Idiom-Lens.hs

{-# LANGUAGE TemplateHaskell, DataKinds, LambdaCase, KindSignatures, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies, Rank2Types #-}
module Idiom.Lens where

import Language.Haskell.TH
import Language.Haskell.TH.Lens
import Data.Proxy
import Control.Lens
import GHC.TypeLits

class Has (s :: Symbol) a where
  type Actual (s :: Symbol) a
  actual :: Proxy s -> Lens' a (Actual s a)

declareHas :: DecsQ -> DecsQ
declareHas decs = declareLenses decs >>= \case
  (d@(DataD _ dName _ _ _):sfs) -> return $ d : pairs (gen dName) sfs
  where
    pairs f (x:y:_:zs) = f x y : pairs f zs
    pairs _ [] = []
    gen dName (SigD n (ForallT _ _ (AppT _ t))) (FunD _ cs) = InstanceD []
      (ConT ''Has `AppT` LitT (StrTyLit $ nameBase n) `AppT` ConT dName) [
      TySynInstD ''Actual $ TySynEqn [LitT (StrTyLit $ nameBase n), ConT dName] t
      , FunD 'actual $ map (clausePattern %~ (WildP:)) cs
      , PragmaD $ InlineP 'actual Inline FunLike AllPhases
      ]

makeIdiom :: String -> Q [Dec]
makeIdiom s = do
  let tvA = mkName "a"
  return [SigD (mkName s) $ ForallT [PlainTV tvA] [ClassP ''Has [LitT (StrTyLit s), VarT tvA]]
    $ ConT ''Lens' `AppT` VarT tvA `AppT` (ConT ''Actual `AppT` LitT (StrTyLit s) `AppT` VarT tvA)
    , ValD (VarP $ mkName s)
    (NormalB $ VarE 'actual `AppE` (ConE 'Proxy `SigE` (ConT ''Proxy `AppT` LitT (StrTyLit s)))) []]

idiom.hs

{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}
import Linear
import Idiom.Lens
import Control.Lens

declareHas [d|data Object = Object { position :: V3 Float , velocity :: V3 Float } deriving (Show, Eq, Ord)|]

makeIdiom "position" -- position :: Has "position" a => Lens' a (Actual "position" a)
makeIdiom "velocity"

initialObject = Object zero zero

main = initialObject & position .~ V3 2 0 0 & velocity +~ V3 0 1 0 & print