module FP.Pretty.Deriving where
import FP.Prelude
import FP.Pretty.Pretty
import Language.Haskell.TH
import qualified Data.Text as Text
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 ∷ (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 ∷ (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