module Data.Layer.Cover where
import Prelude
import Control.Lens
import Control.Monad
import Control.Monad.Fix
import Data.Construction
import Data.Convert
import Data.Layer
newtype Cover a = Cover a deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
type instance Unlayered (Cover a) = a
type family Uncovered a where Uncovered (Cover a) = a
Uncovered a = Uncovered (Unlayered a)
instance Layered (Cover a)
instance Rewrapped (Cover a) (Cover a')
instance Wrapped (Cover a) where
type Unwrapped (Cover a) = a
_Wrapped' = iso (\(Cover a) -> a) Cover
instance Castable a a' => Castable (Cover a) (Cover a') where cast = _Wrapped %~ cast
instance Convertible a a' => Convertible (Cover a) (Cover a') where convert = _Wrapped %~ convert
class Covered a where covered :: Lens' a (Uncovered a)
instance ( Layered a
, Covered (Unlayered a)
, Uncovered a ~ Uncovered (Unlayered a)
) => Covered a where covered = layered . covered
instance Covered (Cover a) where covered = _Wrapped'
uncover :: Covered a => a -> Uncovered a
uncover = view covered
class CoveredM m a where viewCoveredM :: a -> m (Uncovered a)
setCoveredM :: Uncovered a -> a -> m a
instance ( Monad m
, LayeredM m a
, CoveredM m (Unlayered a)
, Uncovered a ~ Uncovered (Unlayered a)
) => CoveredM m a where viewCoveredM = viewLayeredM >=> viewCoveredM
setCoveredM = withLayeredM . setCoveredM
instance Monad m => CoveredM m (Cover a) where viewCoveredM = return . uncover
setCoveredM v = return . set covered v
class CoverConstructor m a where constructCover :: Uncovered a -> m a
instance ( CoverConstructor m (Unlayered a)
, Uncovered a ~ Uncovered (Unlayered a)
, LayerConstructor m a
, Monad m ) => CoverConstructor m a where constructCover = constructCover >=> constructLayer
instance Monad m => CoverConstructor m (Cover a) where constructCover = return . Cover
class CoverConstructorFix m a where constructCoverFix :: Uncovered a -> m a
instance ( CoverConstructorFix m (Unlayered a)
, Uncovered a ~ Uncovered (Unlayered a)
, LayerConstructor m a
, MonadFix m ) => CoverConstructorFix m a where
constructCoverFix base = mdo
out <- constructLayer l
l <- constructCoverFix base
return out
instance Monad m => CoverConstructorFix m (Cover a) where constructCoverFix = return . Cover