NewFunction.hs

module Data.Component.Mock.TH.NewFunction
  (make) where

import Relude

import qualified Language.Haskell.TH as Meta
import qualified Language.Haskell.TH.Syntax as Meta

import Data.Component.Mock.TH.Common

make :: Meta.Name -> [Meta.VarBangType] -> Meta.DecsQ
make recordName fields = pure $
  [ Meta.SigD
      mockName
      (Meta.ForallT
        []
        [ Meta.AppT
            (Meta.AppT
              (Meta.ConT $ Meta.mkName "Executes")
              (Meta.ConT $ Meta.mkName "Action"))
            (Meta.VarT $ Meta.mkName "actions")
        ]
        (Meta.AppT
          (Meta.ConT recordName)
          (Meta.AppT
            (Meta.ConT $ Meta.mkName "InContextOf")
            (Meta.VarT $ Meta.mkName "actions"))))
  , Meta.ValD
     (Meta.VarP mockName)
     (Meta.NormalB
       (Meta.RecConE
         (eraseNameInformation recordName)
         (fmap (mockField . toField) fields)
         )) []
  ]

mockField :: Field -> (Meta.Name, Meta.Exp)
mockField Field{..} = do
  let varExps = fmap toVarExp $ makeVars argumentsLength
  let actionConstructor = Meta.ConE (titleizeName name)
  let appliedConstructor = foldl' Meta.AppE actionConstructor varExps
  ( name
    , Meta.LamE
      (makeVars argumentsLength)
      (Meta.AppE
        (Meta.AppE
          (Meta.VarE $ Meta.mkName "mockAction")
          (Meta.LitE $ Meta.StringL $ Meta.nameBase name))
        appliedConstructor)
    )

mockName :: Meta.Name
mockName = Meta.mkName "mock"

eraseNameInformation :: Meta.Name -> Meta.Name
eraseNameInformation =
  Meta.mkName . Meta.nameBase