module FP.Pretty.Deriving where

import FP.Prelude
import FP.Pretty.Pretty
import Language.Haskell.TH

import qualified Data.Text as Text

-- makePrettySumLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] [(con₁,[conty₁₁,…,conty₁⸤n₁⸥]),…,(conₘ,[contyₘ₁,…,contyₘ⸤nₘ⸥])] ≔ 
--   [| instance 
--        (C₁,…,Cₙ
--        ,Pretty conty₁₁,…,Pretty conty₁⸤n₁⸥,…,Pretty contyₘ₁,…,Pretty contyₘ⸤nₘ⸥
--        ) ⇒ Pretty (ty a₁ … aₙ) where
--          pretty (con₁ (x₁₁ ∷ conty₁₁) … x₁⸤n₁⸥) = app [con "con₁",pretty x₁₁,…,pretty x₁⸤n₁⸥]
--          …
--          pretty (conₘ (xₘ₁ ∷ contyₘ₁) … xₘ⸤nₘ⸥) = app [con "conₘ",pretty xₘ₁,…,pretty xₘ⸤nₘ⸥]
--   |]
makePrettySumLogic ∷ (Monad m,MonadQ m) ⇒ Cxt → Name → [TyVarBndr] → [(Name,[Type])] → m [Dec]
makePrettySumLogic cx ty tyargs concontys = qio $ do
  conxs ∷ [(Name,[Name])] ← mapMOn concontys $ \ (con,contys) → do
    tmpˣˢ ← mapMOn contys $ const $ newName $ chars "x"
    return (con,tmpˣˢ)
  let tyargVars = map (VarT ∘ thTyVarBndrName) tyargs
      instanceCx ∷ [Pred]
      instanceCx = list $ uniques $ concat [cx,map (\ x → ConT ''Pretty ◇⋅ x) $ concat $ map snd concontys]
      instanceTy ∷ Type
      instanceTy = ConT ''Pretty ◇⋅ (ConT ty ◇⋅| tyargVars)
      instanceDec ∷ Dec
      instanceDec = FunD 'pretty $ mapOn conxs $ \ (con,tmpˣˢ) →
        let conString = thString $ 𝕤 $ nameBase con
            prettyCon = VarE 'ppCon ◇⋅ conString
            prettyXs = mapOn tmpˣˢ $ \ x → VarE 'pretty ◇⋅ VarE x
        in thSingleClause [ConP con $ map VarP tmpˣˢ] $ VarE 'ppApp ◇⋅ prettyCon ◇⋅ ListE prettyXs
  return $ single $ InstanceD instanceCx instanceTy $ single instanceDec

makePrettySum ∷ Name → Q [Dec]
makePrettySum name = do
  (cx,ty,tyargs,cs,_) ← returnMaybe abortIO ∘ (thViewADT *∘ view thTyConIL) *$ reify name
  scs ← mapM (returnMaybe abortIO ∘ thViewSimpleCon) cs
  makePrettySumLogic cx ty tyargs scs

-- makePrettyUnionLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] [(con₁,[conty₁₁,…,conty₁⸤n₁⸥]),…,(conₘ,[contyₘ₁,…,contyₘ⸤nₘ⸥])] ≔ 
--   [| instance 
--        (C₁,…,Cₙ
--        ,Pretty conty₁₁,…,Pretty conty₁⸤n₁⸥,…,Pretty contyₘ₁,…,Pretty contyₘ⸤nₘ⸥
--        ) ⇒ Pretty (ty a₁ … aₙ) where
--          pretty (con₁ (x₁₁ ∷ conty₁₁) … x₁⸤n₁⸥) = tup [pretty x₁₁,…,pretty x₁⸤n₁⸥]
--          …
--          pretty (conₘ (xₘ₁ ∷ contyₘ₁) … xₘ⸤nₘ⸥) = tup [pretty xₘ₁,…,pretty xₘ⸤nₘ⸥]
--   |]
makePrettyUnionLogic ∷ (Monad m,MonadQ m) ⇒ Cxt → Name → [TyVarBndr] → [(Name,[Type])] → m [Dec]
makePrettyUnionLogic cx ty tyargs concontys = qio $ do
  conxs ∷ [(Name,[Name])] ← mapMOn concontys $ \ (con,fieldtys) → do
    tmpˣˢ ← mapMOn fieldtys $ const $ newName $ chars "x"
    return (con,tmpˣˢ)
  let tyargVars = map (VarT ∘ thTyVarBndrName) tyargs
      instanceCx ∷ [Pred]
      instanceCx = list $ uniques $ concat [cx,map (\ x → ConT ''Pretty ◇⋅ x) $ concat $ map snd concontys]
      instanceTy ∷ Type
      instanceTy = ConT ''Pretty ◇⋅ (ConT ty ◇⋅| tyargVars)
      instanceDec ∷ Dec
      instanceDec = FunD 'pretty $ mapOn conxs $ \ (con,tmpˣˢ) → 
        thSingleClause [ConP con $ map VarP tmpˣˢ] $  case tmpˣˢ of
          [] → VarE 'pretty ◇⋅ ConE '()
          [x] → VarE 'pretty ◇⋅ VarE x
          _ → 
            let prettyXs = mapOn tmpˣˢ $ \ x → VarE 'pretty ◇⋅ VarE x
            in VarE 'ppCollection ◇⋅ thString "⟨" ◇⋅ thString "⟩" ◇⋅ thString "," ◇⋅ ListE prettyXs
  return $ single $ InstanceD instanceCx instanceTy $ single $ instanceDec

