{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Preamble.Lens
( makeClassyConstraints
) where
import Language.Haskell.TH
import Preamble.Prelude
makeClassyConstraints :: Name -> [Name] -> DecsQ
makeClassyConstraints name names =
addConstraints names <$> makeClassy name
addConstraints :: [Name] -> [Dec] -> [Dec]
addConstraints names = \case
ClassD cs n tvs f d : ds ->
ClassD (newConstraints names tvs ++ cs) n tvs f d : ds
ds -> ds
newConstraints :: [Name] -> [TyVarBndr] -> [Type]
newConstraints ns =
loop where
loop = \case
PlainTV name : _tvs ->
flip map ns $ \n ->
AppT (ConT n) (VarT name)
_tv : tvs -> loop tvs
[] -> []