-- File created: 2008-12-27 20:53:49 -- Various type classes to make both (Maybe a) and (Identity Bool) work -- wherever we need them. {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies , FlexibleInstances #-} module Data.ListTrie.Base.Classes where import qualified Control.Applicative as A import Control.Applicative (Applicative(..)) import Control.Monad (liftM2) import Data.Functor.Identity import Data.Maybe (fromJust, isJust) class Unwrappable w where unwrap :: w a -> a class Boolable b where toBool :: b -> Bool instance Unwrappable Maybe where unwrap = fromJust instance Boolable (Maybe a) where toBool = isJust instance Unwrappable Identity where unwrap (Identity a) = a instance Boolable (Identity Bool) where toBool = unwrap class Unionable v a where unionVals :: (a -> a -> a) -> v a -> v a -> v a unionVals' :: (a -> a -> a) -> v a -> v a -> v a class Differentiable v a b where differenceVals :: (a -> b -> Maybe a) -> v a -> v b -> v a class Intersectable v a b c where intersectionVals :: (a -> b -> c) -> v a -> v b -> v c intersectionVals' :: (a -> b -> c) -> v a -> v b -> v c class Foldable v => ExtFoldable v where head :: v a -> a cons :: a -> v a -> v a snoc :: v a -> a -> v a instance Unionable Maybe a where unionVals f (Just a) (Just b) = Just (f a b) unionVals _ Nothing mb = mb unionVals _ ma _ = ma unionVals' f (Just a) (Just b) = Just $! f a b unionVals' _ Nothing mb = mb unionVals' _ ma _ = ma instance Differentiable Maybe a b where differenceVals f (Just a) (Just b) = f a b differenceVals _ ma _ = ma instance Intersectable Maybe a b c where intersectionVals = liftM2 intersectionVals' f (Just a) (Just b) = Just $! f a b intersectionVals' _ _ _ = Nothing -- The other option with the following three would have been to just call f -- (and, in the case of Differentiable, fromJust) and trust that it's correct. -- I think this way is safer. Bottoms are passed to Base.unionWith etc. -- **FUNKY** instance Unionable Identity Bool where unionVals _ (Identity a) (Identity b) = Identity $ a || b unionVals' = error "Data.ListTrie.Base.Classes.unionVals' :: internal error" -- **FUNKY** instance Differentiable Identity Bool Bool where differenceVals _ (Identity a) (Identity b) = Identity $ a && not b -- **FUNKY** instance Intersectable Identity Bool Bool Bool where intersectionVals _ (Identity a) (Identity b) = Identity $ a && b intersectionVals' = error "Data.ListTrie.Base.Classes.intersectionVals' :: internal error" class Applicative a => Alt a x where altEmpty :: a x (<|>) :: a x -> a x -> a x instance Alt Maybe a where altEmpty = A.empty (<|>) = (A.<|>) instance Alt Identity Bool where altEmpty = Identity False Identity a <|> Identity b = Identity (a || b) fmap', (<$!>) :: (Boolable (f a), Unwrappable f, Alt f b) => (a -> b) -> f a -> f b fmap' f ax = if toBool ax then pure $! f (unwrap ax) else altEmpty (<$!>) = fmap'