-----------------------------------------------------------------------------
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Lens.TH
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
-----------------------------------------------------------------------------
module Miso.Lens.TH (makeLenses, makeClassy, compose, this) where
-----------------------------------------------------------------------------
import Data.Char
import Data.Maybe
import Language.Haskell.TH
-----------------------------------------------------------------------------
import Miso.Util (compose)
import Miso.Lens (this)
-----------------------------------------------------------------------------
makeLenses :: Name -> Q [Dec]
makeLenses :: Name -> Q [Dec]
makeLenses Name
name = do
  Name -> Q Info
reify Name
name Q Info -> (Info -> Q [Dec]) -> Q [Dec]
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    TyConI (NewtypeD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ Con
con [DerivClause]
_) -> do
      case Con
con of
        RecC Name
_ [VarBangType]
fieldNames ->
          [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([VarBangType] -> [Dec]
forall {b}. [(Name, b, Kind)] -> [Dec]
processFieldNames [VarBangType]
fieldNames)
        Con
_ -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ [Con]
cons [DerivClause]
_) ->
      ((Con -> Q [Dec]) -> [Con] -> Q [Dec])
-> [Con] -> (Con -> Q [Dec]) -> Q [Dec]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Con -> Q [Dec]) -> [Con] -> Q [Dec]
forall {t :: * -> *} {f :: * -> *} {a} {a}.
(Traversable t, Monad f) =>
(a -> f [a]) -> t a -> f [a]
concatMapM [Con]
cons ((Con -> Q [Dec]) -> Q [Dec]) -> (Con -> Q [Dec]) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \case
        RecC Name
_ [VarBangType]
fieldNames -> do
          [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([VarBangType] -> [Dec]
forall {b}. [(Name, b, Kind)] -> [Dec]
processFieldNames [VarBangType]
fieldNames)
        Con
_ -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Info
_ -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    processFieldNames :: [(Name, b, Kind)] -> [Dec]
processFieldNames [(Name, b, Kind)]
fieldNames = [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Char] -> Kind -> Kind -> [Dec]
mkFields [Char]
fName (Name -> Kind
ConT Name
name) Kind
fieldType
      | (Name
fieldName, b
_, Kind
fieldType) <- [(Name, b, Kind)]
fieldNames
      , let fName :: [Char]
fName = Name -> [Char]
nameBase Name
fieldName
      , [Char] -> Maybe Char
forall a. [a] -> Maybe a
listToMaybe [Char]
fName Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'_'
      ]
    mkFields :: [Char] -> Kind -> Kind -> [Dec]
mkFields [Char]
fieldName Kind
conType Kind
fieldType =
     let -- dmj: drops '_' prefix
       lensName :: Name
lensName = [Char] -> Name
mkName (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 [Char]
fieldName)
     in
       [ Name -> [Clause] -> Dec
FunD Name
lensName
         [ [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB ([Char] -> Exp
mkLens [Char]
fieldName)) []
         ]
       , Name -> Kind -> Dec
SigD Name
lensName (Kind -> Kind -> Kind
mkLensType Kind
conType Kind
fieldType)
       ]
    concatMapM :: (a -> f [a]) -> t a -> f [a]
concatMapM a -> f [a]
f t a
xs =
      t [a] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (t [a] -> [a]) -> f (t [a]) -> f [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f [a]) -> t a -> f (t [a])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM a -> f [a]
f t a
xs
    mkLensType :: Kind -> Kind -> Kind
mkLensType Kind
conType =
      Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ([Char] -> Name
mkName [Char]
"Lens")) Kind
conType)
    mkLens :: [Char] -> Exp
