{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- Representation of values with an associated (free) unit of measure. Useful to
-- disambiguate primitive types like 'Int' or 'String' which can be in different
-- bases depending on the context.

module Data.Quantity
    ( -- * Polymorphic Quantity
      Quantity(..)

      -- * Percentage
    , Percentage
    , MkPercentageError(..)
    , mkPercentage
    , getPercentage
    , clipToPercentage
    , complementPercentage
    , percentageToDouble
    ) where

import Prelude

import Control.Arrow
    ( left )
import Control.DeepSeq
    ( NFData )
import Control.Monad
    ( unless )
import Data.Aeson
    ( FromJSON (..)
    , ToJSON (..)
    , Value (String)
    , object
    , withObject
    , withScientific
    , (.:)
    , (.=)
    )
import Data.Aeson.Types
    ( Parser )
import Data.Hashable
    ( Hashable )
import Data.Proxy
    ( Proxy (..) )
import Data.Scientific
    ( FPFormat (Fixed), Scientific (..), formatScientific )
import Data.Text.Class
    ( FromText (..), TextDecodingError (..), ToText (..) )
import Data.Text.Read
    ( rational )
import Fmt
    ( Buildable (..), fmt )
import GHC.Generics
    ( Generic )
import GHC.TypeLits
    ( KnownSymbol, Symbol, symbolVal )
import NoThunks.Class
    ( NoThunks (..) )
import Quiet
    ( Quiet (..) )

import qualified Data.Text as T


-- | @Quantity (unit :: Symbol) a@ is a primitive @a@  multiplied by an @unit@.
--
-- Example:
--
-- Instead of providing the unit implicitly as a comment, or a part of a name
--
-- >>> a :: Word32 -- in lovelace
--
-- we can write
--
-- >>> a :: Quantity "lovelace" Word32
--
-- which now has a different type from
--
-- >>> b :: Quantity "lovelace/byte" Word32
--
-- so mixing them up is more difficult.
--
-- The unit is mostly a phantom type, but it is also included in the
-- @ToJSON@/@FromJSON@ instances.
--
-- >>> Aeson.encode $ Quantity @"lovelace" 14
-- {"unit":"lovelace","quantity":14}
newtype Quantity (unit :: Symbol) a = Quantity { Quantity unit a -> a
getQuantity :: a }
    deriving stock ((forall x. Quantity unit a -> Rep (Quantity unit a) x)
-> (forall x. Rep (Quantity unit a) x -> Quantity unit a)
-> Generic (Quantity unit a)
forall x. Rep (Quantity unit a) x -> Quantity unit a
forall x. Quantity unit a -> Rep (Quantity unit a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (unit :: Symbol) a x.
Rep (Quantity unit a) x -> Quantity unit a
forall (unit :: Symbol) a x.
Quantity unit a -> Rep (Quantity unit a) x
$cto :: forall (unit :: Symbol) a x.
Rep (Quantity unit a) x -> Quantity unit a
$cfrom :: forall (unit :: Symbol) a x.
Quantity unit a -> Rep (Quantity unit a) x
Generic, Quantity unit a -> Quantity unit a -> Bool
(Quantity unit a -> Quantity unit a -> Bool)
-> (Quantity unit a -> Quantity unit a -> Bool)
-> Eq (Quantity unit a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (unit :: Symbol) a.
Eq a =>
Quantity unit a -> Quantity unit a -> Bool
/= :: Quantity unit a -> Quantity unit a -> Bool
$c/= :: forall (unit :: Symbol) a.
Eq a =>
Quantity unit a -> Quantity unit a -> Bool
== :: Quantity unit a -> Quantity unit a -> Bool
$c== :: forall (unit :: Symbol) a.
Eq a =>
Quantity unit a -> Quantity unit a -> Bool
Eq, Eq (Quantity unit a)
Eq (Quantity unit a)
-> (Quantity unit a -> Quantity unit a -> Ordering)
-> (Quantity unit a -> Quantity unit a -> Bool)
-> (Quantity unit a -> Quantity unit a -> Bool)
-> (Quantity unit a -> Quantity unit a -> Bool)
-> (Quantity unit a -> Quantity unit a -> Bool)
-> (Quantity unit a -> Quantity unit a -> Quantity unit a)
-> (Quantity unit a -> Quantity unit a -> Quantity unit a)
-> Ord (Quantity unit a)
Quantity unit a -> Quantity unit a -> Bool
Quantity unit a -> Quantity unit a -> Ordering
Quantity unit a -> Quantity unit a -> Quantity unit a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (unit :: Symbol) a. Ord a => Eq (Quantity unit a)
forall (unit :: Symbol) a.
Ord a =>
Quantity unit a -> Quantity unit a -> Bool
forall (unit :: Symbol) a.
Ord a =>
Quantity unit a -> Quantity unit a -> Ordering
forall (unit :: Symbol) a.
Ord a =>
Quantity unit a -> Quantity unit a -> Quantity unit a
min :: Quantity unit a -> Quantity unit a -> Quantity unit a
$cmin :: forall (unit :: Symbol) a.
Ord a =>
Quantity unit a -> Quantity unit a -> Quantity unit a
max :: Quantity unit a -> Quantity unit a -> Quantity unit a
$cmax :: forall (unit :: Symbol) a.
Ord a =>
Quantity unit a -> Quantity unit a -> Quantity unit a
>= :: Quantity unit a -> Quantity unit a -> Bool
$c>= :: forall (unit :: Symbol) a.
Ord a =>
Quantity unit a -> Quantity unit a -> Bool
> :: Quantity unit a -> Quantity unit a -> Bool
$c> :: forall (unit :: Symbol) a.
Ord a =>
Quantity unit a -> Quantity unit a -> Bool
<= :: Quantity unit a -> Quantity unit a -> Bool
$c<= :: forall (unit :: Symbol) a.
Ord a =>
Quantity unit a -> Quantity unit a -> Bool
< :: Quantity unit a -> Quantity unit a -> Bool
$c< :: forall (unit :: Symbol) a.
Ord a =>
Quantity unit a -> Quantity unit a -> Bool
compare :: Quantity unit a -> Quantity unit a -> Ordering
$ccompare :: forall (unit :: Symbol) a.
Ord a =>
Quantity unit a -> Quantity unit a -> Ordering
$cp1Ord :: forall (unit :: Symbol) a. Ord a => Eq (Quantity unit a)
Ord)
    deriving newtype (Quantity unit a
Quantity unit a -> Quantity unit a -> Bounded (Quantity unit a)
forall a. a -> a -> Bounded a
forall (unit :: Symbol) a. Bounded a => Quantity unit a
maxBound :: Quantity unit a
$cmaxBound :: forall (unit :: Symbol) a. Bounded a => Quantity unit a
minBound :: Quantity unit a
$cminBound :: forall (unit :: Symbol) a. Bounded a => Quantity unit a
Bounded, Int -> Quantity unit a
Quantity unit a -> Int
Quantity unit a -> [Quantity unit a]
Quantity unit a -> Quantity unit a
Quantity unit a -> Quantity unit a -> [Quantity unit a]
Quantity unit a
-> Quantity unit a -> Quantity unit a -> [Quantity unit a]
(Quantity unit a -> Quantity unit a)
-> (Quantity unit a -> Quantity unit a)
-> (Int -> Quantity unit a)
-> (Quantity unit a -> Int)
-> (Quantity unit a -> [Quantity unit a])
-> (Quantity unit a -> Quantity unit a -> [Quantity unit a])
-> (Quantity unit a -> Quantity unit a -> [Quantity unit a])
-> (Quantity unit a
    -> Quantity unit a -> Quantity unit a -> [Quantity unit a])
-> Enum (Quantity unit a)
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
forall (unit :: Symbol) a. Enum a => Int -> Quantity unit a
forall (unit :: Symbol) a. Enum a => Quantity unit a -> Int
forall (unit :: Symbol) a.
Enum a =>
Quantity unit a -> [Quantity unit a]
forall (unit :: Symbol) a.
Enum a =>
Quantity unit a -> Quantity unit a
forall (unit :: Symbol) a.
Enum a =>
Quantity unit a -> Quantity unit a -> [Quantity unit a]
forall (unit :: Symbol) a.
Enum a =>
Quantity unit a
-> Quantity unit a -> Quantity unit a -> [Quantity unit a]
enumFromThenTo :: Quantity unit a
-> Quantity unit a -> Quantity unit a -> [Quantity unit a]
$cenumFromThenTo :: forall (unit :: Symbol) a.
Enum a =>
Quantity unit a
-> Quantity unit a -> Quantity unit a -> [Quantity unit a]
enumFromTo :: Quantity unit a -> Quantity unit a -> [Quantity unit a]
$cenumFromTo :: forall (unit :: Symbol) a.
Enum a =>
Quantity unit a -> Quantity unit a -> [Quantity unit a]
enumFromThen :: Quantity unit a -> Quantity unit a -> [Quantity unit a]
$cenumFromThen :: forall (unit :: Symbol) a.
Enum a =>
Quantity unit a -> Quantity unit a -> [Quantity unit a]
enumFrom :: Quantity unit a -> [Quantity unit a]
$cenumFrom :: forall (unit :: Symbol) a.
Enum a =>
Quantity unit a -> [Quantity unit a]
fromEnum :: Quantity unit a -> Int
$cfromEnum :: forall (unit :: Symbol) a. Enum a => Quantity unit a -> Int
toEnum :: Int -> Quantity unit a
$ctoEnum :: forall (unit :: Symbol) a. Enum a => Int -> Quantity unit a
pred :: Quantity unit a -> Quantity unit a
$cpred :: forall (unit :: Symbol) a.
Enum a =>
Quantity unit a -> Quantity unit a
succ :: Quantity unit a -> Quantity unit a
$csucc :: forall (unit :: Symbol) a.
Enum a =>
Quantity unit a -> Quantity unit a
Enum, Int -> Quantity unit a -> Int
Quantity unit a -> Int
(Int -> Quantity unit a -> Int)
-> (Quantity unit a -> Int) -> Hashable (Quantity unit a)
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall (unit :: Symbol) a.
Hashable a =>
Int -> Quantity unit a -> Int
forall (unit :: Symbol) a. Hashable a => Quantity unit a -> Int
hash :: Quantity unit a -> Int
$chash :: forall (unit :: Symbol) a. Hashable a => Quantity unit a -> Int
hashWithSalt :: Int -> Quantity unit a -> Int
$chashWithSalt :: forall (unit :: Symbol) a.
Hashable a =>
Int -> Quantity unit a -> Int
Hashable)
    deriving Int -> Quantity unit a -> ShowS
[Quantity unit a] -> ShowS
Quantity unit a -> String
(Int -> Quantity unit a -> ShowS)
-> (Quantity unit a -> String)
-> ([Quantity unit a] -> ShowS)
-> Show (Quantity unit a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (unit :: Symbol) a.
Show a =>
Int -> Quantity unit a -> ShowS
forall (unit :: Symbol) a. Show a => [Quantity unit a] -> ShowS
forall (unit :: Symbol) a. Show a => Quantity unit a -> String
showList :: [Quantity unit a] -> ShowS
$cshowList :: forall (unit :: Symbol) a. Show a => [Quantity unit a] -> ShowS
show :: Quantity unit a -> String
$cshow :: forall (unit :: Symbol) a. Show a => Quantity unit a -> String
showsPrec :: Int -> Quantity unit a -> ShowS
$cshowsPrec :: forall (unit :: Symbol) a.
Show a =>
Int -> Quantity unit a -> ShowS
Show via (Quiet (Quantity unit a))

instance NoThunks a => NoThunks (Quantity unit a)

instance Functor (Quantity any) where
    fmap :: (a -> b) -> Quantity any a -> Quantity any b
fmap a -> b
f (Quantity a
a) = b -> Quantity any b
forall (unit :: Symbol) a. a -> Quantity unit a
Quantity (a -> b
f a
a)

instance NFData a => NFData (Quantity unit a)

instance (KnownSymbol unit, ToJSON a) => ToJSON (Quantity unit a) where
    toJSON :: Quantity unit a -> Value
toJSON (Quantity a
a) = [Pair] -> Value
object
        [ Key
"unit"     Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Proxy unit -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy unit
forall k (t :: k). Proxy t
Proxy :: Proxy unit)
        , Key
"quantity" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a
        ]

instance (KnownSymbol unit, FromJSON a) => FromJSON (Quantity unit a) where
    parseJSON :: Value -> Parser (Quantity unit a)
parseJSON = String
-> (Object -> Parser (Quantity unit a))
-> Value
-> Parser (Quantity unit a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Quantity" ((Object -> Parser (Quantity unit a))
 -> Value -> Parser (Quantity unit a))
-> (Object -> Parser (Quantity unit a))
-> Value
-> Parser (Quantity unit a)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        Proxy unit -> Value -> Parser ()
verifyUnit (Proxy unit
forall k (t :: k). Proxy t
Proxy :: Proxy unit) (Value -> Parser ()) -> Parser Value -> Parser ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Object
o Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"unit"
        a -> Quantity unit a
forall (unit :: Symbol) a. a -> Quantity unit a
Quantity (a -> Quantity unit a) -> Parser a -> Parser (Quantity unit a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"quantity"
      where
        verifyUnit :: Proxy (unit :: Symbol) -> Value -> Parser ()
        verifyUnit :: Proxy unit -> Value -> Parser ()
verifyUnit Proxy unit
proxy = \case
            String Text
u' | Text
u' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
T.pack String
u -> () -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Value
_ -> String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$
                String
"failed to parse quantified value. Expected value in '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
u
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"' (e.g. { \"unit\": \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
u String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\", \"quantity\": ... })"
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" but got something else."
          where
            u :: String
u = Proxy unit -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy unit
proxy

instance FromText b => FromText (Quantity sym b) where
    fromText :: Text -> Either TextDecodingError (Quantity sym b)
fromText = (b -> Quantity sym b)
-> Either TextDecodingError b
-> Either TextDecodingError (Quantity sym b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Quantity sym b
forall (unit :: Symbol) a. a -> Quantity unit a
Quantity (Either TextDecodingError b
 -> Either TextDecodingError (Quantity sym b))
-> (Text -> Either TextDecodingError b)
-> Text
-> Either TextDecodingError (Quantity sym b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either TextDecodingError b
forall a. FromText a => Text -> Either TextDecodingError a
fromText

instance ToText b => ToText (Quantity sym b) where
    toText :: Quantity sym b -> Text
toText (Quantity b
b) = b -> Text
forall a. ToText a => a -> Text
toText b
b

-- Builds (Quantity "lovelace" Word64) as "42 lovelace"
instance (KnownSymbol unit, Buildable a) => Buildable (Quantity unit a) where
    build :: Quantity unit a -> Builder
build (Quantity a
a) = a -> Builder
forall p. Buildable p => p -> Builder
build a
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
forall b. FromBuilder b => Builder -> b
fmt Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
forall p. Buildable p => p -> Builder
build String
u
      where
        u :: String
u = Proxy unit -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy unit
forall k (t :: k). Proxy t
Proxy :: Proxy unit)

{-------------------------------------------------------------------------------
                                Percentage
-------------------------------------------------------------------------------}

-- | Opaque Haskell type to represent values between 0 and 100 (incl).
newtype Percentage = Percentage
    { Percentage -> Rational
getPercentage :: Rational }
    deriving stock ((forall x. Percentage -> Rep Percentage x)
-> (forall x. Rep Percentage x -> Percentage) -> Generic Percentage
forall x. Rep Percentage x -> Percentage
forall x. Percentage -> Rep Percentage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Percentage x -> Percentage
$cfrom :: forall x. Percentage -> Rep Percentage x
Generic, Percentage -> Percentage -> Bool
(Percentage -> Percentage -> Bool)
-> (Percentage -> Percentage -> Bool) -> Eq Percentage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Percentage -> Percentage -> Bool
$c/= :: Percentage -> Percentage -> Bool
== :: Percentage -> Percentage -> Bool
$c== :: Percentage -> Percentage -> Bool
Eq, Eq Percentage
Eq Percentage
-> (Percentage -> Percentage -> Ordering)
-> (Percentage -> Percentage -> Bool)
-> (Percentage -> Percentage -> Bool)
-> (Percentage -> Percentage -> Bool)
-> (Percentage -> Percentage -> Bool)
-> (Percentage -> Percentage -> Percentage)
-> (Percentage -> Percentage -> Percentage)
-> Ord Percentage
Percentage -> Percentage -> Bool
Percentage -> Percentage -> Ordering
Percentage -> Percentage -> Percentage
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Percentage -> Percentage -> Percentage
$cmin :: Percentage -> Percentage -> Percentage
max :: Percentage -> Percentage -> Percentage
$cmax :: Percentage -> Percentage -> Percentage
>= :: Percentage -> Percentage -> Bool
$c>= :: Percentage -> Percentage -> Bool
> :: Percentage -> Percentage -> Bool
$c> :: Percentage -> Percentage -> Bool
<= :: Percentage -> Percentage -> Bool
$c<= :: Percentage -> Percentage -> Bool
< :: Percentage -> Percentage -> Bool
$c< :: Percentage -> Percentage -> Bool
compare :: Percentage -> Percentage -> Ordering
$ccompare :: Percentage -> Percentage -> Ordering
$cp1Ord :: Eq Percentage
Ord)
    deriving Int -> Percentage -> ShowS
[Percentage] -> ShowS
Percentage -> String
(Int -> Percentage -> ShowS)
-> (Percentage -> String)
-> ([Percentage] -> ShowS)
-> Show Percentage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Percentage] -> ShowS
$cshowList :: [Percentage] -> ShowS
show :: Percentage -> String
$cshow :: Percentage -> String
showsPrec :: Int -> Percentage -> ShowS
$cshowsPrec :: Int -> Percentage -> ShowS
Show via (Quiet Percentage)

instance NoThunks Percentage

instance NFData Percentage

instance Buildable Percentage where
    build :: Percentage -> Builder
build = Text -> Builder
forall p. Buildable p => p -> Builder
build (Text -> Builder) -> (Percentage -> Text) -> Percentage -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Percentage -> Text
forall a. ToText a => a -> Text
toText

instance ToJSON Percentage where
    toJSON :: Percentage -> Value
toJSON =
        Scientific -> Value
forall a. ToJSON a => a -> Value
toJSON
        (Scientific -> Value)
-> (Percentage -> Scientific) -> Percentage -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Rational -> Scientific
rationalToToScientific Int
percentageNumberOfFractionalDigits
        (Rational -> Scientific)
-> (Percentage -> Rational) -> Percentage -> Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
100)
        (Rational -> Rational)
-> (Percentage -> Rational) -> Percentage -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Percentage -> Rational
getPercentage

instance FromJSON Percentage where
    parseJSON :: Value -> Parser Percentage
parseJSON = String
-> (Scientific -> Parser Percentage) -> Value -> Parser Percentage
forall a. String -> (Scientific -> Parser a) -> Value -> Parser a
withScientific String
"Percentage [0,100]" ((Scientific -> Parser Percentage) -> Value -> Parser Percentage)
-> (Scientific -> Parser Percentage) -> Value -> Parser Percentage
forall a b. (a -> b) -> a -> b
$ \Scientific
s ->
        (MkPercentageError -> Parser Percentage)
-> (Percentage -> Parser Percentage)
-> Either MkPercentageError Percentage
-> Parser Percentage
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser Percentage
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Percentage)
-> (MkPercentageError -> String)
-> MkPercentageError
-> Parser Percentage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MkPercentageError -> String
forall a. Show a => a -> String
show) Percentage -> Parser Percentage
forall (m :: * -> *) a. Monad m => a -> m a
return
        (Either MkPercentageError Percentage -> Parser Percentage)
-> (Scientific -> Either MkPercentageError Percentage)
-> Scientific
-> Parser Percentage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Either MkPercentageError Percentage
mkPercentage
        (Rational -> Either MkPercentageError Percentage)
-> (Scientific -> Rational)
-> Scientific
-> Either MkPercentageError Percentage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Rational
forall a. Real a => a -> Rational
toRational
        (Scientific -> Parser Percentage)
-> Scientific -> Parser Percentage
forall a b. (a -> b) -> a -> b
$ (Scientific
s Scientific -> Scientific -> Scientific
forall a. Fractional a => a -> a -> a
/ Scientific
100)

instance Bounded Percentage where
    minBound :: Percentage
minBound = Rational -> Percentage
Percentage Rational
0
    maxBound :: Percentage
maxBound = Rational -> Percentage
Percentage Rational
1

instance ToText Percentage where
    toText :: Percentage -> Text
toText =
        (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"%")
        (Text -> Text) -> (Percentage -> Text) -> Percentage -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
        (String -> Text) -> (Percentage -> String) -> Percentage -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> String
showS
        (Scientific -> String)
-> (Percentage -> Scientific) -> Percentage -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Rational -> Scientific
rationalToToScientific Int
percentageNumberOfFractionalDigits
        (Rational -> Scientific)
-> (Percentage -> Rational) -> Percentage -> Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
100)
        (Rational -> Rational)
