content: {-# LANGUAGE CPP #-}
  {-# OPTIONS_HADDOCK not-home #-}
  -- |
  -- Copyright: (c) 2021 Xy Ren
  -- License: BSD3
  -- Maintainer: xy.r@outlook.com
  -- Stability: unstable
  -- Portability: non-portable (GHC only)
  --
  -- This module contains Template Haskell functions for generating definitions of functions that send effect
  -- operations. You mostly won't want to import this module directly; The "Cleff" module reexports the main
  -- functionalities of this module.
  --
  -- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be
  -- extra careful if you're to depend on this module.
  module Cleff.Internal.TH (makeEffect, makeEffect_) where
  
  import           Cleff.Internal.Interpret
  import           Cleff.Internal.Monad
  import           Control.Monad                (join)
  import           Data.Char                    (toLower)
  import           Data.Foldable                (foldl')
  import qualified Data.Map.Strict              as Map
  import           Data.Maybe                   (maybeToList)
  import           Language.Haskell.TH
  import           Language.Haskell.TH.Datatype (ConstructorInfo (constructorName), DatatypeInfo (datatypeCons),
                                                 TypeSubstitution (applySubstitution), reifyDatatype)
  import           Language.Haskell.TH.PprLib   (text, (<>))
  import           Prelude                      hiding ((<>))
  
  -- | For a datatype @T@ representing an effect, @'makeEffect' T@ generates function defintions for performing the
  -- operations of @T@ via 'send'. For example,
  --
  -- @
  -- 'makeEffect' ''Filesystem
  -- @
  --
  -- generates the following definitions:
  --
  -- @
  -- readFile      :: Filesystem ':>' es => 'FilePath' -> 'Eff' es 'String'
  -- readFile  x   =  'send' (ReadFile x)
  -- writeFile     :: Filesystem ':>' es => 'FilePath' -> 'String' -> 'Eff' es ()
  -- writeFile x y =  'send' (WriteFile x y)
  -- @
  --
  -- The naming rule is changing the first uppercase letter in the constructor name to lowercase or removing the @:@
  -- symbol in the case of operator constructors. Also, this function will preserve any fixity declarations defined on
  -- the constructors.
  --
  -- === Technical details
  --
  -- This function is also "weaker" than @polysemy@'s @makeSem@, because this function cannot properly handle some
  -- cases involving ambiguous types. Those cases are rare, though. See the @ThSpec@ test spec for more details.
  makeEffect :: Name -> Q [Dec]
  makeEffect = makeSmartCons True
  
  -- | Like 'makeEffect', but doesn't generate type signatures. This is useful when you want to attach Haddock
  -- documentation to the function signature, /e.g./:
  --
  -- @
  -- data Identity :: 'Cleff.Effect' where
  --   Noop :: Identity m ()
  -- 'makeEffect_' ''Identity
  --
  -- -- | Perform nothing at all.
  -- noop :: Identity ':>' es => 'Eff' es ()
  -- @
  --
  -- Be careful that the function signatures must be added /after/ the 'makeEffect_' call.
  makeEffect_ :: Name -> Q [Dec]
  makeEffect_ = makeSmartCons False
  
  -- | This is the function underlying 'makeEffect' and 'makeEffect_'. You can switch between the behavior of two by
  -- changing the 'Bool' parameter to 'True' (generating signatures) or 'False' (not generating signatures).
  makeSmartCons :: Bool -> Name -> Q [Dec]
  makeSmartCons shouldMakeSig effName = do
    info <- reifyDatatype effName
    join <$> traverse (makeCon shouldMakeSig) (constructorName <$> reverse (datatypeCons info))
  
  -- | Make a single function definition of a certain effect operation.
  makeCon :: Bool -> Name -> Q [Dec]
  makeCon shouldMakeSig name = do
    fixity <- reifyFixity name
    ctorTy <- reify name >>= \case
      DataConI _ ty _ -> pure ty
      _               -> fail $ show $ text "'" <> ppr name <> text "' is not a constructor"
  
    operationCtx' <- extractCtx ctorTy
    (operationParams', (effTy, effMonad, resTy')) <- extractParams ctorTy
  
    (esVar, maybeMndVar) <- case effMonad of
      Right m -> do
        fresh <- VarT <$> newName "es"
        pure (fresh, Just m)
      Left v -> pure (VarT v, Nothing)
  
    let operationCtx = substMnd maybeMndVar esVar <$> operationCtx'
    let operationParams = substMnd maybeMndVar esVar <$> operationParams'
    let resTy = substMnd maybeMndVar esVar resTy'
  
    let fnName = mkName $ toSmartConName $ nameBase name
    fnArgs <- traverse (const $ newName "x") operationParams
  
    let
      fnBody = VarE 'send `AppE` foldl' (\f -> AppE f . VarE) (ConE name) fnArgs
      fnSig = ForallT [] (UInfixT effTy ''(:>) esVar : operationCtx)
        (makeTyp operationParams esVar effTy resTy)
  
    pure $
      maybeToList ((`InfixD` name) <$> fixity) ++
      [ SigD fnName fnSig | shouldMakeSig ] ++
      [ FunD fnName [Clause [] (NormalB $ LamE (VarP <$> fnArgs) fnBody) []] ]
  
    where
      -- Uncapitalize the first letter / remove the ':' in operator constructors
      toSmartConName :: String -> String
      toSmartConName (':' : xs) = xs
      toSmartConName (x : xs)   = toLower x : xs
      toSmartConName _          = error "Cleff.makeEffect: Empty constructor name. Please report this as a bug."
  
      -- Extract constraints for the constructor (the type is normalized so we don't need to extract recursively)
      extractCtx :: Type -> Q Cxt
      extractCtx (ForallT _ ctx _) = pure ctx
      extractCtx ty = fail $ show $ text "The constructor with type'" <> ppr ty <> text "' does not construct an effect"
  
      -- Extract (parameter types, (effect type, Eff es / m variable, return type))
      extractParams :: Type -> Q ([Type], (Type, Either Name Name, Type))
      extractParams (ForallT _ _ t) = extractParams t
      extractParams (SigT t _) = extractParams t
      extractParams (ParensT t) = extractParams t
      extractParams (ArrowT `AppT` a `AppT` t) = do
        (args, ret) <- extractParams t
        pure (a : args, ret)
  #if MIN_VERSION_template_haskell(2,17,0)
      extractParams (MulArrowT `AppT` _ `AppT` a `AppT` t) = do
        (args, ret) <- extractParams t
        pure (a : args, ret)
  #endif
      extractParams (effTy `AppT` VarT mndVar `AppT` resTy) = pure ([], (effTy, Right mndVar, resTy))
      extractParams (effTy `AppT` (ConT eff `AppT` VarT esVar) `AppT` resTy)
        | eff == ''Eff = pure ([], (effTy, Left esVar, resTy))
      extractParams ty@(_ `AppT` m `AppT` _) = fail $ show
        $ text "The effect monad argument '" <> ppr m
        <> text "' in the effect '" <> ppr ty <> text "' is not a type variable nor in shape 'Eff es'"
      extractParams t = fail $ show
        $ text "The type '" <> ppr t
        <> text "' does not have the shape of an effect (i.e. has a polymorphic monad type and a result type)"
  
      -- Make the type of the smart constructor from params, effect row variable, effect type and result type
      -- Example: a -> m b -> c -> MyEffect m d ==> a -> Eff es b -> c -> Eff es d
      makeTyp :: [Type] -> Type -> Type -> Type -> Type
      makeTyp [] esVar _ resTy = ConT ''Eff `AppT` esVar `AppT` resTy
      makeTyp (parTy : pars) esVar effTy resTy =
        ArrowT `AppT` parTy `AppT` makeTyp pars esVar effTy resTy
  
      -- Substitute in 'Eff es' for the 'm' variable
      substMnd :: Maybe Name -> Type -> Type -> Type
      substMnd Nothing _           = id
      substMnd (Just mndVar) esVar = applySubstitution (Map.singleton mndVar $ ConT ''Eff `AppT` esVar)
  