summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorShou <>2016-09-22 20:10:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-09-22 20:10:00 (GMT)
commit98e0b8e7f4fc27150fbdc80a8a2f656a936b3454 (patch)
tree9484e749318ca61f12f5fb5c23200a7173fa184f
version 0.1.0.00.1.0.0
-rw-r--r--Combinator/Booly.hs388
-rw-r--r--LICENSE30
-rw-r--r--Setup.hs2
-rw-r--r--boolean-like.cabal32
4 files changed, 452 insertions, 0 deletions
diff --git a/Combinator/Booly.hs b/Combinator/Booly.hs
new file mode 100644
index 0000000..bb38cff
--- /dev/null
+++ b/Combinator/Booly.hs
@@ -0,0 +1,388 @@
+
+{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs #-}
+
+
+-- | A set of typeclasses 'Falsifier', 'Andlike', 'Orlike', and 'Xorlike',
+-- that define operations dealing with boolean-representable structures such
+-- as 'Maybe' which has true-like 'Just' and false-like 'Nothing', or '[]' by
+-- true-like non-empty list and false-like empty list.
+module Combinator.Booly
+ ( Andlike(..)
+ , Orlike(..)
+ , Xorlike(..)
+ , Falsifier(..)
+ , (>&>)
+ , (>|>)
+ , andLast
+ , andHead
+ , andMappend
+ , andMconcat
+ , isFalse
+ , isTrue
+ , boolF
+ , voidF
+ , whenF
+ , unlessF
+ )
+ where
+
+
+import Control.Applicative (Alternative(..))
+
+-- FIXME both strict and lazy structures when necessary
+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 <^>
+
+
+-- | Boolean-like logic operation '>&>' that acts like AND for any
+-- boolean-representable datatypes, e.g. '[]' or 'Maybe'.
+--
+-- __Associativity__
+--
+-- prop> (a >&> b) >&> c == a >&> (b >&> c)
+--
+-- __Absorbing element / truth table__
+--
+-- prop> false >&> false == false
+-- prop> false >&> b == false
+-- prop> a >&> false == false
+-- prop> a >&> b == b
+--
+class Andlike a where
+ -- | Andlike operator, returns the rightmost argument on success, i.e.
+ -- if no 'false' are present.
+ (<&<) :: a -> a -> a
+
+ -- | '<*' often shares behaviour with '<&<'.
+ default (<&<) :: (Applicative f, f b ~ a) => a -> a -> a
+ (<&<) = (<*)
+
+-- | Boolean-like logic operation '<|<' that acts like OR for any
+-- boolean-representable datatypes, e.g. '[]' or 'Maybe'. It is basically
+-- 'Control.Applicative.(<|>)' with a list instance that doesn't append.
+--
+-- __Associativity__
+--
+-- prop> (a <|< b) <|< c == a <|< (b <|< c)
+--
+-- __Absorbing element / truth table__
+--
+-- prop> false <|< false == false
+-- prop> false <|< b == b
+-- prop> a <|< false == a
+-- prop> a <|< b == a
+--
+class Orlike a where
+ -- | Orlike operator, returns the leftmost true-like argument,
+ -- otherwise the rightmost true-like argument, or finally 'false'.
+ (<|<) :: a -> a -> a
+
+ -- | All '<|>' instances except list-likes should share behaviour.
+ default (<|<) :: (Alternative f, f b ~ a) => a -> a -> a
+ (<|<) = (<|>)
+
+-- | Boolean-like logic operation '<^>' that acts like XOR for any
+-- boolean-representable datatypes, e.g. '[]' or 'Maybe'.
+--
+-- __Absorbing element / truth table__
+--
+-- prop> false <^> false == false
+-- prop> false <^> b == b
+-- prop> a <^> false == a
+-- prop> a <^> b == false
+--
+class Xorlike a where
+ -- | Xorlike operator, returns whichever argument is true-like as both
+ -- cannot simultaneously be true-like values, or 'false'.
+ (<^>) :: a -> a -> a
+
+class Falsifier a where
+ false :: a
+
+ default false :: Monoid a => a
+ false = mempty
+
+-- {{{ Instances
+
+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)
+
+-- TODO
+--instance Xorlike (Atto.Parser i a) where
+
+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)
+
+
+-- }}}
+
+
+-- | Flipped version of '<&<'. Returns the leftmost argument on both
+-- success or failure.
+(>&>) :: Andlike a => a -> a -> a
+(>&>) = flip (<&<)
+
+-- | Flipped version of '<|<'. Returns the leftmost argument on both
+-- success or failure.
+(>|>) :: Orlike a => a -> a -> a
+(>|>) = flip (<|<)
+
+-- | Returns the first element on success of all values.
+andHead :: (Andlike a, Falsifier a, Foldable t) => t a -> a
+andHead as
+ | null as = false
+ | otherwise = foldr1 (<&<) as
+
+-- | Returns the last element on success of all values.
+andLast :: (Andlike a, Falsifier a, Foldable t) => t a -> a
+andLast as
+ | null as = false
+ | otherwise = foldr1 (>&>) as
+
+-- | Monadic append with the annihilating operator guarding each argument.
+-- Returns the mappended result on success.
+andMappend :: (Andlike a, Monoid a) => a -> a -> a
+andMappend a b = (a <&< b) `mappend` (a >&> b)
+
+-- | Monadic concatenation with the annihilating operator guarding each argument.
+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
+
+-- | Similar to 'Data.Bool.bool'.
+boolF :: (Eq b, Falsifier b) => a -> a -> b -> a
+boolF a b f = if isTrue f then a else b
+
+-- | Discard the argument and return 'false'.
+voidF :: Falsifier a => a -> a
+voidF = const false
+
+-- | Similar to `when` but takes a boolean-like and returns `false`
+-- instead of `()`.
+whenF :: (Eq a, Eq b, Falsifier a, Falsifier b) => a -> b -> b
+whenF fa fb = if isTrue fa then fb else false
+
+-- | Similar to `unless` but takes a boolean-like and returns `false`
+-- instead of `()`.
+unlessF :: (Eq a, Eq b, Falsifier a, Falsifier b) => a -> b -> b
+unlessF fa fb = if isFalse fa then fb else false
+
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..c863395
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Benedict Aas (c) 2016
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Author name here nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/boolean-like.cabal b/boolean-like.cabal
new file mode 100644
index 0000000..d9015cf
--- /dev/null
+++ b/boolean-like.cabal
@@ -0,0 +1,32 @@
+name: boolean-like
+version: 0.1.0.0
+synopsis: Logical combinatory operations dealing with datatypes
+ representing booleans by their constructors.
+description:
+ Boolean-like logical combinatory operations under typeclasses
+ Andlike, Orlike, and Xorlike and a typeclass Falsifier for datatypes with
+ unary false-like values (e.g. Nothing, []).
+homepage: http://github.com/Shou/boolean-like
+bug-reports: http://github.com/Shou/boolean-like/issues
+license: BSD3
+license-file: LICENSE
+author: Benedict Aas
+maintainer: x@shou.io
+copyright: 2016 Benedict Aas
+category: Control
+build-type: Simple
+-- extra-source-files:
+cabal-version: >=1.10
+tested-with:
+ GHC==7.10.3
+
+library
+ exposed-modules: Combinator.Booly
+ build-depends: attoparsec, base >= 4.7 && < 5, bytestring, containers,
+ semigroups, text, vector
+ default-language: Haskell2010
+
+source-repository head
+ type: git
+ location: https://github.com/Shou/boolean-like
+