-> (Percentage -> Rational) -> Percentage -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Percentage -> Rational
getPercentage
      where
        showS :: Scientific -> String
showS = FPFormat -> Maybe Int -> Scientific -> String
formatScientific
            FPFormat
Fixed
            (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
percentageNumberOfFractionalDigits)

instance FromText Percentage where
    fromText :: Text -> Either TextDecodingError Percentage
fromText Text
txt = do
        (Rational
p, Text
u) <- (String -> TextDecodingError)
-> Either String (Rational, Text)
-> Either TextDecodingError (Rational, Text)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (TextDecodingError -> String -> TextDecodingError
forall a b. a -> b -> a
const TextDecodingError
err) (Either String (Rational, Text)
 -> Either TextDecodingError (Rational, Text))
-> Either String (Rational, Text)
-> Either TextDecodingError (Rational, Text)
forall a b. (a -> b) -> a -> b
$ Reader Rational
forall a. Fractional a => Reader a
rational Text
txt
        Bool -> Either TextDecodingError () -> Either TextDecodingError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
u Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"%") (Either TextDecodingError () -> Either TextDecodingError ())
-> Either TextDecodingError () -> Either TextDecodingError ()
forall a b. (a -> b) -> a -> b
$ TextDecodingError -> Either TextDecodingError ()
forall a b. a -> Either a b
Left TextDecodingError
err
        (MkPercentageError -> TextDecodingError)
