Chatter.hs

{-# OPTIONS -Wall -fno-warn-orphans #-}
{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving #-}

----------------------------------------------------------------------
-- |
-- Module      :  Data.Bot.Chatter
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Bots who can produce any number of reactions to each input.  See
-- <http://conal.net/blog/tag/bot/> for explanation and @Examples.Chatter@
-- for examples.  Builds on "Data.Bot.Mutant".

----------------------------------------------------------------------

module Data.Bot.Chatter
  ( ChatterBot(..), (:->)
  , justC, filterC, scanlC, accumC
  ) where

import Control.Arrow hiding (pure)
import Control.Applicative
import Data.Monoid
import Data.Maybe

import Data.Bot.Mutant


-- | Chatter-bots.  Can have any number of outputs per input.  'mappend'
-- appends outputs.
newtype ChatterBot i o =
  Chatter { unChatter :: MutantBot i [o] } deriving Monoid

instance Arrow ChatterBot where
  arr h = Chatter (arr (pure . h))
  Chatter ab >>> Chatter bc = Chatter (ab >>> concatMB bc)
  first (Chatter f) = Chatter $
    first f >>> arr (\ (bs,c) -> [(b,c) | b <- bs])
    -- first f >>> arr (\ (bs,c) -> fmap (flip (,) c) bs)

-- Boilerplate Functor & Applicative for Arrow instance

instance Functor (ChatterBot i) where fmap = (^<<)

instance Applicative (ChatterBot i) where
  pure x        = arr (const x)
  fbot <*> xbot = fbot &&& xbot >>> arr (uncurry ($))

-- TODO: generalize from lists.

-- | Friendly synonym for 'ChatterBot'
type (:->) = ChatterBot


---- Operations

-- | Each 'Nothing' gets dropped, and the 'Just' constructors are stripped
-- from what's left.
justC :: Maybe a :-> a
justC = Chatter (arr maybeToList)

-- | Pass through whatever satisfies a given predicate 
filterC :: (a -> Bool) -> a :-> a
filterC test = f ^>> justC
 where
   f a | test a    = Just a
       | otherwise = Nothing


-- | Chatter-bot analog to list 'scanl', but without initial @b@
scanlC :: (b -> a -> b) -> b -> (a :-> b)
scanlC = (fmap.fmap) (Chatter . fmap pure) scanlM

-- scanlC f b = Chatter $ pure <$> scanlM f b

-- | Cumulative function applications.  @accumC == scanlC (flip ($))@
accumC :: a -> ((a->a) :-> a)
accumC = scanlC (flip ($))