{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Language.Ninja.Misc.Positive
( Positive, makePositive, fromPositive
) where
import Control.Applicative (empty)
import qualified Control.Lens.Getter as Lens
import qualified Data.Aeson as Aeson
import Control.DeepSeq (NFData)
import Data.Hashable (Hashable)
import GHC.Generics (Generic)
import qualified Test.SmallCheck.Series as SC
import Flow ((.>), (|>))
newtype Positive
= MkPositive
{ _fromPositive :: Int
}
deriving ( Eq, Ord, Real, Integral, Enum, Show, Read, Generic
, Hashable, NFData
, Aeson.ToJSON, Aeson.FromJSON )
instance Num Positive where
(MkPositive a) + (MkPositive b) = MkPositive (a + b)
(MkPositive a) * (MkPositive b) = MkPositive (a * b)
abs = id
signum = const 1
negate = ["Prelude.negate: Positive cannot be negated"]
|> mconcat |> error
fromInteger i | i > 0 = MkPositive (fromIntegral i)
| otherwise = [ "Prelude.fromInteger: "
, "Positive invariant violated"
] |> mconcat |> error
{-# INLINEABLE makePositive #-}
makePositive :: Int -> Maybe Positive
makePositive i | i > 0 = Just (MkPositive i)
| otherwise = Nothing
{-# INLINE fromPositive #-}
fromPositive :: Lens.Getter Positive Int
fromPositive = Lens.to _fromPositive
instance (Monad m) => SC.Serial m Positive where
series = MkPositive <$> (SC.series `suchThat` (> 0))
where
suchThat :: SC.Series m a -> (a -> Bool) -> SC.Series m a
suchThat s p = s >>= \x -> if p x then pure x else empty
instance (Monad m) => SC.CoSerial m Positive where
coseries = SC.coseries .> fmap (\f -> _fromPositive .> f)