module Web.Route.Invertible.Monoid.Exactly
( Exactly(..)
, maybeToExactly
, exactlyToMaybe
, listToExactly
, exactlyToList
) where
import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus(..))
import Data.Semigroup (Semigroup((<>)))
data Exactly a
= Blank
| Exactly a
| Conflict
deriving (Eq, Ord, Show, Read)
instance Functor Exactly where
fmap _ Blank = Blank
fmap f (Exactly a) = Exactly (f a)
fmap _ Conflict = Conflict
instance Applicative Exactly where
pure = Exactly
Exactly f <*> Exactly x = Exactly (f x)
_ <*> Conflict = Conflict
Conflict <*> _ = Conflict
_ <*> _ = Blank
instance Alternative Exactly where
empty = Blank
Blank <|> e = e
e <|> Blank = e
_ <|> _ = Conflict
instance Monad Exactly where
Blank >>= _ = Blank
Exactly x >>= f = f x
Conflict >>= _ = Conflict
Exactly _ >> e = e
Conflict >> _ = Conflict
_ >> Conflict = Conflict
_ >> _ = Blank
fail _ = Conflict
instance MonadPlus Exactly
instance Semigroup (Exactly a) where
(<>) = (<|>)
instance Monoid (Exactly a) where
mempty = Blank
mappend = (<|>)
instance Foldable Exactly where
foldr _ z Blank = z
foldr f z (Exactly x) = f x z
foldr f z Conflict = f (error "foldr: Conflict") z
foldl _ z Blank = z
foldl f z (Exactly x) = f z x
foldl f z Conflict = f z (error "foldl: Conflict")
instance Traversable Exactly where
traverse _ Blank = pure Blank
traverse f (Exactly x) = Exactly <$> f x
traverse _ Conflict = pure Conflict
maybeToExactly :: Maybe a -> Exactly a
maybeToExactly Nothing = Blank
maybeToExactly (Just x) = Exactly x
exactlyToMaybe :: Exactly a -> Maybe a
exactlyToMaybe Blank = Nothing
exactlyToMaybe (Exactly x) = Just x
exactlyToMaybe Conflict = error "exactlyToMaybe: Conflict"
listToExactly :: [a] -> Exactly a
listToExactly [] = Blank
listToExactly [x] = Exactly x
listToExactly _ = Conflict
exactlyToList :: Exactly a -> [a]
exactlyToList Blank = []
exactlyToList (Exactly x) = [x]
exactlyToList Conflict = error "exactlyToList: Conflict"