{-# LANGUAGE DeriveGeneric #-}
module Within (
  Within(..)
, fromWithin
, toWithin
, within
, asWithin
, whatLiesWithin
, mapWithin
, mapWithinT
, moveWithin
, moveWithinT
, blinkWithin
, moveAndMapT
, blinkAndMapT
) where

import Control.Monad.Catch
import Data.Typeable
import GHC.Generics
import Path

newtype Within a t = Within (Path a Dir, Path Rel t)
  deriving (Typeable, Generic, Eq, Show)

fromWithin :: Within a t -> Path a t
fromWithin (Within (x,y)) = x </> y

toWithin :: Path a Dir -> Path Rel t -> Within a t
toWithin = flip within

within :: Path Rel t -> Path a Dir -> Within a t
within y x = Within (x,y)

asWithin :: MonadThrow m => Path a t -> Path a Dir -> m (Within a t)
asWithin x y = stripProperPrefix y x >>= \z -> return (Within (y, z))

whatLiesWithin :: Within a t -> Path Rel t
whatLiesWithin (Within (_,y)) = y

mapWithin :: (Path Rel s -> Path Rel t) -> Within a s -> Within a t
mapWithin f (Within (x,y)) = Within (x, f y)

mapWithinT :: MonadThrow m => (Path Rel s -> m (Path Rel t)) -> Within a s -> m (Within a t)
mapWithinT f (Within (x,y)) = f y >>= \z -> return (Within (x, z))

blinkWithin :: Path b Dir -> Within a t -> Within b t
blinkWithin = moveWithin . const

moveWithin :: (Path a Dir -> Path b Dir) -> Within a t -> Within b t
moveWithin f (Within (x,y)) = Within (f x, y)

moveWithinT :: MonadThrow m => (Path a Dir -> m (Path b Dir)) -> Within a t -> m (Within b t)
moveWithinT f (Within (x,y)) = f x >>= \z -> return (Within (z,y))

blinkAndMapT :: MonadThrow m => Path b Dir -> (Path Rel s -> m (Path Rel t)) -> Within a s -> m (Within b t)
blinkAndMapT k g (Within (_,y)) = do
  y' <- g y
  return $ Within (k, y')

moveAndMapT :: MonadThrow m => (Path a Dir -> m (Path b Dir)) -> (Path Rel s -> m (Path Rel t)) -> Within a s -> m (Within b t)
moveAndMapT f g (Within (x,y)) = do
  x' <- f x
  y' <- g y
  return $ Within (x', y')