{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, UndecidableInstances #-}
----------------------------------------------------------------
--                                                  ~ 2012.05.06
-- |
-- Module      :  Data.Lattice
-- Copyright   :  Copyright (c) 2012 wren ng thornton
-- License     :  BSD3
-- Maintainer  :  wren@community.haskell.org
-- Stability   :  experimental
-- Portability :  semi-portable (flexible undecidable instances)
--
-- 
----------------------------------------------------------------

module Data.Lattice
    (
    -- * Classes
      JoinSemilattice(..)
    , BoundedJoinSemilattice(..)
    , MeetSemilattice(..)
    , BoundedMeetSemilattice(..)
    , Lattice
    , BoundedLattice
    , Boolean(..)
    -- * Aliases, a la the Prelude
    , (||)
    , false
    , or
    , (&&)
    , true
    , and
    ) where
import Prelude hiding (and,or,(&&),(||),not)
import qualified Prelude

class JoinSemilattice a where
    lub   :: a -> a -> a
    lubs1 :: a -> [a] -> a

-- | > (||) = lub
(||) :: JoinSemilattice a => a -> a -> a
(||) = lub

instance JoinSemilattice Bool where
    lub        = (Prelude.||)
    lubs1 x xs = x Prelude.|| Prelude.or xs

-- Alas, the Prelude doesn't distinguish upper/lower boundedness
class JoinSemilattice a => BoundedJoinSemilattice a where
    bottom :: a
    lubs   :: [a] -> a

-- | > false = bottom
false :: BoundedJoinSemilattice a => a
false = bottom

-- | > or = lubs
or :: BoundedJoinSemilattice a => [a] -> a
or = lubs

instance BoundedJoinSemilattice Bool where
    bottom = False
    lubs   = Prelude.or

class MeetSemilattice a where
    glb   :: a -> a -> a
    glbs1 :: a -> [a] -> a

-- | > (&&) = glb
(&&) :: MeetSemilattice a => a -> a -> a
(&&) = glb

instance MeetSemilattice Bool where
    glb        = (Prelude.&&)
    glbs1 x xs = x Prelude.&& Prelude.and xs

-- Alas, the Prelude doesn't distinguish upper/lower boundedness
class MeetSemilattice a => BoundedMeetSemilattice a where
    top  :: a
    glbs :: [a] -> a

-- | > true = top
true :: BoundedMeetSemilattice a => a
true = top

-- | > and = glbs
and :: BoundedMeetSemilattice a => [a] -> a
and = glbs

instance BoundedMeetSemilattice Bool where
    top  = True
    glbs = Prelude.and

-- TODO: better as a constraint alias.
class    (JoinSemilattice a, MeetSemilattice a) => Lattice a
instance (JoinSemilattice a, MeetSemilattice a) => Lattice a

-- TODO: better as a constraint alias.
class (BoundedJoinSemilattice a, BoundedMeetSemilattice a)
    => BoundedLattice a
instance (BoundedJoinSemilattice a, BoundedMeetSemilattice a)
    => BoundedLattice a

{-
-- This is orphaned, bwuh? Also "undecidable"
instance BoundedLattice a => Bounded a where
    minBound = bottom
    maxBound = top
-}

class BoundedLattice a => Boolean a where
    not :: a -> a

instance Boolean Bool where
    not = Prelude.not

-- TODO: what's the theory behind xor? is there any?

{-
In general, it'd be worth distinguishing the finer points about (pseudo)complementation, De Morgan's laws, LEM, noncontradiction, etc., but alas, since we can't attach proofs of laws to type classes I think that wouldn't really buy us a whole lot. Of course, we should also have a PartialOrd/Poset class instead of just having Ord.
-}
----------------------------------------------------------------
----------------------------------------------------------- fin.