module Combinator.Booly
( Andlike(..)
, Orlike(..)
, Xorlike(..)
, Falsifier(..)
, (>&>)
, (>|>)
, andLast
, andHead
, andMappend
, andMconcat
, isFalse
, isTrue
, boolF
, voidF
, whenF
, unlessF
)
where
import Control.Applicative (Alternative(..))
import qualified Data.Attoparsec.Internal.Types as Atto
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as Map
import Data.Semigroup (Semigroup(..), Option(..))
import qualified Data.Text as T
import qualified Data.Vector as Vec
infixr 7 >&>
infixl 7 <&<
infixr 5 >|>
infixl 5 <|<
infixl 6 <^>
class Andlike a where
(<&<) :: a -> a -> a
default (<&<) :: (Applicative f, f b ~ a) => a -> a -> a
(<&<) = (<*)
class Orlike a where
(<|<) :: a -> a -> a
default (<|<) :: (Alternative f, f b ~ a) => a -> a -> a
(<|<) = (<|>)
class Xorlike a where
(<^>) :: a -> a -> a
class Falsifier a where
false :: a
default false :: Monoid a => a
false = mempty
instance Andlike () where
_ <&< _ = ()
instance Orlike () where
_ <|< _ = ()
instance Xorlike () where
_ <^> _ = ()
instance Falsifier ()
instance Andlike Bool where
(<&<) = (&&)
instance Orlike Bool where
(<|<) = (||)
instance Xorlike Bool where
ba <^> bb = (ba || bb) && (not ba || not bb)
instance Falsifier Bool where
false = False
instance Andlike (Maybe a) where
Nothing <&< _ = Nothing
_ <&< Nothing = Nothing
a <&< _ = a
instance Orlike (Maybe a) where
(Just a) <|< _ = Just a
_ <|< (Just a) = Just a
_ <|< _ = Nothing
instance Xorlike (Maybe a) where
(Just a) <^> Nothing = Just a
Nothing <^> (Just a) = Just a
_ <^> _ = Nothing
instance Falsifier (Maybe a) where
false = Nothing
instance Andlike (Option a) where
(Option Nothing) <&< _ = Option Nothing
_ <&< (Option Nothing) = Option Nothing
a <&< _ = a
instance Orlike (Option a) where
(Option (Just a)) <|< _ = Option (Just a)
_ <|< (Option (Just a)) = Option (Just a)
_ <|< _ = Option Nothing
instance Xorlike (Option a) where
(Option (Just a)) <^> (Option Nothing) = Option (Just a)
(Option Nothing) <^> (Option (Just a)) = Option (Just a)
_ <^> _ = Option Nothing
instance Falsifier (Option a) where
false = Option Nothing
instance Andlike (Either a b) where
(Left a) <&< _ = Left a
_ <&< (Left b) = Left b
a <&< _ = a
instance Orlike (Either a b) where
(Right a) <|< _ = Right a
_ <|< (Right b) = Right b
(Left a) <|< _ = Left a
instance Andlike ([] a) where
[] <&< _ = []
_ <&< [] = []
a <&< _ = a
instance Orlike ([] a) where
xs@(_:_) <|< _ = xs
_ <|< xs@(_:_) = xs
_ <|< _ = []
instance Xorlike ([] a) where
xs@(_:_) <^> [] = xs
[] <^> xs@(_:_) = xs
_ <^> _ = []
instance Falsifier ([] a)
instance Andlike T.Text where
ta <&< tb
| T.null ta || T.null tb = T.empty
| otherwise = ta
instance Orlike T.Text where
ta <|< tb
| not (T.null ta) = ta
| not (T.null tb) = tb
| otherwise = T.empty
instance Xorlike T.Text where
ta <^> tb
| not (T.null ta) && T.null tb = ta
| T.null ta && not (T.null tb) = tb
| otherwise = T.empty
instance Falsifier T.Text
instance Andlike BS.ByteString where
ba <&< bb
| BS.null ba || BS.null bb = BS.empty
| otherwise = ba
instance Andlike BL.ByteString where
ba <&< bb
| BL.null ba || BL.null bb = BL.empty
| otherwise = ba
instance Orlike BS.ByteString where
ta <|< tb
| not (BS.null ta) = ta
| not (BS.null tb) = tb
| otherwise = BS.empty
instance Orlike BL.ByteString where
ta <|< tb
| not (BL.null ta) = ta
| not (BL.null tb) = tb
| otherwise = BL.empty
instance Xorlike BS.ByteString where
ta <^> tb
| not (BS.null ta) && BS.null tb = ta
| BS.null ta && not (BS.null tb) = tb
| otherwise = BS.empty
instance Xorlike BL.ByteString where
ta <^> tb
| not (BL.null ta) && BL.null tb = ta
| BL.null ta && not (BL.null tb) = tb
| otherwise = BL.empty
instance Falsifier BS.ByteString
instance Falsifier BL.ByteString
instance Ord k => Andlike (Map.Map k v) where
ma <&< mb
| Map.null ma || Map.null mb = Map.empty
| otherwise = ma
instance Ord k => Orlike (Map.Map k v) where
ma <|< mb
| not (Map.null ma) = ma
| not (Map.null mb) = mb
| otherwise = Map.empty
instance Ord k => Xorlike (Map.Map k v) where
ma <^> mb
| not (Map.null ma) && Map.null mb = ma
| Map.null ma && not (Map.null mb) = mb
| otherwise = Map.empty
instance Ord k => Falsifier (Map.Map k v) where
false = Map.empty
instance Andlike (Vec.Vector a)
instance Orlike (Vec.Vector a)
instance Xorlike (Vec.Vector a) where
va <^> vb
| not (Vec.null va) && Vec.null vb = va
| Vec.null va && not (Vec.null vb) = vb
| otherwise = Vec.empty
instance Falsifier (Vec.Vector a)
instance Andlike (Atto.Parser i a)
instance Orlike (Atto.Parser i a)
instance Falsifier (Atto.Parser i a)
instance (Andlike a, Andlike b) => Andlike (a, b) where
(a1, b1) <&< (a2, b2) = (a1 <&< a2, b1 <&< b2)
instance (Orlike a, Orlike b) => Orlike (a, b) where
(a1, b1) <|< (a2, b2) = (a1 <|< a2, b1 <|< b2)
instance (Andlike a, Andlike b, Andlike c) => Andlike (a, b, c) where
(a1, b1, c1) <&< (a2, b2, c2) = (a1 <&< a2, b1 <&< b2, c1 <&< c2)
instance (Orlike a, Orlike b, Orlike c) => Orlike (a, b, c) where
(a1, b1, c1) <|< (a2, b2, c2) = (a1 <|< a2, b1 <|< b2, c1 <|< c2)
instance (Andlike a, Andlike b, Andlike c, Andlike d) => Andlike (a, b, c, d) where
(a1, b1, c1, d1) <&< (a2, b2, c2, d2) = (a1 <&< a2, b1 <&< b2, c1 <&< c2, d1 <&< d2)
instance (Orlike a, Orlike b, Orlike c, Orlike d) => Orlike (a, b, c, d) where
(a1, b1, c1, d1) <|< (a2, b2, c2, d2) = (a1 <|< a2, b1 <|< b2, c1 <|< c2, d1 <|< d2)
(>&>) :: Andlike a => a -> a -> a
(>&>) = flip (<&<)
(>|>) :: Orlike a => a -> a -> a
(>|>) = flip (<|<)
andHead :: (Andlike a, Falsifier a, Foldable t) => t a -> a
andHead as
| null as = false
| otherwise = foldr1 (<&<) as
andLast :: (Andlike a, Falsifier a, Foldable t) => t a -> a
andLast as
| null as = false
| otherwise = foldr1 (>&>) as
andMappend :: (Andlike a, Monoid a) => a -> a -> a
andMappend a b = (a <&< b) `mappend` (a >&> b)
andMconcat :: (Andlike a, Falsifier a, Monoid a, Foldable t) => t a -> a
andMconcat as
| null as = false
| otherwise = foldr1 andMappend as
isFalse :: (Eq a, Falsifier a) => a -> Bool
isFalse = (false ==)
isTrue :: (Eq a, Falsifier a) => a -> Bool
isTrue = not . isFalse
boolF :: (Eq b, Falsifier b) => a -> a -> b -> a
boolF a b f = if isTrue f then a else b
voidF :: Falsifier a => a -> a
voidF = const false
whenF :: (Eq a, Eq b, Falsifier a, Falsifier b) => a -> b -> b
whenF fa fb = if isTrue fa then fb else false
unlessF :: (Eq a, Eq b, Falsifier a, Falsifier b) => a -> b -> b
unlessF fa fb = if isFalse fa then fb else false