makePrettyUnion ∷ Name → Q [Dec]
makePrettyUnion name = do
  (cx,ty,tyargs,cs,_) ← returnMaybe abortIO ∘ (thViewADT *∘ view thTyConIL) *$ reify name
  scs ← mapM (returnMaybe abortIO ∘ thViewSimpleCon) cs
  makePrettyUnionLogic cx ty tyargs scs

-- makePrettyRecordLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] con [(field₁,fieldty₁),…,(fieldₙ,fieldtyₙ)] ≔
--   [| instance 
--        (C₁,…,Cₙ
--        ,Pretty fieldty₁,…,Pretty fieldtyₙ
--        ) ⇒ Pretty (ty a₁ … aₙ) where
--          pretty (con {field₁ = tmp₁;fieldₙ = tmpₙ}) = app [con "con",record [("field₁",tmp₁),…,("fieldₙ",tmpₙ)
--   |]

makePrettyRecordLogic ∷ (Monad m,MonadQ m) ⇒ Cxt → Name → [TyVarBndr] → Name → [(Name,Type)] → m [Dec]
makePrettyRecordLogic cx ty tyargs con fieldfieldtys = qio $ do
  let conPrefix = 𝕤 $ mapHead lowerChar $ nameBase con
  fieldNameTmps ← mapMOn fieldfieldtys $ \ (field,_) → do
    let (_prefix,afterPrefix) = Text.breakOnEnd conPrefix $ 𝕤 $ nameBase field
        loweredAfterPrefix = 𝕤 $ mapHead lowerChar $ list afterPrefix
    tmpˣ ← newName $ chars "x"
    return (field,loweredAfterPrefix,tmpˣ)
  let tyargVars = map (VarT ∘ thTyVarBndrName) tyargs
      instanceCx ∷ [Pred]
      instanceCx = list $ uniques $ concat [cx,map (\ x → ConT ''Pretty ◇⋅ x) $ map snd fieldfieldtys]
      instanceTy ∷ Type
      instanceTy = ConT ''Pretty ◇⋅ (ConT ty ◇⋅| tyargVars)
      instanceDec ∷ Dec
      instanceDec = FunD 'pretty $ single $ thSingleClause [RecP con $ mapOn fieldNameTmps $ \ (field,_name,tmpˣ) → (field,VarP tmpˣ)] $
        VarE 'ppApp ◇⋅ (VarE 'ppCon ◇⋅ (thString $ 𝕤 $ nameBase con)) ◇$ ListE $ single $
          VarE 'ppRecord ◇⋅ thString "≔" ◇$ ListE $ mapOn fieldNameTmps $ \ (_field,name,tmpˣ) → tup 
            [ VarE 'ppText ◇⋅ (thString name)
            , VarE 'pretty ◇⋅ VarE tmpˣ
            ]
  return $ single $ InstanceD instanceCx instanceTy $ single $ instanceDec

makePrettyRecord ∷ Name → Q [Dec]
makePrettyRecord name = do
  (cx,ty,tyargs,c,_) ← returnMaybe abortIO ∘ (thViewSingleConADT *∘ view thTyConIL) *$ reify name
  (con,fields) ← returnMaybe abortIO $ view thRecCL c
  let fieldfieldtys = mapOn fields $ \ (field,_,fieldty) → (field,fieldty)
  makePrettyRecordLogic cx ty tyargs con fieldfieldtys