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 [C₁,…,Cₙ] ty [a₁,…,aₙ] field fieldty ≔ 
--   [| fieldL ∷ ∀ a₁ … aₙ. (C₁,…,Cₙ) ⇒ Lens (ty a₁ … aₙ) fieldty
--      fieldL ≔ lens field (\ x s → s { field = x })
--   |]
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 [C₁,…,Cₙ] ty [a₁,…,aₙ] con (fieldty₁,…,fieldtyₙ) ≔ 
--   [| fieldL ∷ ∀ a₁ … aₙ. (C₁,…,Cₙ) ⇒ Prism (ty a₁ … aₙ) (fieldty₁,…,fieldtyₙ)
--      fieldL ≔ Prism 
--        { inject = con
--        , view = \ v → case v of
--            con x₁ … xₙ → Just (x₁,…,xₙ)
--            _ → Nothing
--        }
--   |]
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 
                  -- avoids generating code that has a dead branch
                  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