{-# OPTIONS_GHC -fno-warn-orphans #-}

module Servant.Util.Internal.Util
    ( Positive (..)
    , toPositive
    , unsafeToPositive
    , IsNotZero
    , KnownPositive
    , positiveVal
    ) where

import Universum

import Fmt (Buildable (..))
import GHC.TypeLits (ErrorMessage (..), TypeError)
import Servant (FromHttpApiData (..), ToHttpApiData (..))

newtype Positive a = PositiveUnsafe { Positive a -> a
unPositive :: a }
    deriving (Int -> Positive a -> ShowS
[Positive a] -> ShowS
Positive a -> String
(Int -> Positive a -> ShowS)
-> (Positive a -> String)
-> ([Positive a] -> ShowS)
-> Show (Positive a)
forall a. Show a => Int -> Positive a -> ShowS
forall a. Show a => [Positive a] -> ShowS
forall a. Show a => Positive a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Positive a] -> ShowS
$cshowList :: forall a. Show a => [Positive a] -> ShowS
show :: Positive a -> String
$cshow :: forall a. Show a => Positive a -> String
showsPrec :: Int -> Positive a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Positive a -> ShowS
Show, Positive a -> Positive a -> Bool
(Positive a -> Positive a -> Bool)
-> (Positive a -> Positive a -> Bool) -> Eq (Positive a)
forall a. Eq a => Positive a -> Positive a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Positive a -> Positive a -> Bool
$c/= :: forall a. Eq a => Positive a -> Positive a -> Bool
== :: Positive a -> Positive a -> Bool
$c== :: forall a. Eq a => Positive a -> Positive a -> Bool
Eq, Eq (Positive a)
Eq (Positive a)
-> (Positive a -> Positive a -> Ordering)
-> (Positive a -> Positive a -> Bool)
-> (Positive a -> Positive a -> Bool)
-> (Positive a -> Positive a -> Bool)
-> (Positive a -> Positive a -> Bool)
-> (Positive a -> Positive a -> Positive a)
-> (Positive a -> Positive a -> Positive a)
-> Ord (Positive a)
Positive a -> Positive a -> Bool
Positive a -> Positive a -> Ordering
Positive a -> Positive a -> Positive 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 a. Ord a => Eq (Positive a)
forall a. Ord a => Positive a -> Positive a -> Bool
forall a. Ord a => Positive a -> Positive a -> Ordering
forall a. Ord a => Positive a -> Positive a -> Positive a
min :: Positive a -> Positive a -> Positive a
$cmin :: forall a. Ord a => Positive a -> Positive a -> Positive a
max :: Positive a -> Positive a -> Positive a
$cmax :: forall a. Ord a => Positive a -> Positive a -> Positive a
>= :: Positive a -> Positive a -> Bool
$c>= :: forall a. Ord a => Positive a -> Positive a -> Bool
> :: Positive a -> Positive a -> Bool
$c> :: forall a. Ord a => Positive a -> Positive a -> Bool
<= :: Positive a -> Positive a -> Bool
$c<= :: forall a. Ord a => Positive a -> Positive a -> Bool
< :: Positive a -> Positive a -> Bool
$c< :: forall a. Ord a => Positive a -> Positive a -> Bool
compare :: Positive a -> Positive a -> Ordering
$ccompare :: forall a. Ord a => Positive a -> Positive a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Positive a)
Ord)

instance Buildable x => Buildable (Positive x) where
    build :: Positive x -> Builder
build = x -> Builder
forall p. Buildable p => p -> Builder
build (x -> Builder) -> (Positive x -> x) -> Positive x -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive x -> x
forall a. Positive a -> a
unPositive

toPositive :: (Show a, Ord a, Num a) => a -> Either Text (Positive a)
toPositive :: a -> Either Text (Positive a)
toPositive a
a
    | a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 = Positive a -> Either Text (Positive a)
forall a b. b -> Either a b
Right (Positive a -> Either Text (Positive a))
-> Positive a -> Either Text (Positive a)
forall a b. (a -> b) -> a -> b
$ a -> Positive a
forall a. a -> Positive a
PositiveUnsafe a
a
    | Bool
otherwise = Text -> Either Text (Positive a)
forall a b. a -> Either a b
Left (Text -> Either Text (Positive a))
-> Text -> Either Text (Positive a)
forall a b. (a -> b) -> a -> b
$ Text
"Non-positive value: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
a

unsafeToPositive :: (Show a, Ord a, Num a, HasCallStack) => a -> Positive a
unsafeToPositive :: a -> Positive a
unsafeToPositive = (Text -> Positive a)
-> (Positive a -> Positive a)
-> Either Text (Positive a)
-> Positive a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Positive a
forall a. HasCallStack => Text -> a
error Positive a -> Positive a
forall a. a -> a
id (Either Text (Positive a) -> Positive a)
-> (a -> Either Text (Positive a)) -> a -> Positive a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either Text (Positive a)
forall a. (Show a, Ord a, Num a) => a -> Either Text (Positive a)
toPositive

type family IsNotZero (k :: Nat) :: Constraint where
    IsNotZero 0 = TypeError ('Text "Null is now allowed here")
    IsNotZero k = ()

type KnownPositive k = (KnownNat k, IsNotZero k)

positiveVal :: forall k i. (KnownPositive k, Num i) => Positive i
positiveVal :: Positive i
positiveVal = i -> Positive i
forall a. a -> Positive a
PositiveUnsafe (i -> Positive i) -> (Natural -> i) -> Natural -> Positive i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> i
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Positive i) -> Natural -> Positive i
forall a b. (a -> b) -> a -> b
$ Proxy k -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal @k Proxy k
forall k (t :: k). Proxy t
Proxy

instance (FromHttpApiData a, Show a, Ord a, Num a) => FromHttpApiData (Positive a) where
    parseUrlPiece :: Text -> Either Text (Positive a)
parseUrlPiece Text
t = Text -> Either Text a
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece @a Text
t Either Text a
-> (a -> Either Text (Positive a)) -> Either Text (Positive a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Either Text (Positive a)
forall a. (Show a, Ord a, Num a) => a -> Either Text (Positive a)
toPositive

instance ToHttpApiData a => ToHttpApiData (Positive a) where
    toUrlPiece :: Positive a -> Text
toUrlPiece = ToHttpApiData a => a -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece @a (a -> Text) -> (Positive a -> a) -> Positive a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive a -> a
forall a. Positive a -> a
unPositive