-- |
-- A monoid that only admits a single value.
{-# LANGUAGE CPP #-}
module Web.Route.Invertible.Monoid.Exactly
  ( Exactly(..)
  , maybeToExactly
  , exactlyToMaybe
  , listToExactly
  , exactlyToList
  ) where

import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus(..))
import Data.Semigroup (Semigroup((<>)))

-- |A 'Maybe'-like monoid that only allows one value, overflowing into 'Conflict' when more than one 'Exactly' are combined (with '<|>' or 'Data.Monoid.<>', which thus function identically).
data Exactly a
  = Blank -- ^ 'Nothing'
  | Exactly a -- ^ 'Just'
  | Conflict -- ^ 'fail': 'error' in most cases that attempt to access a value
  deriving (Exactly a -> Exactly a -> Bool
(Exactly a -> Exactly a -> Bool)
-> (Exactly a -> Exactly a -> Bool) -> Eq (Exactly a)
forall a. Eq a => Exactly a -> Exactly a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Exactly a -> Exactly a -> Bool
$c/= :: forall a. Eq a => Exactly a -> Exactly a -> Bool
== :: Exactly a -> Exactly a -> Bool
$c== :: forall a. Eq a => Exactly a -> Exactly a -> Bool
Eq, Eq (Exactly a)
Eq (Exactly a)
-> (Exactly a -> Exactly a -> Ordering)
-> (Exactly a -> Exactly a -> Bool)
-> (Exactly a -> Exactly a -> Bool)
-> (Exactly a -> Exactly a -> Bool)
-> (Exactly a -> Exactly a -> Bool)
-> (Exactly a -> Exactly a -> Exactly a)
-> (Exactly a -> Exactly a -> Exactly a)
-> Ord (Exactly a)
Exactly a -> Exactly a -> Bool
Exactly a -> Exactly a -> Ordering
Exactly a -> Exactly a -> Exactly 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 (Exactly a)
forall a. Ord a => Exactly a -> Exactly a -> Bool
forall a. Ord a => Exactly a -> Exactly a -> Ordering
forall a. Ord a => Exactly a -> Exactly a -> Exactly a
min :: Exactly a -> Exactly a -> Exactly a
$cmin :: forall a. Ord a => Exactly a -> Exactly a -> Exactly a
max :: Exactly a -> Exactly a -> Exactly a
$cmax :: forall a. Ord a => Exactly a -> Exactly a -> Exactly a
>= :: Exactly a -> Exactly a -> Bool
$c>= :: forall a. Ord a => Exactly a -> Exactly a -> Bool
> :: Exactly a -> Exactly a -> Bool
$c> :: forall a. Ord a => Exactly a -> Exactly a -> Bool
<= :: Exactly a -> Exactly a -> Bool
$c<= :: forall a. Ord a => Exactly a -> Exactly a -> Bool
< :: Exactly a -> Exactly a -> Bool
$c< :: forall a. Ord a => Exactly a -> Exactly a -> Bool
compare :: Exactly a -> Exactly a -> Ordering
$ccompare :: forall a. Ord a => Exactly a -> Exactly a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Exactly a)
Ord, Int -> Exactly a -> ShowS
[Exactly a] -> ShowS
Exactly a -> String
(Int -> Exactly a -> ShowS)
-> (Exactly a -> String)
-> ([Exactly a] -> ShowS)
-> Show (Exactly a)
forall a. Show a => Int -> Exactly a -> ShowS
forall a. Show a => [Exactly a] -> ShowS
forall a. Show a => Exactly a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Exactly a] -> ShowS
$cshowList :: forall a. Show a => [Exactly a] -> ShowS
show :: Exactly a -> String
$cshow :: forall a. Show a => Exactly a -> String
showsPrec :: Int -> Exactly a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Exactly a -> ShowS
Show, ReadPrec [Exactly a]
ReadPrec (Exactly a)
Int -> ReadS (Exactly a)
ReadS [Exactly a]
(Int -> ReadS (Exactly a))
-> ReadS [Exactly a]
-> ReadPrec (Exactly a)
-> ReadPrec [Exactly a]
-> Read (Exactly a)
forall a. Read a => ReadPrec [Exactly a]
forall a. Read a => ReadPrec (Exactly a)
forall a. Read a => Int -> ReadS (Exactly a)
forall a. Read a => ReadS [Exactly a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Exactly a]
$creadListPrec :: forall a. Read a => ReadPrec [Exactly a]
readPrec :: ReadPrec (Exactly a)
$creadPrec :: forall a. Read a => ReadPrec (Exactly a)
readList :: ReadS [Exactly a]
$creadList :: forall a. Read a => ReadS [Exactly a]
readsPrec :: Int -> ReadS (Exactly a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Exactly a)
Read)

instance Functor Exactly where
  fmap :: (a -> b) -> Exactly a -> Exactly b
fmap a -> b
_ Exactly a
Blank = Exactly b
forall a. Exactly a
Blank
  fmap a -> b
f (Exactly a
a) = b -> Exactly b
forall a. a -> Exactly a
Exactly (a -> b
f a
a)
  fmap a -> b
_ Exactly a
Conflict = Exactly b
forall a. Exactly a
Conflict
-- |Conflict always overrides other values.
instance Applicative Exactly where
  pure :: a -> Exactly a
pure = a -> Exactly a
forall a. a -> Exactly a
Exactly
  Exactly a -> b
f <*> :: Exactly (a -> b) -> Exactly a -> Exactly b
<*> Exactly a
x = b -> Exactly b
forall a. a -> Exactly a
Exactly (a -> b
f a
x)
  Exactly (a -> b)
