Lens.hs

{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE DeriveFunctor #-}

module Hans.Lens (

    -- * Lenses
    Lens, Lens',
    lens,

    -- ** Getters
    Getting,
    Getter,
    view,
    to,

    -- ** Setters
    ASetter, ASetter',
    set,
    over,
    modify,

    -- * Utility Lenses
    bit,
    byte,

  ) where

import qualified Control.Applicative as A
import qualified Data.Bits as B
import           Data.Word (Word8)
import           MonadLib (Id,runId)


-- Lenses ----------------------------------------------------------------------

-- | General lenses that allow for the type of the inner field to change.
type Lens s t a b = forall f. Functor f => (a -> f b) -> (s -> f t)

-- | Lenses that don't change type.
type Lens' s a = Lens s s a a

lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens get upd = \ f s -> upd s `fmap` f (get s)
{-# INLINE lens #-}


-- Getters ---------------------------------------------------------------------

type Getting r s a = (a -> Const r a) -> (s -> Const r s)

type Getter s a = forall r. Getting r s a

newtype Const r a = Const { runConst :: r } deriving Functor

-- | This is just a handy way of not exposing a Contrafunctor class, as we only
-- really need it for the definition of `to`.
castConst' :: (b -> a) -> Const r a -> Const r b
castConst' _ (Const r) = Const r
{-# INLINE castConst' #-}

-- NOTE: the @(s -> a)@ part could be generalized to @ReaderM m s@.
view :: Getting a s a -> s -> a
view l = \ s -> runConst (l Const s)
{-# INLINE view #-}

to :: (s -> a) -> Getting r s a
to f = \ l s -> castConst' f (l (f s))
{-# INLINE to #-}


-- Setters ---------------------------------------------------------------------

type ASetter s t a b = (a -> Id b) -> (s -> Id t)

type ASetter' s a = ASetter s s a a

set :: Lens s t a b -> b -> s -> t
set l b = \ s -> runId (l (\ _ -> A.pure b) s)
{-# INLINE set #-}

over :: ASetter s t a b -> (a -> b) -> (s -> t)
over l f = \ s -> runId (l (A.pure . f) s)
{-# INLINE over #-}

newtype Modify r a = Modify { runModify :: (a,r) }

instance Functor (Modify r) where
  fmap f = \ (Modify (a,r)) -> Modify (f a, r)
  {-# INLINE fmap #-}

modify :: Lens s t a b -> (a -> (b,r)) -> (s -> (t,r))
modify l f = \ s -> runModify (l (\ a -> Modify (f a)) s)
{-# INLINE modify #-}


-- Utility Lenses --------------------------------------------------------------

-- NOTE: successive uses of 'bit' with 'set' will cause terms like this to build
-- up:
--
-- > or# (or# .. (or# val (__word m1)) .. (__word mi)) (__word mj)
--
-- This can be fixed with a rewrite rule that associates all uses of or# to the
-- right, but this seems like it might block other simplifications that would
-- have fired if it was associated to the left.
--
-- The real problem here is that GHC isn't reorganizing the uses of or# to group
-- together constants, which would allow only one final use of or# after
-- simplification.
bit :: B.Bits a => Int -> Lens' a Bool
bit n = lens get upd
  where
  get a       = B.testBit a n

  upd a True  = B.setBit   a n
  upd a False = B.clearBit a n


byte :: (Integral a, B.Bits a) => Int -> Lens' a Word8
byte n = lens get upd
  where
  sh      = n * 8

  get a   = fromIntegral (a `B.shiftR` sh)

  upd a b = a B..|. (fromIntegral b `B.shiftL` sh)