Logic.hs

{-# LANGUAGE DeriveGeneric #-}
-- |
-- Module: Data.Greskell.Logic
-- Description: Logic tree data structure
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- Developer note: This module defines 'Logic', a data structure for
-- logic operation tree. There are already similar packages to this
-- module, but, none of them satisfy our requirements.
--
-- Boolean/logic tree data structures
--
-- - https://hackage.haskell.org/package/boolean-normal-forms
-- - https://hackage.haskell.org/package/logic-classes
-- - https://hackage.haskell.org/package/PropLogic
-- - https://hackage.haskell.org/package/Logic
-- - https://hackage.haskell.org/package/boolean-like
--
-- Typeclasses about boolean/logic operations
--
-- - https://hackage.haskell.org/package/Boolean
-- - https://hackage.haskell.org/package/cond
--
-- Trees that contain heterogeneous values
--
-- - http://hackage.haskell.org/package/dual-tree
-- - http://hackage.haskell.org/package/fingertree
--
-- @since 1.2.0.0
module Data.Greskell.Logic
    ( Logic (..)
    , runBool
    ) where

import           Control.Applicative (Applicative (pure, (<*>)), (<$>))
import           Control.Monad       (Monad (return, (>>=)))
import           Data.Foldable       (Foldable (foldMap, toList))
import           Data.Monoid         (All (..), Any (..), (<>))
import           Data.Traversable    (Traversable)
import           GHC.Generics        (Generic)

-- | A general-purpose logic tree structure. Only the leaf nodes have
-- values of type @a@. The tree is lazy both in value and spine (structure).
data Logic a
  = Leaf a -- ^ Leaf node with value
  | And (Logic a) [Logic a] -- ^ \"and\" logic operator
  | Or (Logic a) [Logic a] -- ^ \"or\" logic operator
  | Not (Logic a) -- ^ \"not\" logic operator
  deriving (Eq, Generic, Ord, Show)

instance Functor Logic where
  fmap f l =
    case l of
      Leaf a     -> Leaf (f a)
      And ll rls -> And (fmap f ll) (map (fmap f) rls)
      Or ll rls  -> Or (fmap f ll) (map (fmap f) rls)
      Not nl     -> Not (fmap f nl)

-- | 'pure' is 'Leaf'. @fl@ '<*>' @rl@ appends the @rl@ to the leaves
-- of @fl@.
instance Applicative Logic where
  pure a = Leaf a
  fl <*> rl =
    case fl of
      Leaf f       -> fmap f rl
      And lfl rfls -> And (lfl <*> rl) (map (<*> rl) rfls)
      Or lfl rfls  -> Or (lfl <*> rl) (map (<*> rl) rfls)
      Not nfl      -> Not (nfl <*> rl)

instance Monad Logic where
  return = pure
  l >>= f =
    case l of
      Leaf a     -> f a
      And ll rls -> And (ll >>= f) (map (>>= f) rls)
      Or ll rls  -> Or (ll >>= f) (map (>>= f) rls)
      Not nl     -> Not (nl >>= f)

instance Foldable Logic where
  foldMap f l =
    case l of
      Leaf a     -> f a
      And ll rls -> foldMap f ll <> foldMap (foldMap f) rls
      Or ll rls  -> foldMap f ll <> foldMap (foldMap f) rls
      Not nl     -> foldMap f nl

instance Traversable Logic where
  traverse f l =
    case l of
      Leaf a     -> Leaf <$> f a
      And ll rls -> And <$> traverse f ll <*> traverse (traverse f) rls
      Or ll rls  -> Or <$> traverse f ll <*> traverse (traverse f) rls
      Not nl     -> Not <$> traverse f nl

-- | Run the logic tree of 'Bool' values to get the result.
runBool :: Logic Bool -> Bool
runBool l =
  case l of
    Leaf b     -> b
    And ll rls -> getAll $ mconcat $ (All $ runBool ll) : map (All . runBool) rls
    Or ll rls  -> getAny $ mconcat $ (Any $ runBool ll) : map (Any . runBool) rls
    Not nl     -> not $ runBool nl