Semicategory (partial semigroup)

Semicategory.hs

import Data.Semigroup
import Data.List.NonEmpty
import Data.Semigroup.Foldable
import Test.QuickCheck

data Partial a = Undefined | Defined a
  deriving (Show)

class Semicategory m where
  (<>?) :: m -> m -> Maybe m

instance (Semicategory m) => Semigroup (Partial m) where
  Defined a <> Defined b = maybe Undefined Defined (a <>? b)
  _ <> _ = Undefined

newtype OneToTen = OneToTen Int
  deriving (Show, Eq)

instance Semicategory OneToTen where
  OneToTen x <>? OneToTen y
    | x + y > 10 = Nothing
    | otherwise = Just (OneToTen (x + y))

prop_OneToTen_assoc :: OneToTen -> OneToTen -> OneToTen -> Property
prop_OneToTen_assoc x y z =
  let
    lhs = (x <>? y >>= (<>? z))
    rhs = (x <>?) =<< (y <>? z)
  in
    collect lhs (lhs == rhs)

instance Arbitrary OneToTen where
  arbitrary = OneToTen . (+1) . (`mod` 10) <$> arbitrary

main :: IO ()
main = do 
  print $ foldMap1 Defined (OneToTen 3 :| [OneToTen 6])
  print $ foldMap1 Defined (OneToTen 2 :| [OneToTen 11])
  quickCheck prop_OneToTen_assoc