module FP.Prelude.LensDeriving where
import FP.Prelude.DSL
import FP.Prelude.Core
import FP.Prelude.Lens
import FP.Prelude.TemplateHaskell
import FP.Prelude.Lib
import Language.Haskell.TH
makeLensLogic ∷ (Monad m,MonadQ m) ⇒ Cxt → Name → [TyVarBndr] → Name → Type → m [Dec]
makeLensLogic cx ty tyargs field fieldty = qio $ do
let lensName = mkName $ chars $ 𝕤 (nameBase field) ⧺ "L"
tyargVars = map (VarT ∘ thTyVarBndrName) tyargs
tmpˣ ← newName $ chars "x"
tmpˢ ← newName $ chars "s"
return
[ SigD lensName $
ForallT tyargs cx $
ConT ''Lens ◇⋅ (ConT ty ◇⋅| tyargVars) ◇⋅ fieldty
, FunD lensName $ single $ thSingleClause [] $
VarE 'lens ◇⋅ VarE field ◇$ LamE [VarP tmpˢ,VarP tmpˣ] $ RecUpdE (VarE tmpˢ) [(field,VarE tmpˣ)]
]
makeLenses ∷ Name → Q [Dec]
makeLenses name = do
(cx,ty,tyargs,c,_) ← returnMaybe abortIO ∘ (thViewSingleConADT *∘ view thTyConIL) *$ reify name
(_,fields) ← returnMaybe abortIO $ view thRecCL c
concat ^$ mapMOn fields $ \ (field,_,fieldty) → makeLensLogic cx ty tyargs field fieldty
makePrismLogic ∷ (Monad m,MonadQ m) ⇒ Cxt → Name → [TyVarBndr] → Name → [Type] → ℕ → m [Dec]
makePrismLogic cx ty tyargs con fieldtys numcons = qio $ do
let prismName = mkName $ chars $ 𝕤 (mapHead lowerChar $ nameBase con) ⧺ "L"
tyargVars = map (VarT ∘ thTyVarBndrName) tyargs
tmpˣ ← newName $ chars "x"
tmpˣˢ ← mapMOn fieldtys $ const $ newName $ chars "x"
return
[ SigD prismName $
ForallT tyargs cx $
ConT ''Prism ◇⋅ (ConT ty ◇⋅| tyargVars) ◇⋅ tup fieldtys
, FunD prismName $ single $ thSingleClause [] $
ConE 'Prism
◇⋅ (LamE [tup $ map VarP tmpˣˢ] $ ConE con ◇⋅| map VarE tmpˣˢ)
◇⋅ (LamE [VarP tmpˣ] $
CaseE (VarE tmpˣ) $ concat
[ single $ thSingleMatch (ConP con $ map VarP tmpˣˢ) $
ConE 'Just ◇⋅ tup (map VarE tmpˣˢ)
, if numcons <= 𝕟 1
then []
else single $ thSingleMatch WildP $ ConE 'Nothing
])
]
makePrisms ∷ Name → Q [Dec]
makePrisms name = do
(cx, ty, tyargs, cs, _) ← returnMaybe abortIO ∘ (thViewADT *∘ view thTyConIL) *$ reify name
scs ← mapM (returnMaybe abortIO ∘ thViewSimpleCon) cs
let numcons = length scs
concat ^$ mapMOn scs $ \ (con, fieldtys) → makePrismLogic cx ty tyargs con fieldtys numcons