-> Either MkPercentageError Percentage
-> Either TextDecodingError Percentage
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (TextDecodingError -> MkPercentageError -> TextDecodingError
forall a b. a -> b -> a
const TextDecodingError
err) (Either MkPercentageError Percentage
 -> Either TextDecodingError Percentage)
-> (Rational -> Either MkPercentageError Percentage)
-> Rational
-> Either TextDecodingError Percentage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Either MkPercentageError Percentage
mkPercentage (Rational -> Either TextDecodingError Percentage)
-> Rational -> Either TextDecodingError Percentage
forall a b. (a -> b) -> a -> b
$ (Rational
p Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
100)
      where
        err :: TextDecodingError
err = String -> TextDecodingError
TextDecodingError
            String
"expected a value between 0 and 100 with a '%' suffix (e.g. '14%')"

-- | Safe constructor for 'Percentage'
--
-- Takes an input in the range [0, 1].
mkPercentage
    :: Rational
    -> Either MkPercentageError Percentage
mkPercentage :: Rational -> Either MkPercentageError Percentage
mkPercentage Rational
r
    | Rational
r Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0 =
        MkPercentageError -> Either MkPercentageError Percentage
forall a b. a -> Either a b
Left MkPercentageError
PercentageOutOfBoundsError
    | Rational
r Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
1 =
        MkPercentageError -> Either MkPercentageError Percentage
forall a b. a -> Either a b
Left MkPercentageError
PercentageOutOfBoundsError
    | Bool
otherwise =
        Percentage -> Either MkPercentageError Percentage
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Percentage -> Either MkPercentageError Percentage)
-> (Rational -> Percentage)
-> Rational
-> Either MkPercentageError Percentage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Percentage
Percentage (Rational -> Either MkPercentageError Percentage)
-> Rational -> Either MkPercentageError Percentage
forall a b. (a -> b) -> a -> b
$ Rational
r

data MkPercentageError
    = PercentageOutOfBoundsError
    deriving (Int -> MkPercentageError -> ShowS
[MkPercentageError] -> ShowS
MkPercentageError -> String
(Int -> MkPercentageError -> ShowS)
-> (MkPercentageError -> String)
-> ([MkPercentageError] -> ShowS)
-> Show MkPercentageError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MkPercentageError] -> ShowS
$cshowList :: [MkPercentageError] -> ShowS
show :: MkPercentageError -> String
$cshow :: MkPercentageError -> String
showsPrec :: Int -> MkPercentageError -> ShowS
$cshowsPrec :: Int -> MkPercentageError -> ShowS
Show, MkPercentageError -> MkPercentageError -> Bool
(MkPercentageError -> MkPercentageError -> Bool)
-> (MkPercentageError -> MkPercentageError -> Bool)
-> Eq MkPercentageError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MkPercentageError -> MkPercentageError -> Bool
$c/= :: MkPercentageError -> MkPercentageError -> Bool
== :: MkPercentageError -> MkPercentageError -> Bool
$c== :: MkPercentageError -> MkPercentageError -> Bool
Eq)