mkLens [Char]
n =
      Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE ([Char] -> Name
mkName [Char]
"lens")) (Name -> Exp
VarE ([Char] -> Name
mkName [Char]
n)))
        (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [ Name -> Pat
VarP Name
recName, Name -> Pat
VarP Name
fieldName ]
        (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [FieldExp] -> Exp
RecUpdE (Name -> Exp
VarE Name
recName) [ ([Char] -> Name
mkName [Char]
n, Name -> Exp
VarE Name
fieldName) ]
      where
        recName :: Name
recName = [Char] -> Name
mkName [Char]
"record"
        fieldName :: Name
fieldName = [Char] -> Name
mkName [Char]
"field"
-----------------------------------------------------------------------------
makeClassy :: Name -> Q [Dec]
makeClassy :: Name -> Q [Dec]
makeClassy Name
name = do
  Name -> Q Info
reify Name
name Q Info -> (Info -> Q [Dec]) -> Q [Dec]
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    TyConI (NewtypeD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ Con
con [DerivClause]
_) -> do
      case Con
con of
        RecC Name
_ [VarBangType]
fieldNames ->
          [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([VarBangType] -> [Dec]
forall {b}. [(Name, b, Kind)] -> [Dec]
processFieldNames [VarBangType]
fieldNames)
        Con
_ -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ [Con]
cons [DerivClause]
_) ->
      ((Con -> Q [Dec]) -> [Con] -> Q [Dec])
-> [Con] -> (Con -> Q [Dec]) -> Q [Dec]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Con -> Q [Dec]) -> [Con] -> Q [Dec]
forall {t :: * -> *} {f :: * -> *} {a} {a}.
(Traversable t, Monad f) =>
(a -> f [a]) -> t a -> f [a]
concatMapM [Con]
cons ((Con -> Q [Dec]) -> Q [Dec]) -> (Con -> Q [Dec]) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \case
        RecC Name
_ [VarBangType]
fieldNames -> do
          [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([VarBangType] -> [Dec]
forall {b}. [(Name, b, Kind)] -> [Dec]
processFieldNames [VarBangType]
fieldNames)
        Con
_ -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Info
_ -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    instanceName :: Kind
instanceName =
      Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ([Char] -> Name
mkName ([Char]
"Has" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
baseName))) (Name -> Kind
ConT Name
name)
    baseName :: [Char]
baseName = Name -> [Char]
nameBase Name
name
    baseNameLower :: [Char]
baseNameLower
      | Char
x : [Char]
xs <- [Char]
baseName = Char -> Char
toLower Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
xs
      | Bool
otherwise = []
    processFieldNames :: [(Name, b, Kind)] -> [Dec]
processFieldNames [(Name, b, Kind)]
fieldNames =
        [ Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Kind
instanceName
          [ Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP ([Char] -> Name
mkName [Char]
baseNameLower)) (Exp -> Body
NormalB (Name -> Exp
VarE ([Char] -> Name
mkName [Char]
"this"))) []
            -- instance HasFoo Foo where foo = this
          ]
        , Cxt -> Name -> [TyVarBndr BndrVis] -> [FunDep] -> [Dec] -> Dec
ClassD [] ([Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"Has" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Name -> [Char]
nameBase Name
name)
            [ Name -> BndrVis -> TyVarBndr BndrVis
forall flag. Name -> flag -> TyVarBndr flag
PlainTV ([Char] -> Name
mkName [Char]
baseNameLower) BndrVis
BndrReq
            ] [] ([Dec] -> Dec) -> [Dec] -> Dec
forall a b. (a -> b) -> a -> b
$ [Dec] -> [Dec]
forall a. [a] -> [a]
reverse ([Dec] -> [Dec]) -> [Dec] -> [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [Char] -> Kind -> Kind -> [Dec]
mkFields [Char]
fName (Name -> Kind
VarT ([Char] -> Name
mkName [Char]
baseNameLower)) Kind
fieldType
            | (Name
fieldName, b
_, Kind
fieldType) <- [(Name, b, Kind)]
fieldNames
            , let fName :: [Char]
fName = Name -> [Char]
nameBase Name
fieldName
            , [Char] -> Maybe Char
forall a. [a] -> Maybe a
listToMaybe [Char]
fName Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'_'
            ] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
            [ Name -> Kind -> Dec
SigD
                ([Char] -> Name
mkName [Char]
baseNameLower) 
                (Kind -> Kind -> Kind
AppT
                   (Kind -> Kind -> Kind
AppT
                      (Name -> Kind
ConT ([Char] -> Name
mkName [Char]
"Lens"))
                      (Name -> Kind
VarT ([Char] -> Name
mkName [Char]
baseNameLower)))
                      (Name -> Kind
ConT Name
name))
            ]
        ]
    mkFields :: [Char] -> Kind -> Kind -> [Dec]
mkFields [Char]
fieldName Kind
varType Kind
fieldType =
      let -- dmj: drops '_' prefix
        lensName :: Name
lensName = [Char] -> Name
mkName (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 [Char]
fieldName)
      in
        [ Name -> [Clause] -> Dec
FunD Name
lensName
          [ [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB ([Char] -> Exp
wrapMkLens [Char]
fieldName)) []
          ]
          -- fooX = lens _fooX (\r x -> r { _fooX = x }) . foo
        , Name -> Kind -> Dec
SigD Name
lensName (Kind -> Kind -> Kind
mkLensType Kind
varType Kind
fieldType)
          -- fooY :: Lens foo Int
        ]
    concatMapM :: (a -> f [a]) -> t a -> f [a]
concatMapM a -> f [a]
f t a
xs =
      t [a] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (t [a] -> [a]) -> f (t [a]) -> f [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f [a]) -> t a -> f (t [a])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM a -> f [a]
f t a
xs
    mkLensType :: Kind -> Kind -> Kind
mkLensType Kind
varType Kind
x =
      Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ([Char] -> Name
mkName [Char]
"Lens")) Kind
varType) Kind
x
    wrapMkLens :: [Char] -> Exp
wrapMkLens [Char]
n =
      Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE ([Char] -> Name
mkName [Char]
"compose")) ([Char] -> Exp
mkLens [Char]
n)) (Name -> Exp
VarE ([Char] -> Name
mkName [Char]
baseNameLower))
    mkLens :: [Char] -> Exp
mkLens [Char]
n
      = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE ([Char] -> Name
mkName [Char]
"lens")) (Name -> Exp
VarE ([Char] -> Name
mkName [Char]
n)))
      (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [ Name -> Pat
VarP Name
recName, Name -> Pat
VarP Name
fieldName ]
      (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [FieldExp] -> Exp
RecUpdE (Name -> Exp
VarE Name
recName) [ ([Char] -> Name
mkName [Char]
n, Name -> Exp
VarE Name
fieldName) ]
      where
        recName :: Name
recName = [Char] -> Name
mkName [Char]
"record"
        fieldName :: Name
fieldName = [Char] -> Name
mkName [Char]
"field"
-------------------------------------------------------------------------------