-- 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.Monad       (liftM2)
import Data.Maybe          (fromJust, isJust)

-- Funky instances for this type are marked with **FUNKY**
newtype Identity a = Id a

class Unwrappable  w where unwrap  :: w a -> a
class Boolable     b where toBool  :: b -> Bool

instance Unwrappable  Maybe    where unwrap :: forall a. Maybe a -> a
unwrap = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust
instance Boolable    (Maybe a) where toBool :: Maybe a -> Bool
toBool = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust

instance Unwrappable Identity       where unwrap :: forall a. Identity a -> a
unwrap (Id a
a) = a
a
instance Boolable   (Identity Bool) where toBool :: Identity Bool -> Bool
toBool = Identity Bool -> Bool
forall a. Identity a -> a
forall (w :: * -> *) a. Unwrappable w => w a -> a
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

instance Unionable    Maybe a  where
   unionVals :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
unionVals a -> a -> a
f (Just a
a) (Just a
b) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> a -> a
f a
a a
b)
   unionVals a -> a -> a
_ Maybe a
Nothing  Maybe a
mb       = Maybe a
mb
   unionVals a -> a -> a
_ Maybe a
ma       Maybe a
_        = Maybe a
ma

   unionVals' :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
unionVals' a -> a -> a
f (Just a
a) (Just a
b) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$! a -> a -> a
f a
a a
b
   unionVals' a -> a -> a
_ Maybe a
Nothing  Maybe a
mb       = Maybe a
mb
   unionVals' a -> a -> a
_ Maybe a
ma       Maybe a
_        = Maybe a
ma

instance Differentiable Maybe a b where
   differenceVals :: (a -> b -> Maybe a) -> Maybe a -> Maybe b -> Maybe a
differenceVals a -> b -> Maybe a
f (Just a
a) (Just b
b) = a -> b -> Maybe a
f a
a b
b
   differenceVals a -> b -> Maybe a
_ Maybe a
ma       Maybe b
_        = Maybe a
ma

instance Intersectable Maybe a b c where
   intersectionVals :: (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
intersectionVals = (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2

   intersectionVals' :: (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
intersectionVals' a -> b -> c
f (Just a
a) (Just b
b) = c -> Maybe c
forall a. a -> Maybe a
Just (c -> Maybe c) -> c -> Maybe c
forall a b. (a -> b) -> a -> b
$! a -> b -> c
f a
a b
b
   intersectionVals' a -> b -> c
_ Maybe a
_        Maybe b
_        = Maybe c
forall a. Maybe a
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 :: (Bool -> Bool -> Bool)
-> Identity Bool -> Identity Bool -> Identity Bool
unionVals  Bool -> Bool -> Bool
_ (Id Bool
a) (Id Bool
b) = Bool -> Identity Bool
forall a. a -> Identity a
Id(Bool -> Identity Bool) -> Bool -> Identity Bool
forall a b. (a -> b) -> a -> b
$ Bool
a Bool -> Bool -> Bool
|| Bool
b
   unionVals' :: (Bool -> Bool -> Bool)
-> Identity Bool -> Identity Bool -> Identity Bool
unionVals' = [Char]
-> (Bool -> Bool -> Bool)
-> Identity Bool
-> Identity Bool
-> Identity Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Data.ListTrie.Base.Classes.unionVals' :: internal error"

-- **FUNKY**
instance Differentiable Identity Bool Bool where
   differenceVals :: (Bool -> Bool -> Maybe Bool)
-> Identity Bool -> Identity Bool -> Identity Bool
differenceVals Bool -> Bool -> Maybe Bool
_ (Id Bool
a) (Id Bool
b) = Bool -> Identity Bool
forall a. a -> Identity a
Id(Bool -> Identity Bool) -> Bool -> Identity Bool
forall a b. (a -> b) -> a -> b
$ Bool
a Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
b

-- **FUNKY**
instance Intersectable Identity Bool Bool Bool where
   intersectionVals :: (Bool -> Bool -> Bool)
-> Identity Bool -> Identity Bool -> Identity Bool
intersectionVals Bool -> Bool -> Bool
_ (Id Bool
a) (Id Bool
b) = Bool -> Identity Bool
forall a. a -> Identity a
Id(Bool -> Identity Bool) -> Bool -> Identity Bool
forall a b. (a -> b) -> a -> b
$ Bool
a Bool -> Bool -> Bool
&& Bool
b
   intersectionVals' :: (Bool -> Bool -> Bool)
-> Identity Bool -> Identity Bool -> Identity Bool
intersectionVals' =
      [Char]
-> (Bool -> Bool -> Bool)
-> Identity Bool
-> Identity Bool
-> Identity Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Data.ListTrie.Base.Classes.intersectionVals' :: internal error"

class Applicative a => Alt a x where
   altEmpty :: a x
   (<|>) :: a x -> a x -> a x

instance Functor Identity where
   fmap :: forall a b. (a -> b) -> Identity a -> Identity b
fmap a -> b
f (Id a
a) = b -> Identity b
forall a. a -> Identity a
Id (a -> b
f a
a)

instance Applicative Identity where
   pure :: forall a. a -> Identity a
pure = a -> Identity a
forall a. a -> Identity a
Id
   Id a -> b
f <*> :: forall a b. Identity (a -> b) -> Identity a -> Identity b
<*> Id a
a = b -> Identity b
forall a. a -> Identity a
Id (a -> b
f a
a)

instance Alt Maybe a where
   altEmpty :: Maybe a
altEmpty = Maybe a
forall a. Maybe a
forall (f :: * -> *) a. Alternative f => f a
A.empty
   <|> :: Maybe a -> Maybe a -> Maybe a
(<|>) = Maybe a -> Maybe a -> Maybe a
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(A.<|>)

instance Alt Identity Bool where
   altEmpty :: Identity Bool
altEmpty = Bool -> Identity Bool
forall a. a -> Identity a
Id Bool
False
   Id Bool
a <|> :: Identity Bool -> Identity Bool -> Identity Bool
<|> Id Bool
b = Bool -> Identity Bool
forall a. a -> Identity a
Id (Bool
a Bool -> Bool -> Bool
|| Bool
b)

fmap', (<$!>) :: (Boolable (f a), Unwrappable f, Alt f b)
              => (a -> b) -> f a -> f b
fmap' :: forall (f :: * -> *) a b.
(Boolable (f a), Unwrappable f, Alt f b) =>
(a -> b) -> f a -> f b
fmap' a -> b
f f a
ax = if f a -> Bool
forall b. Boolable b => b -> Bool
toBool f a
ax
                then b -> f b
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> f b) -> b -> f b
forall a b. (a -> b) -> a -> b
$! a -> b
f (f a -> a
forall a. f a -> a
forall (w :: * -> *) a. Unwrappable w => w a -> a
unwrap f a
ax)
                else f b
forall (a :: * -> *) x. Alt a x => a x
altEmpty

<$!> :: forall (f :: * -> *) a b.
(Boolable (f a), Unwrappable f, Alt f b) =>
(a -> b) -> f a -> f b
(<$!>) = (a -> b) -> f a -> f b
forall (f :: * -> *) a b.
(Boolable (f a), Unwrappable f, Alt f b) =>
(a -> b) -> f a -> f b
fmap'