-- | Safe way to make a 'Percentage' by clipping values that are
-- out of bounds.
clipToPercentage :: Rational -> Percentage
clipToPercentage :: Rational -> Percentage
clipToPercentage = Rational -> Percentage
Percentage (Rational -> Percentage)
-> (Rational -> Rational) -> Rational -> Percentage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
min Rational
1 (Rational -> Rational)
-> (Rational -> Rational) -> Rational -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
max Rational
0

-- | The complement is the amount that is missing to make it 100%.
--
-- Example: The 'complementPercentage' of 0.7 is 0.3.
complementPercentage :: Percentage -> Percentage
complementPercentage :: Percentage -> Percentage
complementPercentage (Percentage Rational
p) = Rational -> Percentage
Percentage (Rational
1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
-Rational
p)

-- | Desired number of digits after the decimal point for presenting the
-- @Percentage@ type.
percentageNumberOfFractionalDigits :: Int
percentageNumberOfFractionalDigits :: Int
percentageNumberOfFractionalDigits = Int
2

-- | Round a @Rational@ to the given amount of fractional digits.
--
-- Note: This is safe to call on repeating digits, in contrast to @fromRational@
-- (for creating a @Scientific@).
rationalToToScientific :: Int -> Rational -> Scientific
rationalToToScientific :: Int -> Rational -> Scientific
rationalToToScientific Int
fracDigits Rational
x = (Int -> Scientific
forall a b. (Real a, Fractional b) => a -> b
conv Int
i) Scientific -> Scientific -> Scientific
forall a. Fractional a => a -> a -> a
/ (Rational -> Scientific
forall a b. (Real a, Fractional b) => a -> b
conv Rational
factor)
  where
    i :: Int
    i :: Int
i = Rational -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Rational
factor Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
x)

    conv :: (Real a, Fractional b) => a -> b
    conv :: a -> b
conv = Rational -> b
forall a. Fractional a => Rational -> a
fromRational (Rational -> b) -> (a -> Rational) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rational
forall a. Real a => a -> Rational
toRational

    factor :: Rational
factor = Rational
10 Rational -> Int -> Rational
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
fracDigits

-- | Turn a @Percentage@ to a @Double@ (without any extra rounding.)
percentageToDouble :: Percentage -> Double
percentageToDouble :: Percentage -> Double
percentageToDouble = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double)
-> (Percentage -> Rational) -> Percentage -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Rational
forall a. Real a => a -> Rational
toRational (Rational -> Rational)
-> (Percentage -> Rational) -> Percentage -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Percentage -> Rational
getPercentage