_ <*> Exactly a
Conflict = Exactly b
forall a. Exactly a
Conflict
  Exactly (a -> b)
Conflict <*> Exactly a
_ = Exactly b
forall a. Exactly a
Conflict
  Exactly (a -> b)
_ <*> Exactly a
_ = Exactly b
forall a. Exactly a
Blank
-- |Same as for 'Maybe', except that @Exactly _ <|> Exactly _ = Conflict@.
instance Alternative Exactly where
  empty :: Exactly a
empty = Exactly a
forall a. Exactly a
Blank
  Exactly a
Blank <|> :: Exactly a -> Exactly a -> Exactly a
<|> Exactly a
e = Exactly a
e
  Exactly a
e <|> Exactly a
Blank = Exactly a
e
  Exactly a
_ <|> Exactly a
_ = Exactly a
forall a. Exactly a
Conflict  
instance Monad Exactly where
  Exactly a
Blank >>= :: Exactly a -> (a -> Exactly b) -> Exactly b
>>= a -> Exactly b
_ = Exactly b
forall a. Exactly a
Blank
  Exactly a
x >>= a -> Exactly b
f = a -> Exactly b
f a
x
  Exactly a
Conflict >>= a -> Exactly b
_ = Exactly b
forall a. Exactly a
Conflict
  Exactly a
_ >> :: Exactly a -> Exactly b -> Exactly b
>> Exactly b
e = Exactly b
e
  Exactly a
Conflict >> Exactly b
_ = Exactly b
forall a. Exactly a
Conflict
  Exactly a
_ >> Exactly b
Conflict = Exactly b
forall a. Exactly a
Conflict
  Exactly a
_ >> Exactly b
_ = Exactly b
forall a. Exactly a
Blank
#if MIN_VERSION_base(4,13,0)
instance MonadFail Exactly where
#endif
  fail :: String -> Exactly a
fail String
_ = Exactly a
forall a. Exactly a
Conflict
instance MonadPlus Exactly

instance Semigroup (Exactly a) where
  <> :: Exactly a -> Exactly a -> Exactly a
(<>) = Exactly a -> Exactly a -> Exactly a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

-- |Combines using the 'Alternative' instance, similar to an @'Data.Monoid.Alt' 'Maybe'@.
instance Monoid (Exactly a) where
  mempty :: Exactly a
mempty = Exactly a
forall a. Exactly a
Blank
  mappend :: Exactly a -> Exactly a -> Exactly a
mappend = Exactly a -> Exactly a -> Exactly a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

instance Foldable Exactly where
  foldr :: (a -> b -> b) -> b -> Exactly a -> b
foldr a -> b -> b
_ b
z Exactly a
Blank = b
z
  foldr a -> b -> b
f b
z (Exactly a
x) = a -> b -> b
f a
x b
z
  foldr a -> b -> b
f b
z Exactly a
Conflict = a -> b -> b
f (String -> a
forall a. HasCallStack => String -> a
error String
"foldr: Conflict") b
z
  foldl :: (b -> a -> b) -> b -> Exactly a -> b
foldl b -> a -> b
_ b
z Exactly a
Blank = b
z
  foldl b -> a -> b
f b
z (Exactly a
x) = b -> a -> b
f b
z a
x 
  foldl b -> a -> b
f b
z Exactly a
Conflict = b -> a -> b
f b
z (String -> a
forall a. HasCallStack => String -> a
error String
"foldl: Conflict")
instance Traversable Exactly where
  traverse :: (a -> f b) -> Exactly a -> f (Exactly b)
traverse a -> f b
_ Exactly a
Blank = Exactly b -> f (Exactly b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exactly b
forall a. Exactly a
Blank
  traverse a -> f b
f (Exactly a
x) = b -> Exactly b
forall a. a -> Exactly a
Exactly (b -> Exactly b) -> f b -> f (Exactly b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x 
  traverse a -> f b
_ Exactly a
Conflict = Exactly b -> f (Exactly b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exactly b
forall a. Exactly a
Conflict

-- |@exactlyToMaybe . maybeToExactly == id@
maybeToExactly :: Maybe a -> Exactly a
maybeToExactly :: Maybe a -> Exactly a
maybeToExactly Maybe a
Nothing = Exactly a
forall a. Exactly a
Blank
maybeToExactly (Just a
x) = a -> Exactly a
forall a. a -> Exactly a
Exactly a
x

-- |@exactlyToMaybe Conflict@ is an error.
exactlyToMaybe :: Exactly a -> Maybe a
exactlyToMaybe :: Exactly a -> Maybe a
exactlyToMaybe Exactly a
Blank = Maybe a
forall a. Maybe a
Nothing
exactlyToMaybe (Exactly a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
exactlyToMaybe Exactly a
Conflict = String -> Maybe a
forall a. HasCallStack => String -> a
error String
"exactlyToMaybe: Conflict"

-- |Conflict for any list with more than one element.
listToExactly :: [a] -> Exactly a
listToExactly :: [a] -> Exactly a
listToExactly [] = Exactly a
forall a. Exactly a
Blank
listToExactly [a
x] = a -> Exactly a
forall a. a -> Exactly a
Exactly a
x
listToExactly [a]
_ = Exactly a
forall a. Exactly a
Conflict

-- |@exactlyToList Conflict@ is an error.
exactlyToList :: Exactly a -> [a]
exactlyToList :: Exactly a -> [a]
exactlyToList Exactly a
Blank = []
exactlyToList (Exactly a
x) = [a
x]
exactlyToList Exactly a
Conflict = String -> [a]
forall a. HasCallStack => String -> a
error String
"exactlyToList: Conflict"