pad.hs

{-# LANGUAGE DeriveFunctor, Rank2Types #-}
import Algebra.Lattice
import Algebra.Lattice.Op
import Control.Monad (ap)
import qualified Data.Set as S

newtype Set a = Set {folded :: forall r. BoundedJoinSemiLattice r => (a -> r) -> r} deriving Functor

newtype JoinMonoid a = JM {unJM :: a}

instance BoundedJoinSemiLattice a => Monoid (JoinMonoid a) where
    (JM a1) `mappend` (JM a2) = JM (a1 \/ a2)
    mempty = JM bottom

fromFoldable ls = Set $ \sing -> unJM $ foldMap (JM . sing) ls

instance (Show a, Ord a) => Show (Set a) where
    show sa = "fromFoldable " ++ (show $ S.toList $ folded sa S.singleton)

instance JoinSemiLattice (Set a) where
    s1 \/ s2 = Set $ \cont -> folded s1 cont \/ folded s2 cont

instance BoundedJoinSemiLattice (Set a) where
    bottom = Set $ \cont -> bottom

instance Monad Set where
    return a = Set $ \cont -> cont a
    sa >>= asb = Set $ \cont -> folded sa (\a -> folded (asb a) cont)
    -- OR sa >>= asb = folded sa asb

instance Applicative Set where
    pure = return
    (<*>) = ap

elm a sa = folded sa $ \a' -> a == a'
subSet s1 s2 = getOp $ folded s1 $ \a -> Op $ elm a s2

instance Eq a => Eq (Set a) where
    s1 == s2 = s1 `subSet` s2 && s2 `subSet` s1