HasLens

HasLens.hs

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeInType            #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}

import           Data.Kind (Type)
import           GHC.Prim

-- Core
--------------------

type Optic f s t a b = (a -> f b) -> s -> f t
type Lens s t a b = forall f. Functor f => Optic f s t a b
type Lens' s a = Lens s s a a

class s ~ Recreate x s s => HasLens (x :: k) s where
    type Get x s
    -- | Return 't', but in "WHNF" (don't know whether this term applies at the type level)
    -- and without pattern matching on 't'. This way we show GHC that 't' is of a particular shape
    -- (the one of 's') which helps type inference a lot.
    -- The symmetric constraints ensure that the shape of 't' is determined by 's' and
    -- vice versa, which also helps type inference.
    type Recreate x s t
    lens
        :: ( HasLens x t
           , a ~ Get x s, b ~ Get x t
           , t ~ Recreate x s t, s ~ Recreate x t s
           )
        => Proxy# x -> Lens s t a b

-- Tuple examples
--------------------

instance HasLens "_1" (a, b) where
    type Get "_1" (a, b) = a
    type Recreate "_1" (a, b) t = (Get "_1" t, b)
    lens _ f (x, y) = (, y) <$> f x

instance HasLens "_1" (a, b, c) where
    type Get "_1" (a, b, c) = a
    type Recreate "_1" (a, b, c) t = (Get "_1" t, b, c)
    lens _ f (x, y, z) = (, y, z) <$> f x

-- Composition works.
comp :: (HasLens "_1" s, HasLens "_1" (Get "_1" s)) => Lens' s (Get "_1" (Get "_1" s))
comp = lens @"_1" proxy# . lens @"_1" proxy#

-- And instantiates correctly.
inst :: Lens' ((a, b), c, d) a
inst = comp

-- The phantom arguments problem (https://gitlab.haskell.org/ghc/ghc/wikis/records/overloaded-record-fields/design#type-changing-update-phantom-arguments) is solved:
--------------------

type family Arg1R z :: k where
    Arg1R (f x) = x

type family Arg2R z :: k where
    Arg2R (f x y) = x

data Ph (a :: Type) (b :: [Bool]) = Ph { foo :: Int }

instance HasLens "foo" (Ph a b) where
    type Get "foo" (Ph a b) = Int
    type Recreate "foo" (Ph a b) t = Ph (Arg2R t) (Arg1R t)
    lens _ f (Ph i) = Ph <$> f i

ph :: Lens (Ph a b) (Ph c d) Int Int
ph = lens @"foo" proxy#

-- The type families problem (https://gitlab.haskell.org/ghc/ghc/wikis/records/overloaded-record-fields/design#type-changing-update-type-families) is solved:
--------------------

type family Goo (a :: Type)
data Tf (a :: Type) = Tf { bar :: Goo a }

instance HasLens "bar" (Tf a) where
    type Get "bar" (Tf a) = Goo a
    type Recreate "bar" (Tf a) t = Tf (Arg1R t)
    lens _ f (Tf x) = Tf <$> f x

tf :: Lens (Tf a) (Tf b) (Goo a) (Goo b)
tf = lens @"bar" proxy#