BoolOp.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}

-- |
module Flare.AST.BoolOp where

import Control.Monad
import Control.Monad.Trans
import Data.List (intersperse)
import Prelude hiding (and, not, or)
import Prelude.Extras

import qualified Prelude as P

data BoolOp a
  = Prim a
  | Not (BoolOp a)
  | And (BoolOp a) (BoolOp a)
  | Or  (BoolOp a) (BoolOp a)
  | Any [BoolOp a]
  | All [BoolOp a]
  deriving (Eq, Functor, Foldable, Traversable)

instance Applicative BoolOp where
  pure a     = return a
  bfa <*> ba = bfa >>= \fa -> ba >>= return . fa

instance Monad BoolOp where
  return a       = Prim a
  Prim a   >>= f = f a
  Not  a   >>= f = Not (a >>= f)
  Or   l r >>= f = Or  (l >>= f) (r >>= f)
  And  l r >>= f = And (l >>= f) (r >>= f)
  Any  as  >>= f = Any $ (>>= f) <$> as
  All  as  >>= f = All $ (>>= f) <$> as

newtype BoolOpT m a = BoolOpT { runBoolOpT :: m (BoolOp a) }
  deriving (Functor, Foldable, Traversable)

instance (Show1 m, Show a) => Show (BoolOpT m a) where
  show (BoolOpT m) = parens ["BoolOpT", parens [show1 m]]

instance (Monad m) => Applicative (BoolOpT m) where
  pure a     = return a
  bfa <*> ba = bfa >>= \fa -> ba >>= return . fa

instance (Monad m) => Monad (BoolOpT m) where
  return  = lift . return
  x >>= f = BoolOpT $ do
    op <- runBoolOpT x
    join <$> sequence (runBoolOpT . f <$> op)

instance MonadTrans BoolOpT where
  lift = BoolOpT . liftM Prim

-- |
reduceBoolOp :: Monad m =>
               (a -> BoolOpT m b)
            -> (b -> m Bool)
            -> BoolOp a
            -> m Bool
reduceBoolOp f g expr = reduceBoolOpMT g $ stepBoolOp expr f where
  reduceBoolOpM :: Monad m => (a -> m Bool) -> BoolOp (m a) -> m Bool
  reduceBoolOpM f b = f' $ b >>= \ma -> return (ma >>= f) where
    f' (Prim a)  = a
    f' (Not b')  = P.not <$> f' b'
    f' (And l r) = f' (All [l,r])
    f' (Or  l r) = f' (Any [l,r])
    f' (Any bs)  = P.any id <$> (sequence $ f' <$> bs)
    f' (All bs)  = P.all id <$> (sequence $ f' <$> bs)
  reduceBoolOpMT :: Monad m => (a -> m Bool) -> BoolOpT m a -> m Bool
  reduceBoolOpMT f b = runBoolOpT b >>= reduceBoolOpM f . fmap return where

-- | Used for recursive eval calls
stepBoolOp :: Monad m => BoolOp a -> (a -> BoolOpT m b) -> BoolOpT m b
stepBoolOp expr f = BoolOpT (fmap join $ runBoolOpT $ traverse f expr)

instance Show a => Show (BoolOp a) where
  show (Prim    a) = show a
  show (And e1 e2) = parens [show e1, "&&", show e2]
  show (Or  e1 e2) = parens [show e1, "||", show e2]
  show (Not e)     = parens ["!", show e]
  show (Any es)    = parens ["any", parens (show <$> es)]
  show (All es)    = parens ["all", parens (show <$> es)]

parens :: [[Char]] -> [Char]
parens s = '(' : (concat $ intersperse " " s) ++ ")"

-- | Predicate combinators
and, or :: BoolOp a -> BoolOp a -> BoolOp a
and = And
or  = Or

-- |
not :: BoolOp a -> BoolOp a
not = Not