{-# LANGUAGE TypeFamilies #-}

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

-- Copyright 2018, Ideas project team. This file is distributed under the

-- terms of the Apache License 2.0. For more information, see the files

-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.

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

-- |

-- Maintainer  :  bastiaan.heeren@ou.nl

-- Stability   :  provisional

-- Portability :  portable (depends on ghc)

--

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



module Ideas.Common.Traversal.Utils

   ( -- * Update type class

     Update(..), current, change, replace, changeM, changeG

     -- * Focus type class

   , Focus(..), liftFocus, unliftFocus

     -- * Wrapper type class

   , Wrapper(..), liftWrapper, unliftWrapper, mapWrapper

     -- * Mirror

   , Mirror, makeMirror

     -- * Utility functions

   , (>|<), safe, fixp, fixpl, mplus, (>=>)

   ) where



import Control.Monad

import Data.Maybe



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

-- Update type class



class Update f where

   update  :: f a -> (a, a -> f a)



current :: Update f => f a -> a

current  = fst . update



change  :: Update f => (a -> a) -> f a -> f a

change f = (\(x, g) -> g (f x)) . update



replace :: Update f => a -> f a -> f a

replace  = change . const



changeM :: Update f => (a -> Maybe a) -> f a -> Maybe (f a)

changeM = changeG



changeG :: (Update f, Monad g) => (a -> g a) -> f a -> g (f a)

changeG f a = (`replace` a) <$> f (current a)



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

-- Focus type class



class Focus a where

   type Unfocus a

   focus   :: Unfocus a -> a

   focusM  :: Unfocus a -> Maybe a

   unfocus :: a -> Unfocus a

   -- default definitions

   focus  = fromMaybe (error "no focus") . focusM

   focusM = Just . focus



liftFocus :: Focus a => (Unfocus a -> Maybe (Unfocus a)) -> a -> Maybe a

liftFocus f = fmap focus . f . unfocus



unliftFocus :: Focus a => (a -> Maybe a) -> Unfocus a -> Maybe (Unfocus a)

unliftFocus f = fmap unfocus . f . focus



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

-- Wrapper type class



class Wrapper f where

   wrap   :: a -> f a

   unwrap :: f a -> a



liftWrapper :: (Monad m, Wrapper f) => (a -> m a) -> f a -> m (f a)

liftWrapper f = fmap wrap . f . unwrap



unliftWrapper :: (Monad m, Wrapper f) => (f a -> m (f a)) -> a -> m a

unliftWrapper f = fmap unwrap . f . wrap



mapWrapper :: Wrapper f => (a -> a) -> f a -> f a

mapWrapper f = wrap . f . unwrap



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

-- Mirror



newtype Mirror a = Mirror { fromMirror :: a }

   deriving (Show, Eq)



instance Wrapper Mirror where

   wrap   = Mirror

   unwrap = fromMirror



makeMirror :: a -> Mirror a

makeMirror = wrap



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

-- Utility functions



infixr 0 >|<



(>|<) :: (a -> Maybe a) -> (a -> Maybe a) -> a -> Maybe a

(f >|< g) a = f a `mplus` g a



safe :: (a -> Maybe a) -> a -> a

safe f a = fromMaybe a (f a)



fixp :: (a -> Maybe a) -> a -> a

fixp f = last . fixpl f



fixpl :: (a -> Maybe a) -> a -> [a]

fixpl f a = a : maybe [] (fixpl f) (f a)