Higher-Kinded Data (https://reasonablypolymorphic.com/blog/higher-kinded-data/)

HKD.hs

{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}
module HKD where

-- Depends on: lens, one-liner, inspection-testing
import           Control.Applicative
import           Control.Lens          hiding (from, to)
import qualified Control.Lens          as L
import           Data.Functor.Identity
import           Generics.OneLiner
import           GHC.Generics
import           Test.Inspection
import           Text.Read             (readMaybe)

data Person f =
  Person { _name :: HKD f String
         , _age  :: HKD f Int
         }
  deriving (Generic)

{-
type instance Rep (Person f)
  = D1
      ('MetaData "Person" "HKD" "main" 'False)
      (C1
         ('MetaCons "Person" 'PrefixI 'True)
         (S1
            ('MetaSel
               ('Just "_name")
               'NoSourceUnpackedness
               'NoSourceStrictness
               'DecidedLazy)
            (Rec0 (HKD f String))
          :*: S1
                ('MetaSel
                   ('Just "_age")
                   'NoSourceUnpackedness
                   'NoSourceStrictness
                   'DecidedLazy)
                (Rec0 (HKD f Int))))
-}

deriving instance Show (Person Identity)
deriving instance Show (Person Maybe)

type family HKD f a where
  HKD Identity a = a
  HKD f a = f a

validate' :: Person Maybe -> Maybe (Person Identity)
validate' (Person name age) = Person <$> name <*> age
-- ^^^^^^ Structural boilerplate, we can do better:

--------------- SYB

-- Person Maybe -> Maybe (Person Identity)
-- i = Person Maybe
-- o = Person Identity
class GValidate i o where
  gvalidate :: i p -> Maybe (o p)

-- K1 is for "constant type".
-- In our Person is for example _name :: HKD f String
instance GValidate (K1 a (Maybe k)) (K1 a k) where
  gvalidate (K1 k)  = K1 <$> k
  {-# INLINE gvalidate #-}

instance (GValidate i o, GValidate i' o')
    => GValidate (i :*: i') (o :*: o') where
  gvalidate (l :*: r) = liftA2 (:*:) (gvalidate l) (gvalidate r)
  {-# INLINE gvalidate #-}

instance (GValidate i o, GValidate i' o')
    => GValidate (i :+: i') (o :+: o') where
  gvalidate (L1 l) = L1 <$> gvalidate l
  gvalidate (R1 r) = R1 <$> gvalidate r
  {-# INLINE gvalidate #-}

instance (GValidate i o)
    => (GValidate (M1 _a _b i) (M1 _a _b o)) where
  gvalidate (M1 x) = M1 <$> gvalidate x
  {-# INLINE gvalidate #-}

instance GValidate V1 V1 where
  gvalidate = undefined
  {-# INLINE gvalidate #-}

instance GValidate U1 U1 where
  gvalidate = undefined
  {-# INLINE gvalidate #-}

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

validate
  :: ( Generic (f Maybe)
     , Generic (f Identity)
     , GValidate (Rep (f Maybe)) (Rep (f Identity))
     )
  => f Maybe
  -> Maybe (f Identity)
validate = fmap to . gvalidate . from
{-# INLINE validate #-}

main :: IO ()
main = do
  putStrLn "What's your name?"
  name <- Just <$> getLine
  putStrLn "What's your age?"
  age <- readMaybe <$> getLine
  let maybePerson = Person name age
  case validate maybePerson of
    Nothing     -> putStrLn "Invalid Person"
    Just person -> putStrLn (show person)

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

-- Generating lenses

-- f ~ Lens' (Person Identity)
-- _name :: Lens' (Person Identity) String
-- _age :: Lens' (Person Identity) Int

-- We can't partially apply type-synonyms, we need to introduce a new type constructor:

data LensFor s a = LensFor { getLensFor :: Lens' s a }
-- type Lens' s a = Lens s s a a
-- type Lens s t a b = forall f. Functor f => (a -> f b) -> (s -> f t)

  {-
class GLenses i o where
  glenses :: i p -> o p
  -}

-- p mysterious existentialized type parameters "reserved for future use" by GHC.Generics
-- Recall that `i` is the incoming type for the transformation (not the original Person type)

-- Since lenses don't depend on a particular input we can drop `i p`.

-- Eventually, our lenses are going to depend on our "original" type ( the Person in our desired LensesFor (Person Identity),
-- we'll need another parameters in our typeclass to track that

  {-
class GLenses z i o where
  glenses :: o p
  -}

-- We ae going to need to do structural induction as we traverse our generic Rep.

-- The trick here is that in order to provide a lens, we're going to need to have a lens to give.
-- What type for Lens' ?
-- At the end of the day we want to provide Lens' (z Identity) a where a is the type of the field we're trying to get.

class GLenses z i o where
  glenses :: Lens' (z Identity) (i p) -> o p
-- ^^^^^ Magire said this is the hardest part and he is only sure about it
--       when he has worked through the implementation

-- Let's start with the base case K1
-- K1 corresponds to the end of our generic structural induction: K1 { unK1 :: c }
-- c ~ HKD f String in name

-- So if we have an a in a K1, we weant to instead produce a LensFor (z Identity) a wrapped in the same.

instance GLenses z (K1 _x a)
                   (K1 _x (LensFor (z Identity) a)) where
  glenses l = K1
            $ LensFor
            $ \f -> l $ fmap K1 . f . unK1 -- Lens' (z Identity) (K1 _x a) -> Lens' (z Identity) a
  {-# INLINE glenses #-}

-- l :: (K1 -> f K1) -> z Identity -> f (zIdentity)
-- op (what we want): (K1 -> f K1) -> z Identity -> f (zIdentity)
--                        l              fmap K1 . f . unK1


-- We are wrapping into K1 to get it back to our HKD representation later.

-- Now we need to transform the lens we got into a new lens that focuses down through our generic
-- structure as we traverse it.

instance (GLenses z i o)
    => GLenses z (M1 _a _b i) (M1 _a _b o) where
  glenses l = M1 $ glenses $ \f -> l $ fmap M1 . f . unM1
  {-# INLINE glenses #-}

instance (GLenses z i o, GLenses z i' o')
    => GLenses z (i :*: i') (o :*: o') where
  glenses l = glenses (\f -> l (\(a :*: b) -> fmap (:*: b) $ f a))
          :*: glenses (\f -> l (\(a :*: b) -> fmap (a :*:) $ f b))
  {-# INLINE glenses #-}

-- We don't need to write a lens for (:+:) becauses lenses are for products only.

instance GLenses z V1 V1 where
  glenses l = undefined
  {-# INLINE glenses #-}

instance GLenses z U1 U1 where
  glenses l = U1
  {-# INLINE glenses #-}

-- to call glenses we need to pass `Lens' (z Identity) (Rep (z Identity))` and then call to to get back our HKD representation.
--
-- How do we get Lens' (z Identity) (Rep (z Identity)) ?
-- This is basically an Iso (iso :: (s -> a) -> (b -> t) -> Iso s t a b)
-- iso from to

getLenses
  :: forall z
   . ( Generic (z Identity)
     , Generic (z (LensFor (z Identity)))
     , GLenses z (Rep (z Identity))
                 (Rep (z (LensFor (z Identity))))
     )
    => z (LensFor (z Identity))
getLenses = to $ glenses @z $ iso from to
-- ^^^^^^^^^^ to implement this he just throw z (LensFor (z Identity)) part of the type signature
--            and copy-pasted constraints from the error messages until the compiler was happy.
--
--            Try it, it works pretty well


main' :: IO ()
main' = do
  putStrLn "What's your name?"
  name <- Just <$> getLine
  putStrLn "What's your age?"
  age <- readMaybe <$> getLine
  let maybePerson = Person name age
  case validate maybePerson of
    Nothing     -> putStrLn "Invalid Person"
    Just person -> do
      let Person (LensFor name) (LensFor age) = getLenses
      putStrLn $ "Person (" <> (person ^. name) <> ", " <> (show $ person ^. age) <> ")"

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

-- Deriving Instances for HKD:

-- 1.
-- :set -XStandaloneDeriving
-- deriving instance Eq (Person' Identity)
-- deriving instance Eq (Person' Maybe)
-- deriving instance Ord (Person' Identity)
-- deriving instance Ord (Person' Maybe)

-- 2. We could automatically lift these instances from f a over the HKD f a type family.
--    There is already a library that implements this: one-liner

deriving instance (Constraints (Person f) Eq) => Eq (Person f)
-- ^^^^^ requires UndecidableInstances


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

-- Runtime Performance

-- For the most part, if you mark all of your generic type-class methods as INLINE and turn on -O2, most of the time you’re not going to pay any runtime cost for using the HKD technique.

-- Let's test it with inspection-testing library:

-- 1.

{-
  {-# LANGUAGE TemplateHaskell #-}
  {-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}

  import Test.Inspection
-}

-- 2.

freeName :: Lens' (Person Identity) String
freeName = let Person (LensFor name') _ = getLenses in name'

handName :: Lens' (Person Identity) String
handName a2fb s = a2fb (_name s) <&> \b -> s { _name = b }

-- Let's see if the cost of each implementation is equal:

viewLhs, viewRhs :: Person Identity -> String
viewLhs = view freeName
viewRhs = view handName

-- inspect $ 'viewLhs === 'viewRhs
-- ^^^^^^^^^ it's not equal but on the post it was (something changed over these two years)
--            ^^^^^ even if you compile with ghc -O2

setLhs, setRhs :: String -> Person Identity -> Person Identity
setLhs y = freeName .~ y
setRhs y = handName .~ y

-- inspect $ 'setLhs === 'setRhs
-- ^^^^^^ same


-- The actual lenses implementatio nis not equal at all! But we where only interested
-- in the actual performance penalty (if they produce same Core code, there is no penalty).

-- inspect $ 'freeName === 'handName
-- ^^^^^^^ The error code produced by this is LONG.