{-|
Copyright  :  (C) 2013-2016, University of Twente,
                  2021,      QBayLogic B.V.,
License    :  BSD2 (see the file LICENSE)
Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>

Fixed point numbers

* The 'Num' operators for the given types saturate on overflow,
  and use truncation as the rounding method.
* 'Fixed' has an instance for 'Fractional' meaning you use fractional
  literals @(3.75 :: 'SFixed' 4 18)@.
* Both integer literals and fractional literals are clipped to 'minBound' and
  'maxBound'. __NB__ Needs the `-XNegativeLiterals` language extension to work
  for signed numbers.
* There is no 'Floating' instance for 'Fixed', but you can use @$$('fLit' d)@
  to create 'Fixed' point literal from 'Double' constant at compile-time.
* Use <#constraintsynonyms Constraint synonyms> when writing type signatures
  for polymorphic functions that use 'Fixed' point numbers.

BEWARE: rounding by truncation can introduce errors larger than naively assumed;
e.g. for /Fixed 16 1/, rounding by truncation turns the real number 4.99 to 4.5,
not 5.0, i.e. an error or 0.49 instead of 0.01

BEWARE: rounding by truncation introduces a sign bias!

* Truncation for positive numbers effectively results in: round towards zero.
* Truncation for negative numbers effectively results in: round towards -infinity.

== Reasoning about precision
Givens the real numbers /A/ and /B/, and the corresponding fixed point numbers
/FA+-da/ and /FB+db/, where /da/ and /db/ denote the (potential) error introduced
by truncation w.r.t. the original /A/ and /B/, the arithmetic operators on fixed
point numbers have the following error propagation properties:

* Addition: /da + db/
* Subtraction: /da - db/
* Multiplication: /FA*db + FB*da + da*db/
* Division: /(FA+da)\/(FB+db) - FA\/FB/

=== Additional error from truncation

Given:

>>> 4.13 :: UFixed 16 3
4.125
>>> 20.9 :: UFixed 16 3
20.875

The expected error that we would get from multiplication is:
/20.875*0.005 + 4.125*0.025 + 0.025*0.005 = 0.207625/

>>> 4.13 * 20.9 :: Double
86.317
>>> (4.13 :: UFixed 16 3) `mul` (20.9 :: UFixed 16 3) :: UFixed 32 6
86.109375
>>> 86.109375 + 0.207625 :: Double
86.317

However the /0.109375/ is smaller than /2^-3/, so the regular multiplication
operator that uses truncation introduces an additional error of /0.109375/:

>>> (4.13 :: UFixed 16 3) * (20.9 :: UFixed 16 3) :: UFixed 16 3
86.0

-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-# LANGUAGE Trustworthy #-}

{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
{-# OPTIONS_HADDOCK show-extensions #-}

module Clash.Sized.Fixed
  ( -- * 'SFixed': 'Signed' 'Fixed' point numbers
    SFixed, sf, unSF
    -- * 'UFixed': 'Unsigned' 'Fixed' point numbers
  , UFixed, uf, unUF
      -- * Division
  , divide
    -- * Compile-time 'Double' conversion
  , fLit
    -- * Run-time 'Double' conversion (not synthesizable)
  , fLitR
    -- * 'Fixed' point wrapper
  , Fixed (..), resizeF, fracShift
    -- * Constraint synonyms #constraintsynonyms#
    -- $constraintsynonyms

    -- ** Constraint synonyms for 'SFixed'
  , NumSFixedC, ENumSFixedC, FracSFixedC, ResizeSFC, DivideSC
    -- ** Constraint synonyms for 'UFixed'
  , NumUFixedC, ENumUFixedC, FracUFixedC, ResizeUFC, DivideUC
    -- ** Constraint synonyms for 'Fixed' wrapper
  , NumFixedC, ENumFixedC, FracFixedC, ResizeFC, DivideC
    -- * Proxy
  , asRepProxy, asIntProxy
  )
where

import Control.DeepSeq            (NFData)
import Control.Arrow              ((***), second)
import Data.Bits                  (Bits (..), FiniteBits)
import Data.Data                  (Data)
import Data.Default.Class         (Default (..))
import Data.Either                (isLeft)
import Data.Kind                  (Type)
import Text.Read                  (Read(..))
import Data.List                  (find)
import Data.Proxy                 (Proxy (..))
import Data.Ratio                 ((%), denominator, numerator)
import Data.Typeable              (Typeable, TypeRep, typeRep, typeOf)
import GHC.TypeLits               (KnownNat, Nat, type (+), natVal)
import GHC.TypeLits.Extra         (Max)
import Language.Haskell.TH        (Q, appT, conT, litT, mkName,
                                   numTyLit, sigE)
import Language.Haskell.TH.Syntax (Lift(..))
#if MIN_VERSION_template_haskell(2,16,0)
import Language.Haskell.TH.Compat
#endif
#if MIN_VERSION_template_haskell(2,17,0)
import Language.Haskell.TH        (Quote)
import qualified Language.Haskell.TH as TH
#else
import Language.Haskell.TH        (TExp, TypeQ)
#endif
import Test.QuickCheck            (Arbitrary, CoArbitrary)

import Clash.Class.BitPack        (BitPack (..))
import Clash.Class.Num            (ExtendingNum (..), SaturatingNum (..),
                                   SaturationMode (..), boundedAdd, boundedSub,
                                   boundedMul)
import Clash.Class.Resize         (Resize (..))
import Clash.Promoted.Nat         (SNat, natToNum, natToInteger)
import Clash.Class.BitPack.BitIndex (lsb, msb, split)
import Clash.Class.BitPack.BitReduction (reduceAnd, reduceOr)
import Clash.Sized.BitVector      (BitVector, (++#))
import Clash.Sized.Signed         (Signed)
import Clash.Sized.Unsigned       (Unsigned)
import Clash.XException
  (ShowX (..), NFDataX (..), isX, errorX, showsPrecXWith, fromJustX)

{- $setup
>>> :set -XDataKinds
>>> :set -XTemplateHaskell
>>> import Clash.Prelude
>>> let n = $$(fLit pi) :: SFixed 4 4
-}

-- | 'Fixed'-point number
--
-- Where:
--
-- * @rep@ is the underlying representation
--
-- * @int@ is the number of bits used to represent the integer part
--
-- * @frac@ is the number of bits used to represent the fractional part
--
-- The 'Num' operators for this type saturate to 'maxBound' on overflow and
-- 'minBound' on underflow, and use truncation as the rounding method.
--
-- Fixed has the <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/roles.html type role>
--
-- >>> :i Fixed
-- type role Fixed representational nominal nominal
-- ...
--
-- as it is safe to coerce between different compatible underlying types, but
-- not necessasrily safe to coerce between different widths of this type.  To
-- change the width, use the functions in the 'Clash.Class.Resize.Resize' class.
newtype Fixed (rep :: Nat -> Type) (int :: Nat) (frac :: Nat) =
  Fixed { Fixed rep int frac -> rep (int + frac)
unFixed :: rep (int + frac) }

deriving instance NFData (rep (int + frac)) => NFData (Fixed rep int frac)
deriving instance (Typeable rep, Typeable int, Typeable frac
                  , Data (rep (int + frac))) => Data (Fixed rep int frac)
deriving instance Eq (rep (int + frac))      => Eq (Fixed rep int frac)
deriving instance Ord (rep (int + frac))     => Ord (Fixed rep int frac)
deriving instance Bounded (rep (int + frac)) => Bounded (Fixed rep int frac)
deriving instance Default (rep (int + frac)) => Default (Fixed rep int frac)
deriving instance Arbitrary (rep (int + frac)) => Arbitrary (Fixed rep int frac)
deriving instance CoArbitrary (rep (int + frac)) => CoArbitrary (Fixed rep int frac)
deriving instance FiniteBits (rep (int + frac)) => FiniteBits (Fixed rep int frac)

-- | Instance functions do not saturate.
-- Meaning that \"@\`shiftL\` 1 == 'satMul' 'SatWrap' 2'@\"
deriving instance Bits (rep (int + frac)) => Bits (Fixed rep int frac)

-- | Signed 'Fixed'-point number, with @int@ integer bits (including sign-bit)
-- and @frac@ fractional bits.
--
-- * The range 'SFixed' @int@ @frac@ numbers is: [-(2^(@int@ -1)) ..
-- 2^(@int@-1) - 2^-@frac@ ]
-- * The resolution of 'SFixed' @int@ @frac@ numbers is: 2^@frac@
-- * The 'Num' operators for this type saturate on overflow,
--   and use truncation as the rounding method.
--
-- >>>  maxBound :: SFixed 3 4
-- 3.9375
-- >>> minBound :: SFixed 3 4
-- -4.0
-- >>> read (show (maxBound :: SFixed 3 4)) :: SFixed 3 4
-- 3.9375
-- >>> 1 + 2 :: SFixed 3 4
-- 3.0
-- >>> 2 + 3 :: SFixed 3 4
-- 3.9375
-- >>> (-2) + (-3) :: SFixed 3 4
-- -4.0
-- >>> 1.375 * (-0.8125) :: SFixed 3 4
-- -1.125
-- >>> (1.375 :: SFixed 3 4) `mul` (-0.8125 :: SFixed 3 4) :: SFixed 6 8
-- -1.1171875
-- >>> (2 :: SFixed 3 4) `add` (3 :: SFixed 3 4) :: SFixed 4 4
-- 5.0
-- >>> (-2 :: SFixed 3 4) `add` (-3 :: SFixed 3 4) :: SFixed 4 4
-- -5.0
type SFixed = Fixed Signed

-- | Unsigned 'Fixed'-point number, with @int@ integer bits and @frac@
-- fractional bits
--
-- * The range 'UFixed' @int@ @frac@ numbers is: [0 .. 2^@int@ - 2^-@frac@ ]
-- * The resolution of 'UFixed' @int@ @frac@ numbers is: 2^@frac@
-- * The 'Num' operators for this type saturate on overflow,
--   and use truncation as the rounding method.
--
-- >>> maxBound :: UFixed 3 4
-- 7.9375
-- >>> minBound :: UFixed 3 4
-- 0.0
-- >>> 1 + 2 :: UFixed 3 4
-- 3.0
-- >>> 2 + 6 :: UFixed 3 4
-- 7.9375
-- >>> 1 - 3 :: UFixed 3 4
-- 0.0
-- >>> 1.375 * 0.8125 :: UFixed 3 4
-- 1.0625
-- >>> (1.375 :: UFixed 3 4) `mul` (0.8125 :: UFixed 3 4) :: UFixed 6 8
-- 1.1171875
-- >>> (2 :: UFixed 3 4) `add` (6 :: UFixed 3 4) :: UFixed 4 4
-- 8.0
--
-- However, 'sub' does not saturate to 'minBound' on underflow:
--
-- >>> (1 :: UFixed 3 4) `sub` (3 :: UFixed 3 4) :: UFixed 4 4
-- 14.0
type UFixed = Fixed Unsigned

{-# INLINE sf #-}
-- | Treat a 'Signed' integer as a @Signed@ 'Fixed'-@point@ integer
--
-- >>> sf d4 (-22 :: Signed 7)
-- -1.375
sf
  :: SNat frac
  -- ^ Position of the virtual @point@
  -> Signed (int + frac)
  -- ^ The 'Signed' integer
  -> SFixed int frac
sf :: SNat frac -> Signed (int + frac) -> SFixed int frac
sf SNat frac
_ Signed (int + frac)
fRep = Signed (int + frac) -> SFixed int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed Signed (int + frac)
fRep

{-# INLINE unSF #-}
-- | See the underlying representation of a Signed Fixed-point integer
unSF :: SFixed int frac
     -> Signed (int + frac)
unSF :: SFixed int frac -> Signed (int + frac)
unSF (Fixed Signed (int + frac)
fRep) = Signed (int + frac)
fRep

{-# INLINE uf #-}
-- | Treat an 'Unsigned' integer as a @Unsigned@ 'Fixed'-@point@ number
--
-- >>> uf d4 (92 :: Unsigned 7)
-- 5.75
uf
  :: SNat frac
  -- ^ Position of the virtual @point@
  -> Unsigned (int + frac)
  -- ^ The 'Unsigned' integer
  -> UFixed int frac
uf :: SNat frac -> Unsigned (int + frac) -> UFixed int frac
uf SNat frac
_ Unsigned (int + frac)
fRep = Unsigned (int + frac) -> UFixed int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed Unsigned (int + frac)
fRep

{-# INLINE unUF #-}
-- | See the underlying representation of an Unsigned Fixed-point integer
unUF :: UFixed int frac
     -> Unsigned (int + frac)
unUF :: UFixed int frac -> Unsigned (int + frac)
unUF (Fixed Unsigned (int + frac)
fRep) = Unsigned (int + frac)
fRep

{-# INLINE asRepProxy #-}
-- | 'Fixed' as a 'Proxy' for it's representation type @rep@
asRepProxy :: Fixed rep int frac -> Proxy rep
asRepProxy :: Fixed rep int frac -> Proxy rep
asRepProxy Fixed rep int frac
_ = Proxy rep
forall k (t :: k). Proxy t
Proxy

{-# INLINE asIntProxy #-}
-- | 'Fixed' as a 'Proxy' for the number of integer bits @int@
asIntProxy :: Fixed rep int frac -> Proxy int
asIntProxy :: Fixed rep int frac -> Proxy int
asIntProxy Fixed rep int frac
_ = Proxy int
forall k (t :: k). Proxy t
Proxy

-- | Get the position of the virtual @point@ of a 'Fixed'-@point@ number
fracShift :: KnownNat frac => Fixed rep int frac -> Int
fracShift :: Fixed rep int frac -> Int
fracShift Fixed rep int frac
fx = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Fixed rep int frac -> Integer
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal Fixed rep int frac
fx)

instance ( size ~ (int + frac), KnownNat frac, Integral (rep size)
         ) => Show (Fixed rep int frac) where
  show :: Fixed rep int frac -> String
show f :: Fixed rep int frac
f@(Fixed rep (int + frac)
fRep) =
      String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ ((Int -> ShowS) -> (Int, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> ShowS
pad ((Int, String) -> String)
-> (Ratio Integer -> (Int, String)) -> Ratio Integer -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ratio Integer -> String) -> (Int, Ratio Integer) -> (Int, String)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Integer -> String
forall a. Show a => a -> String
show (Integer -> String)
-> (Ratio Integer -> Integer) -> Ratio Integer -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio Integer -> Integer
forall a. Ratio a -> a
numerator) ((Int, Ratio Integer) -> (Int, String))
-> (Ratio Integer -> (Int, Ratio Integer))
-> Ratio Integer
-> (Int, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                   Maybe (Int, Ratio Integer) -> (Int, Ratio Integer)
forall a. HasCallStack => Maybe a -> a
fromJustX (Maybe (Int, Ratio Integer) -> (Int, Ratio Integer))
-> (Ratio Integer -> Maybe (Int, Ratio Integer))
-> Ratio Integer
-> (Int, Ratio Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Ratio Integer) -> Bool)
-> [(Int, Ratio Integer)] -> Maybe (Int, Ratio Integer)
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find ((Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
1) (Integer -> Bool)
-> ((Int, Ratio Integer) -> Integer)
-> (Int, Ratio Integer)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio Integer -> Integer
forall a. Ratio a -> a
denominator (Ratio Integer -> Integer)
-> ((Int, Ratio Integer) -> Ratio Integer)
-> (Int, Ratio Integer)
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Ratio Integer) -> Ratio Integer
forall a b. (a, b) -> b
snd) ([(Int, Ratio Integer)] -> Maybe (Int, Ratio Integer))
-> (Ratio Integer -> [(Int, Ratio Integer)])
-> Ratio Integer
-> Maybe (Int, Ratio Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                   ((Int, Ratio Integer) -> (Int, Ratio Integer))
-> (Int, Ratio Integer) -> [(Int, Ratio Integer)]
forall a. (a -> a) -> a -> [a]
iterate (Int -> Int
forall a. Enum a => a -> a
succ (Int -> Int)
-> (Ratio Integer -> Ratio Integer)
-> (Int, Ratio Integer)
-> (Int, Ratio Integer)
forall (a :: Type -> Type -> Type) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
*Ratio Integer
10)) ((Int, Ratio Integer) -> [(Int, Ratio Integer)])
-> (Ratio Integer -> (Int, Ratio Integer))
-> Ratio Integer
-> [(Int, Ratio Integer)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) Int
0 (Ratio Integer -> String) -> Ratio Integer -> String
forall a b. (a -> b) -> a -> b
$ (Integer
nom Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% Integer
denom))
    where
      pad :: Int -> ShowS
pad Int
n String
str = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length String
str) Char
'0' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str

      nF :: Int
nF        = Fixed rep int frac -> Int
forall (frac :: Nat) (rep :: Nat -> Type) (int :: Nat).
KnownNat frac =>
Fixed rep int frac -> Int
fracShift Fixed rep int frac
f
      fRepI :: Integer
fRepI     = rep size -> Integer
forall a. Integral a => a -> Integer
toInteger rep size
rep (int + frac)
fRep
      fRepI_abs :: Integer
fRepI_abs = Integer -> Integer
forall a. Num a => a -> a
abs Integer
fRepI
      i :: String
i         = if Integer
fRepI Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: Integer -> String
forall a. Show a => a -> String
show (Integer
fRepI_abs Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
nF)
                               else Integer -> String
forall a. Show a => a -> String
show (Integer
fRepI Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
nF)
      nom :: Integer
nom       = if Integer
fRepI Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Integer
fRepI_abs Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. ((Integer
2 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
nF) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
                               else Integer
fRepI Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. ((Integer
2 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
nF) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
      denom :: Integer
denom     = Integer
2 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
nF

instance ( size ~ (int + frac), KnownNat frac, Integral (rep size)
         ) => ShowX (Fixed rep int frac) where
  showsPrecX :: Int -> Fixed rep int frac -> ShowS
showsPrecX = (Int -> Fixed rep int frac -> ShowS)
-> Int -> Fixed rep int frac -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Fixed rep int frac -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance NFDataX (rep (int + frac)) => NFDataX (Fixed rep int frac) where
  deepErrorX :: String -> Fixed rep int frac
deepErrorX = rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep (int + frac) -> Fixed rep int frac)
-> (String -> rep (int + frac)) -> String -> Fixed rep int frac
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> rep (int + frac)
forall a. HasCallStack => String -> a
errorX
  rnfX :: Fixed rep int frac -> ()
rnfX f :: Fixed rep int frac
f@(~(Fixed rep (int + frac)
x)) = if Either String (Fixed rep int frac) -> Bool
forall a b. Either a b -> Bool
isLeft (Fixed rep int frac -> Either String (Fixed rep int frac)
forall a. a -> Either String a
isX Fixed rep int frac
f) then () else rep (int + frac) -> ()
forall a. NFDataX a => a -> ()
rnfX rep (int + frac)
x
  hasUndefined :: Fixed rep int frac -> Bool
hasUndefined f :: Fixed rep int frac
f@(~(Fixed rep (int + frac)
x)) = if Either String (Fixed rep int frac) -> Bool
forall a b. Either a b -> Bool
isLeft (Fixed rep int frac -> Either String (Fixed rep int frac)
forall a. a -> Either String a
isX Fixed rep int frac
f) then Bool
True else rep (int + frac) -> Bool
forall a. NFDataX a => a -> Bool
hasUndefined rep (int + frac)
x
  ensureSpine :: Fixed rep int frac -> Fixed rep int frac
ensureSpine ~(Fixed rep (int + frac)
x) = rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed rep (int + frac)
x

-- | None of the 'Read' class' methods are synthesizable.
instance (size ~ (int + frac), KnownNat frac, Bounded (rep size), Integral (rep size))
      => Read (Fixed rep int frac) where
  readPrec :: ReadPrec (Fixed rep int frac)
readPrec = Double -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat)
       (size :: Nat).
(size ~ (int + frac), KnownNat frac, Bounded (rep size),
 Integral (rep size)) =>
Double -> Fixed rep int frac
fLitR (Double -> Fixed rep int frac)
-> ReadPrec Double -> ReadPrec (Fixed rep int frac)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec Double
forall a. Read a => ReadPrec a
readPrec

{- $constraintsynonyms
Writing polymorphic functions over fixed point numbers can be a potentially
verbose due to the many class constraints induced by the functions and operators
of this module.

Writing a simple multiply-and-accumulate function can already give rise to many
lines of constraints:

@
mac :: ( 'GHC.TypeLits.KnownNat' frac
       , 'GHC.TypeLits.KnownNat' (frac + frac)
       , 'GHC.TypeLits.KnownNat' (int + frac)
       , 'GHC.TypeLits.KnownNat' (1 + (int + frac))
       , 'GHC.TypeLits.KnownNat' ((int + frac) + (int + frac))
       , ((int + int) + (frac + frac)) ~ ((int + frac) + (int + frac))
       )
    => 'SFixed' int frac
    -> 'SFixed' int frac
    -> 'SFixed' int frac
    -> 'SFixed' int frac
mac s x y = s + (x * y)
@

But with constraint synonyms, you can write the type signature like this:

@
mac1 :: 'NumSFixedC' int frac
    => 'SFixed' int frac
    -> 'SFixed' int frac
    -> 'SFixed' int frac
    -> 'SFixed' int frac
mac1 s x y = s + (x * y)
@

Where 'NumSFixedC' refers to the @Constraints@ needed by the operators of
the 'Num' class for the 'SFixed' datatype.

Although the number of constraints for the @mac@ function defined earlier might
be considered small, here is a \"this way lies madness\" example where you
really want to use constraint kinds:

@
mac2 :: ( 'GHC.TypeLits.KnownNat' frac1
        , 'GHC.TypeLits.KnownNat' frac2
        , 'GHC.TypeLits.KnownNat' frac3
        , 'GHC.TypeLits.KnownNat' (Max frac1 frac2)
        , 'GHC.TypeLits.KnownNat' (int1 + frac1)
        , 'GHC.TypeLits.KnownNat' (int2 + frac2)
        , 'GHC.TypeLits.KnownNat' (int3 + frac3)
        , 'GHC.TypeLits.KnownNat' (frac1 + frac2)
        , 'GHC.TypeLits.KnownNat' (Max (frac1 + frac2) frac3)
        , 'GHC.TypeLits.KnownNat' (((int1 + int2) + (frac1 + frac2)) + (int3 + frac3))
        , 'GHC.TypeLits.KnownNat' ((int1 + int2) + (frac1 + frac2))
        , 'GHC.TypeLits.KnownNat' (1 + Max (int1 + frac1) (int2 + frac2))
        , 'GHC.TypeLits.KnownNat' (1 + Max (int1 + int2) int3 + Max (frac1 + frac2) frac3)
        , 'GHC.TypeLits.KnownNat' ((1 + Max int1 int2) + Max frac1 frac2)
        , 'GHC.TypeLits.KnownNat' ((1 + Max ((int1 + int2) + (frac1 + frac2)) (int3 + frac3)))
        , ((int1 + frac1) + (int2 + frac2)) ~ ((int1 + int2) + (frac1 + frac2))
        , (((int1 + int2) + int3) + ((frac1 + frac2) + frac3)) ~ (((int1 + int2) + (frac1 + frac2)) + (int3 + frac3))
        )
     => 'SFixed' int1 frac1
     -> 'SFixed' int2 frac2
     -> 'SFixed' int3 frac3
     -> 'SFixed' (1 + Max (int1 + int2) int3) (Max (frac1 + frac2) frac3)
mac2 x y s = (x \`mul\` y) \`add\` s
@

Which, with the proper constraint kinds can be reduced to:

@
mac3 :: ( 'ENumSFixedC' int1 frac1 int2 frac2
        , 'ENumSFixedC' (int1 + int2) (frac1 + frac2) int3 frac3
        )
     => 'SFixed' int1 frac1
     -> 'SFixed' int2 frac2
     -> 'SFixed' int3 frac3
     -> 'SFixed' (1 + Max (int1 + int2) int3) (Max (frac1 + frac2) frac3)
mac3 x y s = (x \`mul\` y) \`add\` s
@
-}

-- | Constraint for the 'ExtendingNum' instance of 'Fixed'
type ENumFixedC rep int1 frac1 int2 frac2
  = ( Bounded  (rep ((1 + Max int1 int2) + Max frac1 frac2))
    , Num      (rep ((1 + Max int1 int2) + Max frac1 frac2))
    , Bits     (rep ((1 + Max int1 int2) + Max frac1 frac2))
    , ExtendingNum (rep (int1 + frac1)) (rep (int2 + frac2))
    , MResult (rep (int1 + frac1)) (rep (int2 + frac2)) ~
              rep ((int1 + int2) + (frac1 + frac2))
    , KnownNat int1
    , KnownNat int2
    , KnownNat frac1
    , KnownNat frac2
    , Resize   rep
    )

-- | Constraint for the 'ExtendingNum' instance of 'SFixed'
type ENumSFixedC int1 frac1 int2 frac2
  = ( KnownNat (int2 + frac2)
    , KnownNat (1 + Max int1 int2 + Max frac1 frac2)
    , KnownNat (Max frac1 frac2)
    , KnownNat (1 + Max int1 int2)
    , KnownNat (int1 + frac1)
    , KnownNat frac2
    , KnownNat int2
    , KnownNat frac1
    , KnownNat int1
    )

-- | Constraint for the 'ExtendingNum' instance of 'UFixed'
type ENumUFixedC int1 frac1 int2 frac2 =
     ENumSFixedC int1 frac1 int2 frac2

-- | When used in a polymorphic setting, use the following
-- <Clash-Sized-Fixed.html#constraintsynonyms Constraint synonyms> for less
-- verbose type signatures:
--
-- * @'ENumFixedC'  rep frac1 frac2 size1 size2@ for: 'Fixed'
-- * @'ENumSFixedC' int1 frac1 int2 frac2@       for: 'SFixed'
-- * @'ENumUFixedC' int1 frac1 int2 frac2@       for: 'UFixed'
instance ENumFixedC rep int1 frac1 int2 frac2 =>
  ExtendingNum (Fixed rep int1 frac1) (Fixed rep int2 frac2) where
  type AResult (Fixed rep int1 frac1) (Fixed rep int2 frac2) =
               Fixed rep (1 + Max int1 int2) (Max frac1 frac2)
  add :: Fixed rep int1 frac1
-> Fixed rep int2 frac2
-> AResult (Fixed rep int1 frac1) (Fixed rep int2 frac2)
add (Fixed rep (int1 + frac1)
f1) (Fixed rep (int2 + frac2)
f2) =
    let sh1 :: Int
sh1 = forall a. (Num a, KnownNat (Max frac1 frac2)) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @(Max frac1 frac2) Int -> Int -> Int
forall a. Num a => a -> a -> a
- forall a. (Num a, KnownNat frac1) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac1 :: Int
        f1R :: rep ((1 + Max int1 int2) + Max frac1 frac2)
f1R = rep ((1 + Max int1 int2) + Max frac1 frac2)
-> Int -> rep ((1 + Max int1 int2) + Max frac1 frac2)
forall a. Bits a => a -> Int -> a
shiftL (rep (int1 + frac1) -> rep ((1 + Max int1 int2) + Max frac1 frac2)
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize rep (int1 + frac1)
f1) Int
sh1 :: rep ((1 + Max int1 int2) + (Max frac1 frac2))
        sh2 :: Int
sh2 = forall a. (Num a, KnownNat (Max frac1 frac2)) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @(Max frac1 frac2) Int -> Int -> Int
forall a. Num a => a -> a -> a
- forall a. (Num a, KnownNat frac2) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac2 :: Int
        f2R :: rep ((1 + Max int1 int2) + Max frac1 frac2)
f2R = rep ((1 + Max int1 int2) + Max frac1 frac2)
-> Int -> rep ((1 + Max int1 int2) + Max frac1 frac2)
forall a. Bits a => a -> Int -> a
shiftL (rep (int2 + frac2) -> rep ((1 + Max int1 int2) + Max frac1 frac2)
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize rep (int2 + frac2)
f2) Int
sh2 :: rep ((1 + Max int1 int2) + (Max frac1 frac2))
    in  rep ((1 + Max int1 int2) + Max frac1 frac2)
-> Fixed rep (1 + Max int1 int2) (Max frac1 frac2)
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep ((1 + Max int1 int2) + Max frac1 frac2)
f1R rep ((1 + Max int1 int2) + Max frac1 frac2)
-> rep ((1 + Max int1 int2) + Max frac1 frac2)
-> rep ((1 + Max int1 int2) + Max frac1 frac2)
forall a. Num a => a -> a -> a
+ rep ((1 + Max int1 int2) + Max frac1 frac2)
f2R)
  sub :: Fixed rep int1 frac1
-> Fixed rep int2 frac2
-> AResult (Fixed rep int1 frac1) (Fixed rep int2 frac2)
sub (Fixed rep (int1 + frac1)
f1) (Fixed rep (int2 + frac2)
f2) =
    let sh1 :: Int
sh1 = forall a. (Num a, KnownNat (Max frac1 frac2)) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @(Max frac1 frac2) Int -> Int -> Int
forall a. Num a => a -> a -> a
- forall a. (Num a, KnownNat frac1) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac1 :: Int
        f1R :: rep ((1 + Max int1 int2) + Max frac1 frac2)
f1R = rep ((1 + Max int1 int2) + Max frac1 frac2)
-> Int -> rep ((1 + Max int1 int2) + Max frac1 frac2)
forall a. Bits a => a -> Int -> a
shiftL (rep (int1 + frac1) -> rep ((1 + Max int1 int2) + Max frac1 frac2)
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize rep (int1 + frac1)
f1) Int
sh1 :: rep ((1 + Max int1 int2) + (Max frac1 frac2))
        sh2 :: Int
sh2 = forall a. (Num a, KnownNat (Max frac1 frac2)) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @(Max frac1 frac2) Int -> Int -> Int
forall a. Num a => a -> a -> a
- forall a. (Num a, KnownNat frac2) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac2 :: Int
        f2R :: rep ((1 + Max int1 int2) + Max frac1 frac2)
f2R = rep ((1 + Max int1 int2) + Max frac1 frac2)
-> Int -> rep ((1 + Max int1 int2) + Max frac1 frac2)
forall a. Bits a => a -> Int -> a
shiftL (rep (int2 + frac2) -> rep ((1 + Max int1 int2) + Max frac1 frac2)
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize rep (int2 + frac2)
f2) Int
sh2 :: rep ((1 + Max int1 int2) + (Max frac1 frac2))
    in  rep ((1 + Max int1 int2) + Max frac1 frac2)
-> Fixed rep (1 + Max int1 int2) (Max frac1 frac2)
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep ((1 + Max int1 int2) + Max frac1 frac2)
f1R rep ((1 + Max int1 int2) + Max frac1 frac2)
-> rep ((1 + Max int1 int2) + Max frac1 frac2)
-> rep ((1 + Max int1 int2) + Max frac1 frac2)
forall a. Num a => a -> a -> a
- rep ((1 + Max int1 int2) + Max frac1 frac2)
f2R)
  type MResult (Fixed rep int1 frac1) (Fixed rep int2 frac2) =
               Fixed rep (int1 + int2) (frac1 + frac2)
  mul :: Fixed rep int1 frac1
-> Fixed rep int2 frac2
-> MResult (Fixed rep int1 frac1) (Fixed rep int2 frac2)
mul (Fixed rep (int1 + frac1)
fRep1) (Fixed rep (int2 + frac2)
fRep2) = rep ((int1 + int2) + (frac1 + frac2))
-> Fixed rep (int1 + int2) (frac1 + frac2)
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep (int1 + frac1)
-> rep (int2 + frac2)
-> MResult (rep (int1 + frac1)) (rep (int2 + frac2))
forall a b. ExtendingNum a b => a -> b -> MResult a b
mul rep (int1 + frac1)
fRep1 rep (int2 + frac2)
fRep2)

-- | Constraint for the 'Num' instance of 'Fixed'
type NumFixedC rep int frac
  = ( SaturatingNum (rep (int + frac))
    , ExtendingNum (rep (int + frac)) (rep (int + frac))
    , MResult (rep (int + frac)) (rep (int + frac)) ~
              rep ((int + int) + (frac + frac))
    , BitSize (rep ((int + int) + (frac + frac))) ~
              (int + ((int + frac) + frac))
    , BitPack (rep ((int + int) + (frac + frac)))
    , Bits    (rep ((int + int) + (frac + frac)))
    , BitPack (rep (int + frac))
    , Bits    (rep (int + frac))
    , Integral (rep (int + frac))
    , Resize  rep
    , Typeable rep
    , KnownNat int
    , KnownNat frac
    )

-- | Constraint for the 'Num' instance of 'SFixed'
type NumSFixedC int frac =
  ( KnownNat ((int + int) + (frac + frac))
  , KnownNat (frac + frac)
  , KnownNat (int + int)
  , KnownNat (int + frac)
  , KnownNat frac
  , KnownNat int
  )

-- | Constraint for the 'Num' instance of 'UFixed'
type NumUFixedC int frac =
     NumSFixedC int frac

-- | The operators of this instance saturate on overflow, and use truncation as
-- the rounding method.
--
-- When used in a polymorphic setting, use the following
-- <Clash-Sized-Fixed.html#constraintsynonyms Constraint synonyms> for less
-- verbose type signatures:
--
-- * @'NumFixedC' frac rep size@ for: @'Fixed' frac rep size@
-- * @'NumSFixedC' int frac@     for: @'SFixed' int frac@
-- * @'NumUFixedC' int frac@     for: @'UFixed' int frac@
instance (NumFixedC rep int frac) => Num (Fixed rep int frac) where
  + :: Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
(+)              = Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
forall a. SaturatingNum a => a -> a -> a
boundedAdd
  * :: Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
(*)              = Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
forall a. SaturatingNum a => a -> a -> a
boundedMul
  (-)              = Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
forall a. SaturatingNum a => a -> a -> a
boundedSub
  negate :: Fixed rep int frac -> Fixed rep int frac
negate           = Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
forall a. SaturatingNum a => a -> a -> a
boundedSub (rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed rep (int + frac)
0)
  abs :: Fixed rep int frac -> Fixed rep int frac
abs    (Fixed rep (int + frac)
a) = rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep (int + frac) -> rep (int + frac)
forall a. Num a => a -> a
abs rep (int + frac)
a)
  signum :: Fixed rep int frac -> Fixed rep int frac
signum (Fixed rep (int + frac)
a)
    | rep (int + frac)
a rep (int + frac) -> rep (int + frac) -> Bool
forall a. Eq a => a -> a -> Bool
== rep (int + frac)
0       = Fixed rep int frac
0
    | rep (int + frac)
a rep (int + frac) -> rep (int + frac) -> Bool
forall a. Ord a => a -> a -> Bool
<  rep (int + frac)
0       = Fixed rep int frac
-1
    | Bool
otherwise    = Fixed rep int frac
1
  fromInteger :: Integer -> Fixed rep int frac
fromInteger Integer
i    = let fSH :: Int
fSH = forall a. (Num a, KnownNat frac) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac
                         res :: Integer
res = Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
fSH
                         rMax :: Integer
rMax = rep (int + frac) -> Integer
forall a. Integral a => a -> Integer
toInteger (rep (int + frac)
forall a. Bounded a => a
maxBound :: rep (int + frac))
                         rMin :: Integer
rMin = rep (int + frac) -> Integer
forall a. Integral a => a -> Integer
toInteger (rep (int + frac)
forall a. Bounded a => a
minBound :: rep (int + frac))
                         sat :: Integer
sat | Integer
res Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
rMax = Integer
rMax
                             | Integer
res Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
rMin = Integer
rMin
                             | Bool
otherwise  = Integer
res
                     in  rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (Integer -> rep (int + frac)
forall a. Num a => Integer -> a
fromInteger Integer
sat)

instance (BitPack (rep (int + frac))) => BitPack (Fixed rep int frac) where
  type BitSize (Fixed rep int frac) = BitSize (rep (int + frac))
  pack :: Fixed rep int frac -> BitVector (BitSize (Fixed rep int frac))
pack   (Fixed rep (int + frac)
fRep) = rep (int + frac) -> BitVector (BitSize (rep (int + frac)))
forall a. BitPack a => a -> BitVector (BitSize a)
pack rep (int + frac)
fRep
  unpack :: BitVector (BitSize (Fixed rep int frac)) -> Fixed rep int frac
unpack BitVector (BitSize (Fixed rep int frac))
bv           = rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (BitVector (BitSize (rep (int + frac))) -> rep (int + frac)
forall a. BitPack a => BitVector (BitSize a) -> a
unpack BitVector (BitSize (rep (int + frac)))
BitVector (BitSize (Fixed rep int frac))
bv)

instance (Lift (rep (int + frac)), KnownNat frac, KnownNat int, Typeable rep) =>
  Lift (Fixed rep int frac) where
  lift :: Fixed rep int frac -> Q Exp
lift f :: Fixed rep int frac
f@(Fixed rep (int + frac)
fRep) = Q Exp -> TypeQ -> Q Exp
sigE [| Fixed fRep |]
                          (TypeRep -> Integer -> Integer -> TypeQ
decFixed (Proxy rep -> TypeRep
forall k (proxy :: k -> Type) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Fixed rep int frac -> Proxy rep
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
Fixed rep int frac -> Proxy rep
asRepProxy Fixed rep int frac
f))
                                    (Proxy int -> Integer
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal (Fixed rep int frac -> Proxy int
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
Fixed rep int frac -> Proxy int
asIntProxy Fixed rep int frac
f))
                                    (Fixed rep int frac -> Integer
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal Fixed rep int frac
f))
#if MIN_VERSION_template_haskell(2,16,0)
  liftTyped :: Fixed rep int frac -> Q (TExp (Fixed rep int frac))
liftTyped = Fixed rep int frac -> Q (TExp (Fixed rep int frac))
forall a. Lift a => a -> Q (TExp a)
liftTypedFromUntyped
#endif

#if MIN_VERSION_template_haskell(2,17,0)
decFixed :: Quote m => TypeRep -> Integer -> Integer -> m TH.Type
#else
decFixed :: TypeRep -> Integer -> Integer -> TypeQ
#endif
decFixed :: TypeRep -> Integer -> Integer -> TypeQ
decFixed TypeRep
r Integer
i Integer
f = do
  (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''Fixed) [ Name -> TypeQ
conT (String -> Name
mkName (TypeRep -> String
forall a. Show a => a -> String
show TypeRep
r))
                            , TyLitQ -> TypeQ
litT (Integer -> TyLitQ
numTyLit Integer
i)
                            , TyLitQ -> TypeQ
litT (Integer -> TyLitQ
numTyLit Integer
f)
                            ]

-- | Constraint for the 'resizeF' function
type ResizeFC rep int1 frac1 int2 frac2
  = ( Resize   rep
    , Ord      (rep (int1 + frac1))
    , Num      (rep (int1 + frac1))
    , Bits     (rep (int1 + frac1))
    , Bits     (rep (int2 + frac2))
    , Bounded  (rep (int2 + frac2))
    , KnownNat int1
    , KnownNat frac1
    , KnownNat int2
    , KnownNat frac2
    )

-- | Constraint for the 'resizeF' function, specialized for 'SFixed'
type ResizeSFC int1 frac1 int2 frac2
  = ( KnownNat int1
    , KnownNat frac1
    , KnownNat int2
    , KnownNat frac2
    , KnownNat (int2 + frac2)
    , KnownNat (int1 + frac1)
    )

-- | Constraint for the 'resizeF' function, specialized for 'UFixed'
type ResizeUFC int1 frac1 int2 frac2 =
     ResizeSFC int1 frac1 int2 frac2

{-# INLINE resizeF #-}
-- | Saturating resize operation, truncates for rounding
--
-- >>> 0.8125 :: SFixed 3 4
-- 0.8125
-- >>> resizeF (0.8125 :: SFixed 3 4) :: SFixed 2 3
-- 0.75
-- >>> 3.4 :: SFixed 3 4
-- 3.375
-- >>> resizeF (3.4 :: SFixed 3 4) :: SFixed 2 3
-- 1.875
-- >>> maxBound :: SFixed 2 3
-- 1.875
--
-- When used in a polymorphic setting, use the following
-- <#constraintsynonyms Constraint synonyms> for less verbose type signatures:
--
-- * @'ResizeFC' rep int1 frac1 int2 frac2@ for:
--   @'Fixed' rep int1 frac1 -> 'Fixed' rep int2 frac2@
--
-- * @'ResizeSFC' int1 frac1 int2 frac2@ for:
--   @'SFixed' int1 frac1 -> 'SFixed' int2 frac2@
--
-- * @'ResizeUFC' rep int1 frac1 int2 frac2@ for:
--   @'UFixed' int1 frac1 -> 'UFixed' int2 frac2@
resizeF
  :: forall rep int1 frac1 int2 frac2
   . ResizeFC rep int1 frac1 int2 frac2
  => Fixed rep int1 frac1
  -> Fixed rep int2 frac2
resizeF :: Fixed rep int1 frac1 -> Fixed rep int2 frac2
resizeF (Fixed rep (int1 + frac1)
fRep) = rep (int2 + frac2) -> Fixed rep int2 frac2
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed rep (int2 + frac2)
sat
  where
    fMin :: rep (int2 + frac2)
fMin  = rep (int2 + frac2)
forall a. Bounded a => a
minBound :: rep (int2 + frac2)
    fMax :: rep (int2 + frac2)
fMax  = rep (int2 + frac2)
forall a. Bounded a => a
maxBound :: rep (int2 + frac2)
    argSZ :: Integer
argSZ = KnownNat (int1 + frac1) => Integer
forall (n :: Nat). KnownNat n => Integer
natToInteger @(int1 + frac1)
    resSZ :: Integer
resSZ = KnownNat (int2 + frac2) => Integer
forall (n :: Nat). KnownNat n => Integer
natToInteger @(int2 + frac2)

    argFracSZ :: Int
argFracSZ = forall a. (Num a, KnownNat frac1) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac1
    resFracSZ :: Int
resFracSZ = forall a. (Num a, KnownNat frac2) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac2

    -- All size and frac comparisons and related if-then-else statements should
    -- be optimized away by the compiler
    sat :: rep (int2 + frac2)
sat = if Integer
argSZ Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
resSZ
            -- if the argument is smaller than the result, resize before shift
            then if Int
argFracSZ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
resFracSZ
                    then rep (int1 + frac1) -> rep (int2 + frac2)
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize rep (int1 + frac1)
fRep rep (int2 + frac2) -> Int -> rep (int2 + frac2)
forall a. Bits a => a -> Int -> a
`shiftL` (Int
resFracSZ Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
argFracSZ)
                    else rep (int1 + frac1) -> rep (int2 + frac2)
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize rep (int1 + frac1)
fRep rep (int2 + frac2) -> Int -> rep (int2 + frac2)
forall a. Bits a => a -> Int -> a
`shiftR` (Int
argFracSZ Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
resFracSZ)
            -- if the argument is bigger than the result, shift before resize
            else let mask :: rep (int1 + frac1)
mask = rep (int1 + frac1) -> rep (int1 + frac1)
forall a. Bits a => a -> a
complement (rep (int2 + frac2) -> rep (int1 + frac1)
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize rep (int2 + frac2)
fMax) :: rep (int1 + frac1)
                 in if Int
argFracSZ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
resFracSZ
                       then let shiftedL :: rep (int1 + frac1)
shiftedL         = rep (int1 + frac1)
fRep rep (int1 + frac1) -> Int -> rep (int1 + frac1)
forall a. Bits a => a -> Int -> a
`shiftL`
                                                   (Int
resFracSZ Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
argFracSZ)
                                shiftedL_masked :: rep (int1 + frac1)
shiftedL_masked  = rep (int1 + frac1)
shiftedL rep (int1 + frac1) -> rep (int1 + frac1) -> rep (int1 + frac1)
forall a. Bits a => a -> a -> a
.&. rep (int1 + frac1)
mask
                                shiftedL_resized :: rep (int2 + frac2)
shiftedL_resized = rep (int1 + frac1) -> rep (int2 + frac2)
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize rep (int1 + frac1)
shiftedL
                            in if rep (int1 + frac1)
fRep rep (int1 + frac1) -> rep (int1 + frac1) -> Bool
forall a. Ord a => a -> a -> Bool
>= rep (int1 + frac1)
0
                                  then if rep (int1 + frac1)
shiftedL_masked rep (int1 + frac1) -> rep (int1 + frac1) -> Bool
forall a. Eq a => a -> a -> Bool
== rep (int1 + frac1)
0
                                          then rep (int2 + frac2)
shiftedL_resized
                                          else rep (int2 + frac2)
fMax
                                  else if rep (int1 + frac1)
shiftedL_masked rep (int1 + frac1) -> rep (int1 + frac1) -> Bool
forall a. Eq a => a -> a -> Bool
== rep (int1 + frac1)
mask
                                          then rep (int2 + frac2)
shiftedL_resized
                                          else rep (int2 + frac2)
fMin
                       else let shiftedR :: rep (int1 + frac1)
shiftedR         = rep (int1 + frac1)
fRep rep (int1 + frac1) -> Int -> rep (int1 + frac1)
forall a. Bits a => a -> Int -> a
`shiftR`
                                                   (Int
argFracSZ Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
resFracSZ)
                                shiftedR_masked :: rep (int1 + frac1)
shiftedR_masked  = rep (int1 + frac1)
shiftedR rep (int1 + frac1) -> rep (int1 + frac1) -> rep (int1 + frac1)
forall a. Bits a => a -> a -> a
.&. rep (int1 + frac1)
mask
                                shiftedR_resized :: rep (int2 + frac2)
shiftedR_resized = rep (int1 + frac1) -> rep (int2 + frac2)
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize rep (int1 + frac1)
shiftedR
                            in if rep (int1 + frac1)
fRep rep (int1 + frac1) -> rep (int1 + frac1) -> Bool
forall a. Ord a => a -> a -> Bool
>= rep (int1 + frac1)
0
                                  then if rep (int1 + frac1)
shiftedR_masked rep (int1 + frac1) -> rep (int1 + frac1) -> Bool
forall a. Eq a => a -> a -> Bool
== rep (int1 + frac1)
0
                                          then rep (int2 + frac2)
shiftedR_resized
                                          else rep (int2 + frac2)
fMax
                                  else if rep (int1 + frac1)
shiftedR_masked rep (int1 + frac1) -> rep (int1 + frac1) -> Bool
forall a. Eq a => a -> a -> Bool
== rep (int1 + frac1)
mask
                                          then rep (int2 + frac2)
shiftedR_resized
                                          else rep (int2 + frac2)
fMin

-- | Convert, at compile-time, a 'Double' /constant/ to a 'Fixed'-point /literal/.
-- The conversion saturates on overflow, and uses truncation as its rounding
-- method.
--
-- So when you type:
--
-- @
-- n = $$('fLit' pi) :: 'SFixed' 4 4
-- @
--
-- The compiler sees:
--
-- @
-- n = 'Fixed' (fromInteger 50) :: 'SFixed' 4 4
-- @
--
-- Upon evaluation you see that the value is rounded / truncated in accordance
-- to the fixed point representation:
--
-- >>> n
-- 3.125
--
-- Further examples:
--
-- >>> sin 0.5 :: Double
-- 0.479425538604203
-- >>> $$(fLit (sin 0.5)) :: SFixed 1 8
-- 0.4765625
-- >>> atan 0.2 :: Double
-- 0.19739555984988078
-- >>> $$(fLit (atan 0.2)) :: SFixed 1 8
-- 0.1953125
-- >>> $$(fLit (atan 0.2)) :: SFixed 1 20
-- 0.19739532470703125
fLit
  :: forall rep int frac size
   . ( size ~ (int + frac)
     , KnownNat frac
     , Bounded (rep size)
     , Integral (rep size) )
  => Double
#if MIN_VERSION_template_haskell(2,17,0)
  -> TH.Code Q (Fixed rep int frac)
#else
  -> Q (TExp (Fixed rep int frac))
#endif
fLit :: Double -> Q (TExp (Fixed rep int frac))
fLit Double
a = [|| Fixed (fromInteger sat) ||]
  where
    rMax :: Integer
rMax      = rep size -> Integer
forall a. Integral a => a -> Integer
toInteger (rep size
forall a. Bounded a => a
maxBound :: rep size)
    rMin :: Integer
rMin      = rep size -> Integer
forall a. Integral a => a -> Integer
toInteger (rep size
forall a. Bounded a => a
minBound :: rep size)
    sat :: Integer
sat       = if Integer
truncated Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
rMax
                   then Integer
rMax
                   else if Integer
truncated Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
rMin
                           then Integer
rMin
                           else Integer
truncated
    truncated :: Integer
truncated = Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
shifted :: Integer
    shifted :: Double
shifted   = Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
2 Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ (KnownNat frac => Integer
forall (n :: Nat). KnownNat n => Integer
natToInteger @frac))

-- | Convert, at run-time, a 'Double' to a 'Fixed'-point.
--
-- __NB__: this function is /not/ synthesizable
--
-- = Creating data-files #creatingdatafiles#
--
-- An example usage of this function is to convert a data file containing
-- 'Double's to a data file with ASCII-encoded binary numbers to be used by a
-- synthesizable function like 'Clash.Prelude.ROM.File.asyncRomFile'. For
-- example, consider a file @Data.txt@ containing:
--
-- @
-- 1.2 2.0 3.0 4.0
-- -1.0 -2.0 -3.5 -4.0
-- @
--
-- which we want to put in a ROM, interpreting them as @8.8@ signed fixed point
-- numbers. What we do is that we first create a conversion utility,
-- @createRomFile@, which uses 'fLitR':
--
-- @createRomFile.hs@:
--
-- @
-- module Main where
--
-- import Clash.Prelude
-- import Clash.Prelude.ROM.File
-- import System.Environment
-- import qualified Data.List as L
--
-- createRomFile
--   :: BitPack a
--   => (Double -> a)
--   -> FilePath
--   -> FilePath
--   -> IO ()
-- createRomFile convert fileR fileW = do
--   f <- readFile fileR
--   let ds :: [Double]
--       ds = L.concat . (L.map . L.map) read . L.map words $ lines f
--       fes = L.map convert ds
--   writeFile fileW ('Clash.Prelude.ROM.File.memFile' Nothing fes)
--
-- toSFixed8_8 :: Double -> SFixed 8 8
-- toSFixed8_8 = 'fLitR'
--
-- main :: IO ()
-- main = do
--   [fileR,fileW] <- getArgs
--   createRomFile toSFixed8_8 fileR fileW
-- @
--
-- We then compile this to an executable:
--
-- @
-- \$ clash --make createRomFile.hs
-- @
--
-- We can then use this utility to convert our @Data.txt@ file which contains
-- 'Double's to a @Data.bin@ file which will containing the desired ASCII-encoded
-- binary data:
--
-- @
-- \$ ./createRomFile \"Data.txt\" \"Data.bin\"
-- @
--
-- Which results in a @Data.bin@ file containing:
--
-- @
-- 0000000100110011
-- 0000001000000000
-- 0000001100000000
-- 0000010000000000
-- 1111111100000000
-- 1111111000000000
-- 1111110010000000
-- 1111110000000000
-- @
--
-- We can then use this @Data.bin@ file in for our ROM:
--
-- @
-- romF :: Unsigned 3 -> Unsigned 3 -> SFixed 8 8
-- romF rowAddr colAddr = 'unpack'
--                      $ 'Clash.Prelude.ROM.File.asyncRomFile' d8 "Data.bin" ((rowAddr * 4) + colAddr)
-- @
--
-- And see that it works as expected:
--
-- @
-- __>>> romF 1 2__
-- -3.5
-- __>>> romF 0 0__
-- 1.19921875
-- @
--
-- == Using Template Haskell
--
-- For those of us who like to live on the edge, another option is to convert
-- our @Data.txt@ at compile-time using
-- <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/template_haskell.html Template Haskell>.
-- For this we first create a module @CreateRomFileTH.hs@:
--
-- @
-- module CreateRomFileTH (romDataFromFile) where
--
-- import Clash.Prelude
-- import Clash.Prelude.ROM.File
-- import qualified Data.List as L
-- import Language.Haskell.TH (ExpQ, litE, stringL)
-- import Language.Haskell.TH.Syntax (qRunIO)
--
-- createRomFile :: BitPack a => (Double -> a)
--               -> FilePath -> FilePath -> IO ()
-- createRomFile convert fileR fileW = do
--   f <- readFile fileR
--   let ds :: [Double]
--       ds = L.concat . (L.map . L.map) read . L.map words $ lines f
--       fes = L.map convert ds
--   writeFile fileW ('Clash.Prelude.ROM.File.memFile' Nothing fes)
--
-- romDataFromFile :: BitPack a => (Double -> a) -> String -> ExpQ
-- romDataFromFile convert fileR = do
--   let fileW = fileR L.++ ".bin"
--   qRunIO (createRomFile convert fileR fileW)
--   litE (stringL fileW)
-- @
--
-- Instead of first converting @Data.txt@ to @Data.bin@, we will now use the
-- @romDataFromFile@ function to convert @Data.txt@ to a new file in the proper
-- format at compile-time of our new @romF'@ function:
--
-- @
-- import Clash.Prelude
-- import CreateRomFileTH
--
-- romF' :: Unsigned 3 -> Unsigned 3 -> SFixed 8 8
-- romF' rowAddr colAddr = unpack $
--   asyncRomFile d8
--                $(romDataFromFile (fLitR :: Double -> SFixed 8 8) "Data.txt") -- Template Haskell splice
--                ((rowAddr * 4) + colAddr)
-- @
--
-- And see that it works just like the @romF@ function from earlier:
--
-- @
-- __>>> romF' 1 2__
-- -3.5
-- __>>> romF' 0 0__
-- 1.19921875
-- @
fLitR
  :: forall rep int frac size
   . ( size ~ (int + frac)
     , KnownNat frac
     , Bounded (rep size)
     , Integral (rep size))
  => Double
  -> Fixed rep int frac
fLitR :: Double -> Fixed rep int frac
fLitR Double
a = rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (Integer -> rep size
forall a. Num a => Integer -> a
fromInteger Integer
sat)
  where
    rMax :: Integer
rMax      = rep size -> Integer
forall a. Integral a => a -> Integer
toInteger (rep size
forall a. Bounded a => a
maxBound :: rep size)
    rMin :: Integer
rMin      = rep size -> Integer
forall a. Integral a => a -> Integer
toInteger (rep size
forall a. Bounded a => a
minBound :: rep size)
    sat :: Integer
sat       = if Integer
truncated Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
rMax
                   then Integer
rMax
                   else if Integer
truncated Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
rMin
                           then Integer
rMin
                           else Integer
truncated
    truncated :: Integer
truncated = Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
shifted :: Integer
    shifted :: Double
shifted   = Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
2 Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ (KnownNat frac => Integer
forall (n :: Nat). KnownNat n => Integer
natToInteger @frac))

-- | These behave similar to 'Prelude.Float', 'Prelude.Double' and
-- 'Prelude.Rational'. 'succ'\/'pred' add\/subtract 1. See the
-- <https://www.haskell.org/onlinereport/haskell2010/haskellch6.html#dx13-131001 Haskell Report>
-- for full details.
--
-- The rules set out there for instances of both 'Enum' and
-- 'Bounded' are also observed. In particular, 'succ' and 'pred' result in a
-- runtime error if the result cannot be represented. See 'satSucc' and
-- 'satPred' for other options.
instance NumFixedC rep int frac => Enum (Fixed rep int frac) where
  succ :: Fixed rep int frac -> Fixed rep int frac
succ Fixed rep int frac
f =
    let err :: Fixed rep int frac
err = String -> Fixed rep int frac
forall a. HasCallStack => String -> a
error (String -> Fixed rep int frac) -> String -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$
             String
"Enum.succ{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Fixed rep int frac -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Fixed rep int frac
f) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}: tried to take 'succ' of "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ Fixed rep int frac -> String
forall a. Show a => a -> String
show Fixed rep int frac
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", causing overflow. Use 'satSucc' and specify a "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"SaturationMode if you need other behavior."
    in case KnownNat int => Integer
forall (n :: Nat). KnownNat n => Integer
natToInteger @int of
         Integer
0 -> Fixed rep int frac
err
         Integer
_ -> if Fixed rep int frac
f Fixed rep int frac -> Fixed rep int frac -> Bool
forall a. Ord a => a -> a -> Bool
> SaturationMode -> Fixed rep int frac -> Fixed rep int frac
forall a. SaturatingNum a => SaturationMode -> a -> a
satPred SaturationMode
SatBound Fixed rep int frac
forall a. Bounded a => a
maxBound then
                Fixed rep int frac
err
              else
                SaturationMode -> Fixed rep int frac -> Fixed rep int frac
forall a. SaturatingNum a => SaturationMode -> a -> a
satSucc SaturationMode
SatWrap Fixed rep int frac
f


  pred :: Fixed rep int frac -> Fixed rep int frac
pred Fixed rep int frac
f =
    let err :: Fixed rep int frac
err = String -> Fixed rep int frac
forall a. HasCallStack => String -> a
error (String -> Fixed rep int frac) -> String -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$
             String
"Enum.pred{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Fixed rep int frac -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Fixed rep int frac
f) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}: tried to take 'pred' of "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ Fixed rep int frac -> String
forall a. Show a => a -> String
show Fixed rep int frac
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", causing negative overflow. Use 'satPred' and "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"specify a SaturationMode if you need other behavior."
    in case KnownNat int => Integer
forall (n :: Nat). KnownNat n => Integer
natToInteger @int of
         Integer
0 -> Fixed rep int frac
err
         Integer
_ -> if Fixed rep int frac
f Fixed rep int frac -> Fixed rep int frac -> Bool
forall a. Ord a => a -> a -> Bool
< SaturationMode -> Fixed rep int frac -> Fixed rep int frac
forall a. SaturatingNum a => SaturationMode -> a -> a
satSucc SaturationMode
SatBound Fixed rep int frac
forall a. Bounded a => a
minBound then
                Fixed rep int frac
err
              else
                SaturationMode -> Fixed rep int frac -> Fixed rep int frac
forall a. SaturatingNum a => SaturationMode -> a -> a
satPred SaturationMode
SatWrap Fixed rep int frac
f

  toEnum :: Int -> Fixed rep int frac
toEnum Int
i =
    if Integer
res Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
rMax Bool -> Bool -> Bool
|| Integer
res Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
rMin then
      String -> Fixed rep int frac
forall a. HasCallStack => String -> a
error (String -> Fixed rep int frac) -> String -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$  String
"Enum.toEnum{"
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Proxy (Fixed rep int frac) -> TypeRep
forall k (proxy :: k -> Type) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy (Fixed rep int frac) -> TypeRep)
-> Proxy (Fixed rep int frac) -> TypeRep
forall a b. (a -> b) -> a -> b
$ Proxy (Fixed rep int frac)
forall k (t :: k). Proxy t
Proxy @(Fixed rep int frac)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}: tag ("
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") is outside of bounds "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Fixed rep int frac, Fixed rep int frac) -> String
forall a. Show a => a -> String
show ( Fixed rep int frac
forall a. Bounded a => a
minBound :: Fixed rep int frac
                    , Fixed rep int frac
forall a. Bounded a => a
maxBound :: Fixed rep int frac)
    else
      rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (Integer -> rep (int + frac)
forall a. Num a => Integer -> a
fromInteger Integer
res)
     where
      sh :: Int
sh   = forall a. (Num a, KnownNat frac) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac
      res :: Integer
res  = Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
sh
      rMax :: Integer
rMax = rep (int + frac) -> Integer
forall a. Integral a => a -> Integer
toInteger (rep (int + frac)
forall a. Bounded a => a
maxBound :: rep (int + frac))
      rMin :: Integer
rMin = rep (int + frac) -> Integer
forall a. Integral a => a -> Integer
toInteger (rep (int + frac)
forall a. Bounded a => a
minBound :: rep (int + frac))

  fromEnum :: Fixed rep int frac -> Int
fromEnum f :: Fixed rep int frac
f@(Fixed rep (int + frac)
fRep) =
    if Integer
res Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
rMax Bool -> Bool -> Bool
|| Integer
res Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
rMin then
      String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$  String
"Enum.fromEnum{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Fixed rep int frac -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Fixed rep int frac
f) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}: value ("
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Fixed rep int frac -> String
forall a. Show a => a -> String
show Fixed rep int frac
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") is outside of Int's bounds "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Integer, Integer) -> String
forall a. Show a => a -> String
show (Integer
rMin, Integer
rMax)
    else
      Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
res
     where
      nF :: Int
nF     = forall a. (Num a, KnownNat frac) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac
      frMask :: rep (int + frac)
frMask = Integer -> rep (int + frac)
forall a. Num a => Integer -> a
fromInteger (Integer -> rep (int + frac)) -> Integer -> rep (int + frac)
forall a b. (a -> b) -> a -> b
$ (Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
nF) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
      offset :: rep (int + frac)
offset = if Fixed rep int frac
f Fixed rep int frac -> Fixed rep int frac -> Bool
forall a. Ord a => a -> a -> Bool
< Fixed rep int frac
0 Bool -> Bool -> Bool
&& rep (int + frac)
fRep rep (int + frac) -> rep (int + frac) -> rep (int + frac)
forall a. Bits a => a -> a -> a
.&. rep (int + frac)
frMask rep (int + frac) -> rep (int + frac) -> Bool
forall a. Eq a => a -> a -> Bool
/= rep (int + frac)
0 then rep (int + frac)
1 else rep (int + frac)
0
      -- res amounts to "truncate f", but without needing all the constraints
      -- for RealFrac.
      res :: Integer
res    = rep (int + frac) -> Integer
forall a. Integral a => a -> Integer
toInteger (rep (int + frac) -> Integer) -> rep (int + frac) -> Integer
forall a b. (a -> b) -> a -> b
$ (rep (int + frac)
fRep rep (int + frac) -> Int -> rep (int + frac)
forall a. Bits a => a -> Int -> a
`shiftR` Int
nF) rep (int + frac) -> rep (int + frac) -> rep (int + frac)
forall a. Num a => a -> a -> a
+ rep (int + frac)
offset
      rMax :: Integer
rMax   = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int)
      rMin :: Integer
rMin   = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
minBound :: Int)

  enumFrom :: Fixed rep int frac -> [Fixed rep int frac]
enumFrom Fixed rep int frac
x1 = Fixed rep int frac -> Fixed rep int frac -> [Fixed rep int frac]
forall a. Enum a => a -> a -> [a]
enumFromTo Fixed rep int frac
x1 Fixed rep int frac
forall a. Bounded a => a
maxBound
  enumFromThen :: Fixed rep int frac -> Fixed rep int frac -> [Fixed rep int frac]
enumFromThen (Fixed rep (int + frac)
x1Rep) (Fixed rep (int + frac)
x2Rep) =
    (rep (int + frac) -> Fixed rep int frac)
-> [rep (int + frac)] -> [Fixed rep int frac]
forall a b. (a -> b) -> [a] -> [b]
map rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed ([rep (int + frac)] -> [Fixed rep int frac])
-> [rep (int + frac)] -> [Fixed rep int frac]
forall a b. (a -> b) -> a -> b
$ rep (int + frac) -> rep (int + frac) -> [rep (int + frac)]
forall a. Enum a => a -> a -> [a]
enumFromThen rep (int + frac)
x1Rep rep (int + frac)
x2Rep

  enumFromTo :: Fixed rep int frac -> Fixed rep int frac -> [Fixed rep int frac]
enumFromTo x1 :: Fixed rep int frac
x1@(Fixed rep (int + frac)
x1Rep) y :: Fixed rep int frac
y@(Fixed rep (int + frac)
yRep)
    | Fixed rep int frac
yPlusHalf Fixed rep int frac -> Fixed rep int frac -> Bool
forall a. Ord a => a -> a -> Bool
< Fixed rep int frac
x1 = []
    | Bool
closeToMax     = [Fixed rep int frac
x1]
    | Bool
otherwise      =  (rep (int + frac) -> Fixed rep int frac)
-> [rep (int + frac)] -> [Fixed rep int frac]
forall a b. (a -> b) -> [a] -> [b]
map rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed ([rep (int + frac)] -> [Fixed rep int frac])
-> [rep (int + frac)] -> [Fixed rep int frac]
forall a b. (a -> b) -> a -> b
$ rep (int + frac)
-> rep (int + frac) -> rep (int + frac) -> [rep (int + frac)]
forall a. Enum a => a -> a -> a -> [a]
enumFromThenTo
                                      rep (int + frac)
x1Rep
                                      (Fixed rep int frac -> rep (int + frac)
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
Fixed rep int frac -> rep (int + frac)
unFixed (Fixed rep int frac -> rep (int + frac))
-> Fixed rep int frac -> rep (int + frac)
forall a b. (a -> b) -> a -> b
$ SaturationMode -> Fixed rep int frac -> Fixed rep int frac
forall a. SaturatingNum a => SaturationMode -> a -> a
satSucc SaturationMode
SatWrap Fixed rep int frac
x1)
                                      (Fixed rep int frac -> rep (int + frac)
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
Fixed rep int frac -> rep (int + frac)
unFixed (Fixed rep int frac -> rep (int + frac))
-> Fixed rep int frac -> rep (int + frac)
forall a b. (a -> b) -> a -> b
$ Fixed rep int frac
yPlusHalf)
   where
    closeToMax :: Bool
closeToMax = KnownNat int => Integer
forall (n :: Nat). KnownNat n => Integer
natToInteger @int Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
|| Fixed rep int frac
x1 Fixed rep int frac -> Fixed rep int frac -> Bool
forall a. Ord a => a -> a -> Bool
> SaturationMode -> Fixed rep int frac -> Fixed rep int frac
forall a. SaturatingNum a => SaturationMode -> a -> a
satPred SaturationMode
SatBound Fixed rep int frac
forall a. Bounded a => a
maxBound
    nF :: Int
nF = forall a. (Num a, KnownNat frac) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac
    yPlusHalf :: Fixed rep int frac
yPlusHalf | Int
nF Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0       = Fixed rep int frac
y
              | rep (int + frac) -> Bool
forall a. Bits a => a -> Bool
isSigned rep (int + frac)
yRep = Fixed rep int frac
y Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
forall a. Num a => a -> a -> a
- (rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep (int + frac) -> Fixed rep int frac)
-> rep (int + frac) -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$ rep (int + frac)
-1 rep (int + frac) -> Int -> rep (int + frac)
forall a. Bits a => a -> Int -> a
`shiftL` (Int
nF Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
              | Bool
otherwise     = Fixed rep int frac
y Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
forall a. Num a => a -> a -> a
+ (rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep (int + frac) -> Fixed rep int frac)
-> rep (int + frac) -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$ rep (int + frac)
1 rep (int + frac) -> Int -> rep (int + frac)
forall a. Bits a => a -> Int -> a
`shiftL` (Int
nF Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))

  enumFromThenTo :: Fixed rep int frac
-> Fixed rep int frac -> Fixed rep int frac -> [Fixed rep int frac]
enumFromThenTo = Fixed rep int frac
-> Fixed rep int frac -> Fixed rep int frac -> [Fixed rep int frac]
forall f (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
(NumFixedC rep int frac, f ~ Fixed rep int frac) =>
f -> f -> f -> [f]
enumFromThenTo#

-- Inspired by Enum Int from GHC.Enum in base-4.14.1.0
--
-- Note that if x2 /= x1, it is guaranteed that (int + frac) >= 1, because if it
-- were zero there would only be one concrete value. This fact is relied upon in
-- enumFromThenToUp and enumFromThenToDown, which would have undefined behavior
-- for (int + frac) == 0.
enumFromThenTo#
  :: forall f rep int frac
   . ( NumFixedC rep int frac
     , f ~ Fixed rep int frac)
  => f
  -> f
  -> f
  -> [f]
enumFromThenTo# :: f -> f -> f -> [f]
enumFromThenTo# f
x1 f
x2 f
y
  | f
x2 f -> f -> Bool
forall a. Eq a => a -> a -> Bool
== f
x1  = if f
y f -> f -> Bool
forall a. Ord a => a -> a -> Bool
< f
x1 then
                  []
                else
                  f -> [f]
forall a. a -> [a]
repeat f
x1
  | f
x2 f -> f -> Bool
forall a. Ord a => a -> a -> Bool
> f
x1   = f -> f -> f -> [f]
forall f (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
(NumFixedC rep int frac, f ~ Fixed rep int frac) =>
f -> f -> f -> [f]
enumFromThenToUp f
x1 f
x2 f
y
  | Bool
otherwise = f -> f -> f -> [f]
forall f (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
(NumFixedC rep int frac, f ~ Fixed rep int frac) =>
f -> f -> f -> [f]
enumFromThenToDown f
x1 f
x2 f
y

enumFromThenToUp
  :: forall f rep int frac
   . ( NumFixedC rep int frac
     , f ~ Fixed rep int frac)
  => f
  -> f
  -> f
  -> [f]
enumFromThenToUp :: f -> f -> f -> [f]
enumFromThenToUp f
x1 f
x2 f
y
  | f
y f -> f -> Bool
forall a. Ord a => a -> a -> Bool
< f
x1 = let y' :: f
y' = SaturationMode -> f -> f -> f
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satAdd SaturationMode
SatWrap f
y f
halfDelta  -- Never wraps
             in if f
y' f -> f -> Bool
forall a. Ord a => a -> a -> Bool
< f
x1 Bool -> Bool -> Bool
|| (Bool
isMinusHalf Bool -> Bool -> Bool
&& f
y' f -> f -> Bool
forall a. Ord a => a -> a -> Bool
<= f
x1) then
                  []
                else
                  [f
x1]
  | f
y f -> f -> Bool
forall a. Ord a => a -> a -> Bool
< f
x2 = let x2' :: f
x2' = SaturationMode -> f -> f -> f
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satSub SaturationMode
SatWrap f
x2 f
halfDelta  -- Never wraps `
             in if f
y f -> f -> Bool
forall a. Ord a => a -> a -> Bool
> f
x2' Bool -> Bool -> Bool
|| (Bool -> Bool
not Bool
isMinusHalf Bool -> Bool -> Bool
&& f
y f -> f -> Bool
forall a. Ord a => a -> a -> Bool
>= f
x2') then
                  [f
x1, f
x2]
                else
                  [f
x1]
  | Bool
otherwise = let y' :: f
y' = SaturationMode -> f -> f -> f
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satSub SaturationMode
SatWrap f
y (f
delta f -> Int -> f
forall a. Bits a => a -> Int -> a
`shiftR` Int
1) -- Does wrap
                    go_up :: f -> [f]
go_up f
x
                      | f
x' f -> f -> Bool
forall a. Ord a => a -> a -> Bool
< f
x            = [f
x]
                      | Bool
isHalf Bool -> Bool -> Bool
&& f
x f -> f -> Bool
forall a. Ord a => a -> a -> Bool
>= f
y' = [f
x]
                      | f
x f -> f -> Bool
forall a. Ord a => a -> a -> Bool
> f
y'            = [f
x]
                      | Bool
otherwise          = f
x f -> [f] -> [f]
forall a. a -> [a] -> [a]
: f -> [f]
go_up f
x'
                     where
                      x' :: f
x' = SaturationMode -> f -> f -> f
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satAdd SaturationMode
SatWrap f
x f
delta  -- Does wrap
                in f
x1 f -> [f] -> [f]
forall a. a -> [a] -> [a]
: f -> [f]
go_up f
x2
 where
   delta :: f
delta = SaturationMode -> f -> f -> f
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satSub SaturationMode
SatWrap f
x2 f
x1  -- Does wrap!
   halfDelta :: f
halfDelta = SaturationMode -> f -> f -> f
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satSub SaturationMode
SatWrap (f
x2 f -> Int -> f
forall a. Bits a => a -> Int -> a
`shiftR` Int
1) (f
x1 f -> Int -> f
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)  -- Never wraps
   isHalf :: Bool
isHalf = f -> Bit
forall a. BitPack a => a -> Bit
lsb f
delta Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
== Bit
1
   isMinusHalf :: Bool
isMinusHalf = f -> Bit
forall a. BitPack a => a -> Bit
lsb f
x2 Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
== Bit
0 Bool -> Bool -> Bool
&& f -> Bit
forall a. BitPack a => a -> Bit
lsb f
x1 Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
== Bit
1

enumFromThenToDown
  :: forall f rep int frac
   . ( NumFixedC rep int frac
     , f ~ Fixed rep int frac)
  => f
  -> f
  -> f
  -> [f]
enumFromThenToDown :: f -> f -> f -> [f]
enumFromThenToDown f
x1 f
x2 f
y
  | f
y f -> f -> Bool
forall a. Ord a => a -> a -> Bool
> f
x1 = let y' :: f
y' = SaturationMode -> f -> f -> f
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satSub SaturationMode
SatWrap f
y f
halfDelta  -- Never wraps
             in if f
y' f -> f -> Bool
forall a. Ord a => a -> a -> Bool
> f
x1 Bool -> Bool -> Bool
|| (Bool
isMinusHalf Bool -> Bool -> Bool
&& f
y' f -> f -> Bool
forall a. Ord a => a -> a -> Bool
>= f
x1) then
                  []
                else
                  [f
x1]
  | f
y f -> f -> Bool
forall a. Ord a => a -> a -> Bool
> f
x2 = let x2' :: f
x2' = SaturationMode -> f -> f -> f
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satAdd SaturationMode
SatWrap f
x2 f
halfDelta  -- Never wraps `
             in if f
y f -> f -> Bool
forall a. Ord a => a -> a -> Bool
< f
x2' Bool -> Bool -> Bool
|| (Bool -> Bool
not Bool
isMinusHalf Bool -> Bool -> Bool
&& f
y f -> f -> Bool
forall a. Ord a => a -> a -> Bool
<= f
x2') then
                  [f
x1, f
x2]
                else
                  [f
x1]
  | Bool
otherwise = let y' :: f
y' = SaturationMode -> f -> f -> f
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satAdd SaturationMode
SatWrap f
y (f
delta f -> Int -> f
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)  -- Does wrap
                    go_dn :: f -> [f]
go_dn f
x
                      | f
x' f -> f -> Bool
forall a. Ord a => a -> a -> Bool
> f
x            = [f
x]
                      | Bool
isHalf Bool -> Bool -> Bool
&& f
x f -> f -> Bool
forall a. Ord a => a -> a -> Bool
<= f
y' = [f
x]
                      | f
x f -> f -> Bool
forall a. Ord a => a -> a -> Bool
< f
y'            = [f
x]
                      | Bool
otherwise         = f
x f -> [f] -> [f]
forall a. a -> [a] -> [a]
: f -> [f]
go_dn f
x'
                     where
                      x' :: f
x' = SaturationMode -> f -> f -> f
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satSub SaturationMode
SatWrap f
x f
delta  -- Does wrap
                in f
x1 f -> [f] -> [f]
forall a. a -> [a] -> [a]
: f -> [f]
go_dn f
x2
 where
  delta :: f
delta = SaturationMode -> f -> f -> f
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satSub SaturationMode
SatWrap f
x1 f
x2  -- Does wrap!
  halfDelta :: f
halfDelta = SaturationMode -> f -> f -> f
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satSub SaturationMode
SatWrap (f
x1 f -> Int -> f
forall a. Bits a => a -> Int -> a
`shiftR` Int
1) (f
x2 f -> Int -> f
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)  -- Never wraps
  isHalf :: Bool
isHalf = f -> Bit
forall a. BitPack a => a -> Bit
lsb f
delta Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
== Bit
1
  isMinusHalf :: Bool
isMinusHalf = f -> Bit
forall a. BitPack a => a -> Bit
lsb f
x1 Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
== Bit
0 Bool -> Bool -> Bool
&& f -> Bit
forall a. BitPack a => a -> Bit
lsb f
x2 Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
== Bit
1


instance NumFixedC rep int frac => SaturatingNum (Fixed rep int frac) where
  satAdd :: SaturationMode
-> Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
satAdd SaturationMode
w (Fixed rep (int + frac)
a) (Fixed rep (int + frac)
b) = rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (SaturationMode
-> rep (int + frac) -> rep (int + frac) -> rep (int + frac)
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satAdd SaturationMode
w rep (int + frac)
a rep (int + frac)
b)
  satSub :: SaturationMode
-> Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
satSub  SaturationMode
w (Fixed rep (int + frac)
a) (Fixed rep (int + frac)
b) = rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (SaturationMode
-> rep (int + frac) -> rep (int + frac) -> rep (int + frac)
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satSub SaturationMode
w rep (int + frac)
a rep (int + frac)
b)

  satMul :: SaturationMode
-> Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
satMul SaturationMode
SatWrap (Fixed rep (int + frac)
a) (Fixed rep (int + frac)
b) =
    let res :: MResult (rep (int + frac)) (rep (int + frac))
res  = rep (int + frac)
a rep (int + frac)
-> rep (int + frac)
-> MResult (rep (int + frac)) (rep (int + frac))
forall a b. ExtendingNum a b => a -> b -> MResult a b
`mul` rep (int + frac)
b
        sh :: Int
sh   = forall a. (Num a, KnownNat frac) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac
        res' :: rep ((int + int) + (frac + frac))
res' = rep ((int + int) + (frac + frac))
-> Int -> rep ((int + int) + (frac + frac))
forall a. Bits a => a -> Int -> a
shiftR rep ((int + int) + (frac + frac))
MResult (rep (int + frac)) (rep (int + frac))
res Int
sh
    in  rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep ((int + int) + (frac + frac)) -> rep (int + frac)
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize rep ((int + int) + (frac + frac))
res')

  satMul SaturationMode
SatBound (Fixed rep (int + frac)
a) (Fixed rep (int + frac)
b) =
    let res :: MResult (rep (int + frac)) (rep (int + frac))
res     = rep (int + frac)
a rep (int + frac)
-> rep (int + frac)
-> MResult (rep (int + frac)) (rep (int + frac))
forall a b. ExtendingNum a b => a -> b -> MResult a b
`mul` rep (int + frac)
b
        sh :: Int
sh      = forall a. (Num a, KnownNat frac) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac
        (BitVector int
rL,BitVector ((int + frac) + frac)
rR) = rep ((int + int) + (frac + frac))
-> (BitVector int, BitVector ((int + frac) + frac))
forall a (m :: Nat) (n :: Nat).
(BitPack a, BitSize a ~ (m + n), KnownNat n) =>
a -> (BitVector m, BitVector n)
split rep ((int + int) + (frac + frac))
MResult (rep (int + frac)) (rep (int + frac))
res :: (BitVector int, BitVector (int + frac + frac))
    in  case rep (int + frac) -> Bool
forall a. Bits a => a -> Bool
isSigned rep (int + frac)
a of
          Bool
True  -> let overflow :: Bit
overflow = Bit -> Bit
forall a. Bits a => a -> a
complement (BitVector (1 + int) -> Bit
forall a. BitPack a => a -> Bit
reduceOr (Bit -> BitVector (BitSize Bit)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (BitVector ((int + frac) + frac) -> Bit
forall a. BitPack a => a -> Bit
msb BitVector ((int + frac) + frac)
rR) BitVector 1 -> BitVector int -> BitVector (1 + int)
forall (m :: Nat) (n :: Nat).
KnownNat m =>
BitVector n -> BitVector m -> BitVector (n + m)
++# BitVector int -> BitVector (BitSize (BitVector int))
forall a. BitPack a => a -> BitVector (BitSize a)
pack BitVector int
rL)) Bit -> Bit -> Bit
forall a. Bits a => a -> a -> a
.|.
                                  BitVector (1 + int) -> Bit
forall a. BitPack a => a -> Bit
reduceAnd (Bit -> BitVector (BitSize Bit)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (BitVector ((int + frac) + frac) -> Bit
forall a. BitPack a => a -> Bit
msb BitVector ((int + frac) + frac)
rR) BitVector 1 -> BitVector int -> BitVector (1 + int)
forall (m :: Nat) (n :: Nat).
KnownNat m =>
BitVector n -> BitVector m -> BitVector (n + m)
++# BitVector int -> BitVector (BitSize (BitVector int))
forall a. BitPack a => a -> BitVector (BitSize a)
pack BitVector int
rL)
                   in  case Bit
overflow of
                         Bit
1 -> BitVector (BitSize (Fixed rep int frac)) -> Fixed rep int frac
forall a. BitPack a => BitVector (BitSize a) -> a
unpack (BitVector ((int + frac) + frac)
-> BitVector (BitSize (rep (int + frac)))
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize (BitVector ((int + frac) + frac)
-> Int -> BitVector ((int + frac) + frac)
forall a. Bits a => a -> Int -> a
shiftR BitVector ((int + frac) + frac)
rR Int
sh))
                         Bit
_ -> case BitVector int -> Bit
forall a. BitPack a => a -> Bit
msb BitVector int
rL of
                                Bit
0 -> Fixed rep int frac
forall a. Bounded a => a
maxBound
                                Bit
_ -> Fixed rep int frac
forall a. Bounded a => a
minBound
          Bool
False -> case BitVector int
rL of
                     BitVector int
0 -> BitVector (BitSize (Fixed rep int frac)) -> Fixed rep int frac
forall a. BitPack a => BitVector (BitSize a) -> a
unpack (BitVector ((int + frac) + frac)
-> BitVector (BitSize (rep (int + frac)))
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize (BitVector ((int + frac) + frac)
-> Int -> BitVector ((int + frac) + frac)
forall a. Bits a => a -> Int -> a
shiftR BitVector ((int + frac) + frac)
rR Int
sh))
                     BitVector int
_ -> Fixed rep int frac
forall a. Bounded a => a
maxBound

  satMul SaturationMode
SatZero (Fixed rep (int + frac)
a) (Fixed rep (int + frac)
b) =
    let res :: MResult (rep (int + frac)) (rep (int + frac))
res     = rep (int + frac)
a rep (int + frac)
-> rep (int + frac)
-> MResult (rep (int + frac)) (rep (int + frac))
forall a b. ExtendingNum a b => a -> b -> MResult a b
`mul` rep (int + frac)
b
        sh :: Int
sh      = forall a. (Num a, KnownNat frac) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac
        (BitVector int
rL,BitVector ((int + frac) + frac)
rR) = rep ((int + int) + (frac + frac))
-> (BitVector int, BitVector ((int + frac) + frac))
forall a (m :: Nat) (n :: Nat).
(BitPack a, BitSize a ~ (m + n), KnownNat n) =>
a -> (BitVector m, BitVector n)
split rep ((int + int) + (frac + frac))
MResult (rep (int + frac)) (rep (int + frac))
res :: (BitVector int, BitVector (int + frac + frac))
    in  case rep (int + frac) -> Bool
forall a. Bits a => a -> Bool
isSigned rep (int + frac)
a of
          Bool
True  -> let overflow :: Bit
overflow = Bit -> Bit
forall a. Bits a => a -> a
complement (BitVector (1 + int) -> Bit
forall a. BitPack a => a -> Bit
reduceOr (Bit -> BitVector (BitSize Bit)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (BitVector ((int + frac) + frac) -> Bit
forall a. BitPack a => a -> Bit
msb BitVector ((int + frac) + frac)
rR) BitVector 1 -> BitVector int -> BitVector (1 + int)
forall (m :: Nat) (n :: Nat).
KnownNat m =>
BitVector n -> BitVector m -> BitVector (n + m)
++# BitVector int -> BitVector (BitSize (BitVector int))
forall a. BitPack a => a -> BitVector (BitSize a)
pack BitVector int
rL)) Bit -> Bit -> Bit
forall a. Bits a => a -> a -> a
.|.
                                  BitVector (1 + int) -> Bit
forall a. BitPack a => a -> Bit
reduceAnd (Bit -> BitVector (BitSize Bit)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (BitVector ((int + frac) + frac) -> Bit
forall a. BitPack a => a -> Bit
msb BitVector ((int + frac) + frac)
rR) BitVector 1 -> BitVector int -> BitVector (1 + int)
forall (m :: Nat) (n :: Nat).
KnownNat m =>
BitVector n -> BitVector m -> BitVector (n + m)
++# BitVector int -> BitVector (BitSize (BitVector int))
forall a. BitPack a => a -> BitVector (BitSize a)
pack BitVector int
rL)
                   in  case Bit
overflow of
                         Bit
1 -> BitVector (BitSize (Fixed rep int frac)) -> Fixed rep int frac
forall a. BitPack a => BitVector (BitSize a) -> a
unpack (BitVector ((int + frac) + frac)
-> BitVector (BitSize (rep (int + frac)))
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize (BitVector ((int + frac) + frac)
-> Int -> BitVector ((int + frac) + frac)
forall a. Bits a => a -> Int -> a
shiftR BitVector ((int + frac) + frac)
rR Int
sh))
                         Bit
_ -> Fixed rep int frac
0
          Bool
False -> case BitVector int
rL of
                     BitVector int
0 -> BitVector (BitSize (Fixed rep int frac)) -> Fixed rep int frac
forall a. BitPack a => BitVector (BitSize a) -> a
unpack (BitVector ((int + frac) + frac)
-> BitVector (BitSize (rep (int + frac)))
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize (BitVector ((int + frac) + frac)
-> Int -> BitVector ((int + frac) + frac)
forall a. Bits a => a -> Int -> a
shiftR BitVector ((int + frac) + frac)
rR Int
sh))
                     BitVector int
_ -> Fixed rep int frac
0

  satMul SaturationMode
SatError (Fixed rep (int + frac)
a) (Fixed rep (int + frac)
b) =
    let res :: MResult (rep (int + frac)) (rep (int + frac))
res     = rep (int + frac)
a rep (int + frac)
-> rep (int + frac)
-> MResult (rep (int + frac)) (rep (int + frac))
forall a b. ExtendingNum a b => a -> b -> MResult a b
`mul` rep (int + frac)
b
        sh :: Int
sh      = forall a. (Num a, KnownNat frac) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac
        (BitVector int
rL,BitVector ((int + frac) + frac)
rR) = rep ((int + int) + (frac + frac))
-> (BitVector int, BitVector ((int + frac) + frac))
forall a (m :: Nat) (n :: Nat).
(BitPack a, BitSize a ~ (m + n), KnownNat n) =>
a -> (BitVector m, BitVector n)
split rep ((int + int) + (frac + frac))
MResult (rep (int + frac)) (rep (int + frac))
res :: (BitVector int, BitVector (int + frac + frac))
    in  case rep (int + frac) -> Bool
forall a. Bits a => a -> Bool
isSigned rep (int + frac)
a of
          Bool
True  -> let overflow :: Bit
overflow = Bit -> Bit
forall a. Bits a => a -> a
complement (BitVector (1 + int) -> Bit
forall a. BitPack a => a -> Bit
reduceOr (Bit -> BitVector (BitSize Bit)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (BitVector ((int + frac) + frac) -> Bit
forall a. BitPack a => a -> Bit
msb BitVector ((int + frac) + frac)
rR) BitVector 1 -> BitVector int -> BitVector (1 + int)
forall (m :: Nat) (n :: Nat).
KnownNat m =>
BitVector n -> BitVector m -> BitVector (n + m)
++# BitVector int -> BitVector (BitSize (BitVector int))
forall a. BitPack a => a -> BitVector (BitSize a)
pack BitVector int
rL)) Bit -> Bit -> Bit
forall a. Bits a => a -> a -> a
.|.
                                  BitVector (1 + int) -> Bit
forall a. BitPack a => a -> Bit
reduceAnd (Bit -> BitVector (BitSize Bit)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (BitVector ((int + frac) + frac) -> Bit
forall a. BitPack a => a -> Bit
msb BitVector ((int + frac) + frac)
rR) BitVector 1 -> BitVector int -> BitVector (1 + int)
forall (m :: Nat) (n :: Nat).
KnownNat m =>
BitVector n -> BitVector m -> BitVector (n + m)
++# BitVector int -> BitVector (BitSize (BitVector int))
forall a. BitPack a => a -> BitVector (BitSize a)
pack BitVector int
rL)
                   in  case Bit
overflow of
                         Bit
1 -> BitVector (BitSize (Fixed rep int frac)) -> Fixed rep int frac
forall a. BitPack a => BitVector (BitSize a) -> a
unpack (BitVector ((int + frac) + frac)
-> BitVector (BitSize (rep (int + frac)))
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize (BitVector ((int + frac) + frac)
-> Int -> BitVector ((int + frac) + frac)
forall a. Bits a => a -> Int -> a
shiftR BitVector ((int + frac) + frac)
rR Int
sh))
                         Bit
_ -> String -> Fixed rep int frac
forall a. HasCallStack => String -> a
errorX String
"Fixed.satMul: result exceeds bounds"

          Bool
False -> case BitVector int
rL of
                     BitVector int
0 -> BitVector (BitSize (Fixed rep int frac)) -> Fixed rep int frac
forall a. BitPack a => BitVector (BitSize a) -> a
unpack (BitVector ((int + frac) + frac)
-> BitVector (BitSize (rep (int + frac)))
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize (BitVector ((int + frac) + frac)
-> Int -> BitVector ((int + frac) + frac)
forall a. Bits a => a -> Int -> a
shiftR BitVector ((int + frac) + frac)
rR Int
sh))
                     BitVector int
_ -> String -> Fixed rep int frac
forall a. HasCallStack => String -> a
errorX String
"Fixed.satMul: result exceeds maxBound"

  satMul SaturationMode
SatSymmetric (Fixed rep (int + frac)
a) (Fixed rep (int + frac)
b) =
    let res :: MResult (rep (int + frac)) (rep (int + frac))
res     = rep (int + frac)
a rep (int + frac)
-> rep (int + frac)
-> MResult (rep (int + frac)) (rep (int + frac))
forall a b. ExtendingNum a b => a -> b -> MResult a b
`mul` rep (int + frac)
b
        sh :: Int
sh      = forall a. (Num a, KnownNat frac) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac
        (BitVector int
rL,BitVector ((int + frac) + frac)
rR) = rep ((int + int) + (frac + frac))
-> (BitVector int, BitVector ((int + frac) + frac))
forall a (m :: Nat) (n :: Nat).
(BitPack a, BitSize a ~ (m + n), KnownNat n) =>
a -> (BitVector m, BitVector n)
split rep ((int + int) + (frac + frac))
MResult (rep (int + frac)) (rep (int + frac))
res :: (BitVector int, BitVector (int + frac + frac))
    in  case rep (int + frac) -> Bool
forall a. Bits a => a -> Bool
isSigned rep (int + frac)
a of
          Bool
True  -> let overflow :: Bit
overflow = Bit -> Bit
forall a. Bits a => a -> a
complement (BitVector (1 + int) -> Bit
forall a. BitPack a => a -> Bit
reduceOr (Bit -> BitVector (BitSize Bit)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (BitVector ((int + frac) + frac) -> Bit
forall a. BitPack a => a -> Bit
msb BitVector ((int + frac) + frac)
rR) BitVector 1 -> BitVector int -> BitVector (1 + int)
forall (m :: Nat) (n :: Nat).
KnownNat m =>
BitVector n -> BitVector m -> BitVector (n + m)
++# BitVector int -> BitVector (BitSize (BitVector int))
forall a. BitPack a => a -> BitVector (BitSize a)
pack BitVector int
rL)) Bit -> Bit -> Bit
forall a. Bits a => a -> a -> a
.|.
                                  BitVector (1 + int) -> Bit
forall a. BitPack a => a -> Bit
reduceAnd (Bit -> BitVector (BitSize Bit)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (BitVector ((int + frac) + frac) -> Bit
forall a. BitPack a => a -> Bit
msb BitVector ((int + frac) + frac)
rR) BitVector 1 -> BitVector int -> BitVector (1 + int)
forall (m :: Nat) (n :: Nat).
KnownNat m =>
BitVector n -> BitVector m -> BitVector (n + m)
++# BitVector int -> BitVector (BitSize (BitVector int))
forall a. BitPack a => a -> BitVector (BitSize a)
pack BitVector int
rL)
                   in  case Bit
overflow of
                         Bit
1 -> BitVector (BitSize (Fixed rep int frac)) -> Fixed rep int frac
forall a. BitPack a => BitVector (BitSize a) -> a
unpack (BitVector ((int + frac) + frac)
-> BitVector (BitSize (rep (int + frac)))
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize (BitVector ((int + frac) + frac)
-> Int -> BitVector ((int + frac) + frac)
forall a. Bits a => a -> Int -> a
shiftR BitVector ((int + frac) + frac)
rR Int
sh))
                         Bit
_ -> case BitVector int -> Bit
forall a. BitPack a => a -> Bit
msb BitVector int
rL of
                                Bit
0 -> Fixed rep int frac
forall a. Bounded a => a
maxBound
                                Bit
_ -> rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep (int + frac) -> Fixed rep int frac)
-> rep (int + frac) -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$ rep (int + frac) -> rep (int + frac)
forall a. Enum a => a -> a
succ rep (int + frac)
forall a. Bounded a => a
minBound
          Bool
False -> case BitVector int
rL of
                     BitVector int
0 -> BitVector (BitSize (Fixed rep int frac)) -> Fixed rep int frac
forall a. BitPack a => BitVector (BitSize a) -> a
unpack (BitVector ((int + frac) + frac)
-> BitVector (BitSize (rep (int + frac)))
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize (BitVector ((int + frac) + frac)
-> Int -> BitVector ((int + frac) + frac)
forall a. Bits a => a -> Int -> a
shiftR BitVector ((int + frac) + frac)
rR Int
sh))
                     BitVector int
_ -> Fixed rep int frac
forall a. Bounded a => a
maxBound

  satSucc :: SaturationMode -> Fixed rep int frac -> Fixed rep int frac
satSucc SaturationMode
satMode f :: Fixed rep int frac
f@(Fixed rep (int + frac)
fRep) =
    let sh :: Int
sh    = forall a. (Num a, KnownNat frac) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac
    in case KnownNat int => Integer
forall (n :: Nat). KnownNat n => Integer
natToInteger @int of
         Integer
0 -> case SaturationMode
satMode of
                SaturationMode
SatWrap -> Fixed rep int frac
f
                SaturationMode
SatZero -> Fixed rep int frac
0
                SaturationMode
SatError -> String -> Fixed rep int frac
forall a. HasCallStack => String -> a
errorX String
"Fixed.satSucc: result exceeds maxBound"
                SaturationMode
_       -> Fixed rep int frac
forall a. Bounded a => a
maxBound
         Integer
_ -> if rep (int + frac) -> Bool
forall a. Bits a => a -> Bool
isSigned rep (int + frac)
fRep
              then SaturationMode
-> Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satSub SaturationMode
satMode Fixed rep int frac
f (Fixed rep int frac -> Fixed rep int frac)
-> Fixed rep int frac -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$ rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep (int + frac) -> Fixed rep int frac)
-> rep (int + frac) -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$ Integer -> rep (int + frac)
forall a. Num a => Integer -> a
fromInteger (Integer -> rep (int + frac)) -> Integer -> rep (int + frac)
forall a b. (a -> b) -> a -> b
$ (Integer
-1) Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
sh
              else SaturationMode
-> Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satAdd SaturationMode
satMode Fixed rep int frac
f (Fixed rep int frac -> Fixed rep int frac)
-> Fixed rep int frac -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$ rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep (int + frac) -> Fixed rep int frac)
-> rep (int + frac) -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$ Integer -> rep (int + frac)
forall a. Num a => Integer -> a
fromInteger (Integer -> rep (int + frac)) -> Integer -> rep (int + frac)
forall a b. (a -> b) -> a -> b
$ Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
sh
  {-# INLINE satSucc #-}

  satPred :: SaturationMode -> Fixed rep int frac -> Fixed rep int frac
satPred SaturationMode
satMode f :: Fixed rep int frac
f@(Fixed rep (int + frac)
fRep) =
    let sh :: Int
sh       = forall a. (Num a, KnownNat frac) => a
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @frac
        symBound :: Fixed rep int frac
symBound = if rep (int + frac) -> Bool
forall a. Bits a => a -> Bool
isSigned rep (int + frac)
fRep
                   then rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep (int + frac) -> Fixed rep int frac)
-> rep (int + frac) -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$ rep (int + frac)
forall a. Bounded a => a
minBound rep (int + frac) -> rep (int + frac) -> rep (int + frac)
forall a. Num a => a -> a -> a
+ rep (int + frac)
1
                   else Fixed rep int frac
forall a. Bounded a => a
minBound
    in case KnownNat int => Integer
forall (n :: Nat). KnownNat n => Integer
natToInteger @int of
         Integer
0 -> case SaturationMode
satMode of
                SaturationMode
SatWrap      -> Fixed rep int frac
f
                SaturationMode
SatBound     -> Fixed rep int frac
forall a. Bounded a => a
minBound
                SaturationMode
SatZero      -> Fixed rep int frac
0
                SaturationMode
SatError     -> String -> Fixed rep int frac
forall a. HasCallStack => String -> a
errorX String
"Fixed.satPred: result exceeds minBound"
                SaturationMode
SatSymmetric -> Fixed rep int frac
symBound
         Integer
_ -> if rep (int + frac) -> Bool
forall a. Bits a => a -> Bool
isSigned rep (int + frac)
fRep
              then SaturationMode
-> Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satAdd SaturationMode
satMode Fixed rep int frac
f (Fixed rep int frac -> Fixed rep int frac)
-> Fixed rep int frac -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$ rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep (int + frac) -> Fixed rep int frac)
-> rep (int + frac) -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$ Integer -> rep (int + frac)
forall a. Num a => Integer -> a
fromInteger (Integer -> rep (int + frac)) -> Integer -> rep (int + frac)
forall a b. (a -> b) -> a -> b
$ (Integer
-1) Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
sh
              else SaturationMode
-> Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satSub SaturationMode
satMode Fixed rep int frac
f (Fixed rep int frac -> Fixed rep int frac)
-> Fixed rep int frac -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$ rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep (int + frac) -> Fixed rep int frac)
-> rep (int + frac) -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$ Integer -> rep (int + frac)
forall a. Num a => Integer -> a
fromInteger (Integer -> rep (int + frac)) -> Integer -> rep (int + frac)
forall a b. (a -> b) -> a -> b
$ Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
sh
  {-# INLINE satPred #-}

-- | Constraint for the 'divide' function
type DivideC rep int1 frac1 int2 frac2
  = ( Resize   rep
    , Integral (rep (((int1 + frac2) + 1) + (int2 + frac1)))
    , Bits     (rep (((int1 + frac2) + 1) + (int2 + frac1)))
    , KnownNat int1
    , KnownNat frac1
    , KnownNat int2
    , KnownNat frac2
    )

-- | Constraint for the 'divide' function, specialized for 'SFixed'
type DivideSC int1 frac1 int2 frac2
  = ( KnownNat (((int1 + frac2) + 1) + (int2 + frac1))
    , KnownNat frac2
    , KnownNat int2
    , KnownNat frac1
    , KnownNat int1
    )

-- | Constraint for the 'divide' function, specialized for 'UFixed'
type DivideUC int1 frac1 int2 frac2 =
     DivideSC int1 frac1 int2 frac2

-- | Fixed point division
--
-- When used in a polymorphic setting, use the following
-- <#constraintsynonyms Constraint synonyms> for less verbose type signatures:
--
-- * @'DivideC' rep int1 frac1 int2 frac2@ for:
--   @'Fixed' rep int1 frac1 -> 'Fixed' rep int2 frac2 -> 'Fixed' rep (int1 + frac2 + 1) (int2 + frac1)@
--
-- * @'DivideSC' rep int1 frac1 int2 frac2@ for:
--   @'SFixed' int1 frac1 -> 'SFixed' int2 frac2 -> 'SFixed' (int1 + frac2 + 1) (int2 + frac1)@
--
-- * @'DivideUC' rep int1 frac1 int2 frac2@ for:
--   @'UFixed' int1 frac1 -> 'UFixed' int2 frac2 -> 'UFixed' (int1 + frac2 + 1) (int2 + frac1)@
divide
  :: DivideC rep int1 frac1 int2 frac2
  => Fixed rep int1 frac1
  -> Fixed rep int2 frac2
  -> Fixed rep (int1 + frac2 + 1) (int2 + frac1)
divide :: Fixed rep int1 frac1
-> Fixed rep int2 frac2
-> Fixed rep ((int1 + frac2) + 1) (int2 + frac1)
divide (Fixed rep (int1 + frac1)
fr1) fx2 :: Fixed rep int2 frac2
fx2@(Fixed rep (int2 + frac2)
fr2) =
  let int2 :: Int
int2  = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Proxy int2 -> Integer
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal (Fixed rep int2 frac2 -> Proxy int2
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
Fixed rep int frac -> Proxy int
asIntProxy Fixed rep int2 frac2
fx2))
      frac2 :: Int
frac2 = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Fixed rep int2 frac2 -> Integer
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal Fixed rep int2 frac2
fx2)
      fr1' :: rep (((int1 + frac2) + 1) + (int2 + frac1))
fr1'  = rep (int1 + frac1) -> rep (((int1 + frac2) + 1) + (int2 + frac1))
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize rep (int1 + frac1)
fr1
      fr2' :: rep (((int1 + frac2) + 1) + (int2 + frac1))
fr2'  = rep (int2 + frac2) -> rep (((int1 + frac2) + 1) + (int2 + frac1))
forall (f :: Nat -> Type) (a :: Nat) (b :: Nat).
(Resize f, KnownNat a, KnownNat b) =>
f a -> f b
resize rep (int2 + frac2)
fr2
      fr1SH :: rep (((int1 + frac2) + 1) + (int2 + frac1))
fr1SH = rep (((int1 + frac2) + 1) + (int2 + frac1))
-> Int -> rep (((int1 + frac2) + 1) + (int2 + frac1))
forall a. Bits a => a -> Int -> a
shiftL rep (((int1 + frac2) + 1) + (int2 + frac1))
fr1' ((Int
int2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frac2))
      res :: rep (((int1 + frac2) + 1) + (int2 + frac1))
res   = rep (((int1 + frac2) + 1) + (int2 + frac1))
fr1SH rep (((int1 + frac2) + 1) + (int2 + frac1))
-> rep (((int1 + frac2) + 1) + (int2 + frac1))
-> rep (((int1 + frac2) + 1) + (int2 + frac1))
forall a. Integral a => a -> a -> a
`quot` rep (((int1 + frac2) + 1) + (int2 + frac1))
fr2'
  in  rep (((int1 + frac2) + 1) + (int2 + frac1))
-> Fixed rep ((int1 + frac2) + 1) (int2 + frac1)
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed rep (((int1 + frac2) + 1) + (int2 + frac1))
res

-- | Constraint for the 'Fractional' instance of 'Fixed'
type FracFixedC rep int frac
  = ( NumFixedC rep int frac
    , DivideC   rep int frac int frac
    )

-- | Constraint for the 'Fractional' instance of 'SFixed'
type FracSFixedC int frac
  = ( NumSFixedC int frac
    , KnownNat ((int + frac + 1) + (int + frac))
    )

-- | Constraint for the 'Fractional' instance of 'UFixed'
type FracUFixedC int frac
  = FracSFixedC int frac

-- | The operators of this instance saturate on overflow, and use truncation as
-- the rounding method.
--
-- When used in a polymorphic setting, use the following
-- <Clash-Sized-Fixed.html#constraintsynonyms Constraint synonyms> for less
-- verbose type signatures:
--
-- * @'FracFixedC' frac rep size@ for: @'Fixed' frac rep size@
-- * @'FracSFixedC' int frac@     for: @'SFixed' int frac@
-- * @'FracUFixedC' int frac@     for: @'UFixed' int frac@
instance FracFixedC rep int frac => Fractional (Fixed rep int frac) where
  Fixed rep int frac
f1 / :: Fixed rep int frac -> Fixed rep int frac -> Fixed rep int frac
/ Fixed rep int frac
f2        = Fixed rep ((int + frac) + 1) (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int1 :: Nat) (frac1 :: Nat)
       (int2 :: Nat) (frac2 :: Nat).
ResizeFC rep int1 frac1 int2 frac2 =>
Fixed rep int1 frac1 -> Fixed rep int2 frac2
resizeF (Fixed rep int frac
-> Fixed rep int frac -> Fixed rep ((int + frac) + 1) (int + frac)
forall (rep :: Nat -> Type) (int1 :: Nat) (frac1 :: Nat)
       (int2 :: Nat) (frac2 :: Nat).
DivideC rep int1 frac1 int2 frac2 =>
Fixed rep int1 frac1
-> Fixed rep int2 frac2
-> Fixed rep ((int1 + frac2) + 1) (int2 + frac1)
divide Fixed rep int frac
f1 Fixed rep int frac
f2)
  recip :: Fixed rep int frac -> Fixed rep int frac
recip Fixed rep int frac
fx       = Fixed rep ((int + frac) + 1) (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int1 :: Nat) (frac1 :: Nat)
       (int2 :: Nat) (frac2 :: Nat).
ResizeFC rep int1 frac1 int2 frac2 =>
Fixed rep int1 frac1 -> Fixed rep int2 frac2
resizeF (Fixed rep int frac
-> Fixed rep int frac -> Fixed rep ((int + frac) + 1) (int + frac)
forall (rep :: Nat -> Type) (int1 :: Nat) (frac1 :: Nat)
       (int2 :: Nat) (frac2 :: Nat).
DivideC rep int1 frac1 int2 frac2 =>
Fixed rep int1 frac1
-> Fixed rep int2 frac2
-> Fixed rep ((int1 + frac2) + 1) (int2 + frac1)
divide (Fixed rep int frac
1 :: Fixed rep int frac) Fixed rep int frac
fx)
  fromRational :: Ratio Integer -> Fixed rep int frac
fromRational Ratio Integer
r = Fixed rep int frac
res
    where
      res :: Fixed rep int frac
res  = rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (Integer -> rep (int + frac)
forall a. Num a => Integer -> a
fromInteger Integer
sat)
      sat :: Integer
sat  = if Integer
res' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
rMax
                then Integer
rMax
                else if Integer
res' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
rMin then Integer
rMin else Integer
res'

      rMax :: Integer
rMax = rep (int + frac) -> Integer
forall a. Integral a => a -> Integer
toInteger (rep (int + frac)
forall a. Bounded a => a
maxBound :: rep (int + frac))
      rMin :: Integer
rMin = rep (int + frac) -> Integer
forall a. Integral a => a -> Integer
toInteger (rep (int + frac)
forall a. Bounded a => a
minBound :: rep (int + frac))
      res' :: Integer
res' = Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
d

      frac :: Int
frac = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Fixed rep int frac -> Integer
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal Fixed rep int frac
res)
      n :: Integer
n    = Ratio Integer -> Integer
forall a. Ratio a -> a
numerator   Ratio Integer
r Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
frac)
      d :: Integer
d    = Ratio Integer -> Integer
forall a. Ratio a -> a
denominator Ratio Integer
r Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
frac

instance NumFixedC rep int frac => Real (Fixed rep int frac) where
  toRational :: Fixed rep int frac -> Ratio Integer
toRational f :: Fixed rep int frac
f@(Fixed rep (int + frac)
fRep) = Integer
nom Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% Integer
denom
   where
     nF :: Int
nF        = Fixed rep int frac -> Int
forall (frac :: Nat) (rep :: Nat -> Type) (int :: Nat).
KnownNat frac =>
Fixed rep int frac -> Int
fracShift Fixed rep int frac
f
     denom :: Integer
denom     = Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
nF
     nom :: Integer
nom       = rep (int + frac) -> Integer
forall a. Integral a => a -> Integer
toInteger rep (int + frac)
fRep

instance FracFixedC rep int frac => RealFrac (Fixed rep int frac) where
  properFraction :: Fixed rep int frac -> (b, Fixed rep int frac)
properFraction f :: Fixed rep int frac
f@(Fixed rep (int + frac)
fRep) = (rep (int + frac) -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral rep (int + frac)
whole, Fixed rep int frac
fract)
    where
      whole :: rep (int + frac)
whole = (rep (int + frac)
fRep rep (int + frac) -> Int -> rep (int + frac)
forall a. Bits a => a -> Int -> a
`shiftR` Fixed rep int frac -> Int
forall (frac :: Nat) (rep :: Nat -> Type) (int :: Nat).
KnownNat frac =>
Fixed rep int frac -> Int
fracShift Fixed rep int frac
f) rep (int + frac) -> rep (int + frac) -> rep (int + frac)
forall a. Num a => a -> a -> a
+ rep (int + frac)
offset
      fract :: Fixed rep int frac
fract = rep (int + frac) -> Fixed rep int frac
forall (rep :: Nat -> Type) (int :: Nat) (frac :: Nat).
rep (int + frac) -> Fixed rep int frac
Fixed (rep (int + frac) -> Fixed rep int frac)
-> rep (int + frac) -> Fixed rep int frac
forall a b. (a -> b) -> a -> b
$ rep (int + frac)
fRep rep (int + frac) -> rep (int + frac) -> rep (int + frac)
forall a. Num a => a -> a -> a
- (rep (int + frac)
whole rep (int + frac) -> Int -> rep (int + frac)
forall a. Bits a => a -> Int -> a
`shiftL` Fixed rep int frac -> Int
forall (frac :: Nat) (rep :: Nat -> Type) (int :: Nat).
KnownNat frac =>
Fixed rep int frac -> Int
fracShift Fixed rep int frac
f)
      frMask :: rep (int + frac)
frMask = Integer -> rep (int + frac)
forall a. Num a => Integer -> a
fromInteger (Integer -> rep (int + frac)) -> Integer -> rep (int + frac)
forall a b. (a -> b) -> a -> b
$ (Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Fixed rep int frac -> Int
forall (frac :: Nat) (rep :: Nat -> Type) (int :: Nat).
KnownNat frac =>
Fixed rep int frac -> Int
fracShift Fixed rep int frac
f) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
      offset :: rep (int + frac)
offset = if Fixed rep int frac
f Fixed rep int frac -> Fixed rep int frac -> Bool
forall a. Ord a => a -> a -> Bool
< Fixed rep int frac
0 Bool -> Bool -> Bool
&& rep (int + frac)
fRep rep (int + frac) -> rep (int + frac) -> rep (int + frac)
forall a. Bits a => a -> a -> a
.&. rep (int + frac)
frMask rep (int + frac) -> rep (int + frac) -> Bool
forall a. Eq a => a -> a -> Bool
/= rep (int + frac)
0 then rep (int + frac)
1 else rep (int + frac)
0