{- Copyright 2010 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with SCC. If not, see <http://www.gnu.org/licenses/>. -} -- | This module defines the Ticker cofunctor, useful for 'ticking off' a prefix of the input. -- module Data.Functor.Contravariant.Ticker ( -- * The Ticker type Ticker(Ticker), -- * Using a Ticker splitTicked, Contravariant(..), -- * Ticker constructors tickNone, tickOne, tickCount, tickPrefixOf, tickWhilePrefixOf, tickWhile, tickUntil, tickAll, -- * Ticker combinators andThen, and, or ) where import Prelude hiding (and, or) import Control.Monad (liftM2) import Data.Functor.Contravariant (Contravariant(contramap)) -- | This is a contra-functor data type for selecting a prefix of an input stream. If the next input item is acceptable, -- the ticker function returns the ticker for the rest of the stream. If not, it returns 'Nothing'. newtype Ticker x = Ticker (x -> Maybe (Ticker x)) instance Contravariant Ticker where contramap f (Ticker g) = Ticker (fmap (contramap f) . g . f) -- | Extracts a list prefix accepted by the 'Ticker' argument. Returns the modified ticker, the prefix, and the -- remainder of the list. splitTicked :: Ticker x -> [x] -> (Ticker x, [x], [x]) splitTicked t [] = (t, [], []) splitTicked t@(Ticker f) l@(x:rest) = maybe (t, [], l) (\t' -> let (t'', xs1, xs2) = splitTicked t' rest in (t'', x:xs1, xs2)) (f x) -- | A ticker that accepts no input. tickNone :: Ticker x tickNone = Ticker (const Nothing) -- | A ticker that accepts a single input item. tickOne :: Ticker x tickOne = Ticker (const $ Just tickNone) -- | A ticker that accepts a given number of input items. tickCount :: Int -> Ticker x tickCount n | n > 0 = Ticker (const $ Just $ tickCount (pred n)) | otherwise = tickNone -- | A ticker that accepts the longest prefix of input that matches a prefix of the argument list. tickPrefixOf :: Eq x => [x] -> Ticker x tickPrefixOf list = tickWhilePrefixOf (map (==) list) -- | A ticker that accepts a prefix of input as long as each item satisfies the predicate at the same position in the -- argument list. The length of the predicate list thus determines the maximum number of acepted values. tickWhilePrefixOf :: [x -> Bool] -> Ticker x tickWhilePrefixOf (p : rest) = Ticker $ \x-> if p x then Just (tickWhilePrefixOf rest) else Nothing tickWhilePrefixOf [] = tickNone -- | A ticker that accepts all input as long as it matches the given predicate. tickWhile :: (x -> Bool) -> Ticker x tickWhile p = t where t = Ticker (\x-> if p x then Just t else Nothing) -- | A ticker that accepts all input items until one matches the given predicate. tickUntil :: (x -> Bool) -> Ticker x tickUntil p = t where t = Ticker (\x-> if p x then Nothing else Just t) -- | A ticker that accepts all input. tickAll :: Ticker x tickAll = Ticker (const $ Just tickAll) -- | Sequential concatenation ticker combinator: when the first argument ticker stops ticking, the second takes over. andThen :: Ticker x -> Ticker x -> Ticker x Ticker t1 `andThen` t@(Ticker t2) = Ticker (\x-> maybe (t2 x) (Just . (`andThen` t)) (t1 x)) -- | Parallel conjunction ticker combinator: the result keeps ticking as long as both arguments do. and :: Ticker x -> Ticker x -> Ticker x Ticker t1 `and` Ticker t2 = Ticker (\x-> liftM2 and (t1 x) (t2 x)) -- | Parallel choice ticker combinator: the result keeps ticking as long as any of the arguments does. or :: Ticker x -> Ticker x -> Ticker x Ticker t1 `or` Ticker t2 = Ticker (\x-> case (t1 x, t2 x) of (Nothing, Nothing) -> Nothing (Nothing, t'@Just{}) -> t' (t'@Just{}, Nothing) -> t' (Just t1', Just t2') -> Just (t1' `or` t2'))