{-# OPTIONS -XMultiParamTypeClasses -XFunctionalDependencies  -XFlexibleInstances #-}

module Data.Function.Selector
where

import Prelude          hiding (id,(.))

import Control.Arrow
import Control.Category

infixr 3 .&&&.

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

-- | A Selector is a pair of an access function and a modifying function
-- for reading and updating parts of a composite type

data Selector s a       = S { forall s a. Selector s a -> s -> a
getS :: s -> a
                            , forall s a. Selector s a -> a -> s -> s
setS :: a -> s -> s
                            }

chgS                    :: Selector s a -> (a -> a) -> (s -> s)
chgS :: forall s a. Selector s a -> (a -> a) -> s -> s
chgS Selector s a
sel a -> a
f s
s            = Selector s a -> a -> s -> s
forall s a. Selector s a -> a -> s -> s
setS Selector s a
sel a
x s
s
                          where
                          x :: a
x = a -> a
f (a -> a) -> (s -> a) -> s -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Selector s a -> s -> a
forall s a. Selector s a -> s -> a
getS Selector s a
sel (s -> a) -> s -> a
forall a b. (a -> b) -> a -> b
$ s
s

chgM                    :: (Monad m) => Selector s a -> (a -> m a) -> (s -> m s)
chgM :: forall (m :: * -> *) s a.
Monad m =>
Selector s a -> (a -> m a) -> s -> m s
chgM Selector s a
sel a -> m a
f s
s            = do
                          a
y <- a -> m a
f a
x
                          s -> m s
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (s -> m s) -> s -> m s
forall a b. (a -> b) -> a -> b
$ Selector s a -> a -> s -> s
forall s a. Selector s a -> a -> s -> s
setS Selector s a
sel a
y s
s
                          where
                          x :: a
x = Selector s a -> s -> a
forall s a. Selector s a -> s -> a
getS Selector s a
sel (s -> a) -> s -> a
forall a b. (a -> b) -> a -> b
$ s
s

-- | Alias for constructor S

mkSelector              :: (s -> a) -> (a -> s -> s) -> Selector s a
mkSelector :: forall s a. (s -> a) -> (a -> s -> s) -> Selector s a
mkSelector              = (s -> a) -> (a -> s -> s) -> Selector s a
forall s a. (s -> a) -> (a -> s -> s) -> Selector s a
S

-- (.), (>>>), (<<<)

instance Category Selector where
    id :: forall a. Selector a a
id                          = S { getS :: a -> a
getS = a -> a
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
                                    , setS :: a -> a -> a
setS = a -> a -> a
forall a b. a -> b -> a
const
                                    }
    (S b -> c
g2 c -> b -> b
s2) . :: forall b c a. Selector b c -> Selector a b -> Selector a c
. (S a -> b
g1 b -> a -> a
s1)       = S { getS :: a -> c
getS = b -> c
g2 (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> b
g1
                                    , setS :: c -> a -> a
setS = \ c
x a
s ->
                                            let x1 :: b
x1  = a -> b
g1 a
s    in
                                            let x1' :: b
x1' = c -> b -> b
s2 c
x b
x1 in
                                            b -> a -> a
s1 b
x1' a
s
                                    }

idS                             :: Selector s s
idS :: forall a. Selector a a
idS                             = Selector s s
forall a. Selector a a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

(.&&&.)                         :: Selector s a -> Selector s b -> Selector s (a, b)
.&&&. :: forall s a b. Selector s a -> Selector s b -> Selector s (a, b)
(.&&&.) (S s -> a
g1 a -> s -> s
s1) (S s -> b
g2 b -> s -> s
s2)     = S { getS :: s -> (a, b)
getS = s -> a
g1 (s -> a) -> (s -> b) -> s -> (a, b)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& s -> b
g2
                                    , setS :: (a, b) -> s -> s
setS = \ (a
x, b
y) -> b -> s -> s
s2 b
y (s -> s) -> (s -> s) -> s -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> s -> s
s1 a
x
                                    }

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

-- | Selectors for pairs and 3-tuples: comp1, comp2, comp3,
-- this can be extended to n-tuples

class Comp1 s a | s -> a where  comp1   :: Selector s a
class Comp2 s a | s -> a where  comp2   :: Selector s a
class Comp3 s a | s -> a where  comp3   :: Selector s a


instance Comp1 (a, b) a where           comp1 :: Selector (a, b) a
comp1   = S { getS :: (a, b) -> a
getS = (a, b) -> a
forall a b. (a, b) -> a
fst
                                                    , setS :: a -> (a, b) -> (a, b)
setS = \ a
x1 (a
_, b
x2) -> (a
x1, b
x2)
                                                    }

instance Comp2 (a, b) b where           comp2 :: Selector (a, b) b
comp2   = S { getS :: (a, b) -> b
getS = (a, b) -> b
forall a b. (a, b) -> b
snd
                                                    , setS :: b -> (a, b) -> (a, b)
setS = \ b
x2 (a
x1, b
_) -> (a
x1, b
x2)
                                                    }

instance Comp1 (a, b, c) a where        comp1 :: Selector (a, b, c) a
comp1   = S { getS :: (a, b, c) -> a
getS = \ (a
x1, b
_, c
_) -> a
x1
                                                    , setS :: a -> (a, b, c) -> (a, b, c)
setS = \ a
x1 (a
_, b
x2, c
x3) -> (a
x1, b
x2, c
x3)
                                                    }

instance Comp2 (a, b, c) b where        comp2 :: Selector (a, b, c) b
comp2   = S { getS :: (a, b, c) -> b
getS = \ (a
_, b
x2, c
_) -> b
x2
                                                    , setS :: b -> (a, b, c) -> (a, b, c)
setS = \ b
x2 (a
x1, b
_, c
x3) -> (a
x1, b
x2, c
x3)
                                                    }

instance Comp3 (a, b, c) c where        comp3 :: Selector (a, b, c) c
comp3   = S { getS :: (a, b, c) -> c
getS = \ (a
_, b
_, c
x3) -> c
x3
                                                    , setS :: c -> (a, b, c) -> (a, b, c)
setS = \ c
x3 (a
x1, b
x2, c
_) -> (a
x1, b
x2, c
x3)
                                                    }

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