{-# 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.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 functions 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 :: Name -> Q [Dec]
makeEffect = Bool -> Name -> Q [Dec]
makeSmartCons Bool
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 :: '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_ :: Name -> Q [Dec]
makeEffect_ = Bool -> Name -> Q [Dec]
makeSmartCons Bool
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 :: Bool -> Name -> Q [Dec]
makeSmartCons Bool
shouldMakeSig Name
effName = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
effName
  [[Dec]] -> [Dec]
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Bool -> Name -> Q [Dec]
makeCon Bool
shouldMakeSig) (ConstructorInfo -> Name
constructorName (ConstructorInfo -> Name) -> [ConstructorInfo] -> [Name]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorInfo] -> [ConstructorInfo]
forall a. [a] -> [a]
reverse (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
info))

-- | Make a single function definition of a certain effect operation.
makeCon :: Bool -> Name -> Q [Dec]
makeCon :: Bool -> Name -> Q [Dec]
makeCon Bool
shouldMakeSig Name
name = do
  Maybe Fixity
fixity <- Name -> Q (Maybe Fixity)
reifyFixity Name
name
  Type
ctorTy <- Name -> Q Info
reify Name
name Q Info -> (Info -> Q Type) -> Q Type
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    DataConI Name
_ Type
ty Name
_ -> Type -> Q Type
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
ty
    Info
_               -> String -> Q Type
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"'" Doc -> Doc -> Doc
<> Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
name Doc -> Doc -> Doc
<> String -> Doc
text String
"' is not a constructor"

  Cxt
operationCtx' <- Type -> Q Cxt
extractCtx Type
ctorTy
  (Cxt
operationParams', (Type
effTy, Either Name Name
effMonad, Type
resTy')) <- Type -> Q (Cxt, (Type, Either Name Name, Type))
extractParams Type
ctorTy

  (Type
esVar, Maybe Name
maybeMndVar) <- case Either Name Name
effMonad of
    Right Name
m -> do
      Type
fresh <- Name -> Type
VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"es"
      (Type, Maybe Name) -> Q (Type, Maybe Name)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type
fresh, Name -> Maybe Name
forall a. a -> Maybe a
Just Name
m)
    Left Name
v -> (Type, Maybe Name) -> Q (Type, Maybe Name)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Name -> Type
VarT Name
v, Maybe Name
forall a. Maybe a
Nothing)

  let operationCtx :: Cxt
operationCtx = Maybe Name -> Type -> Type -> Type
substMnd Maybe Name
maybeMndVar Type
esVar (Type -> Type) -> Cxt -> Cxt
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt
operationCtx'
  let operationParams :: Cxt
operationParams = Maybe Name -> Type -> Type -> Type
substMnd Maybe Name
maybeMndVar Type
esVar (Type -> Type) -> Cxt -> Cxt
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt
operationParams'
  let resTy :: Type
resTy = Maybe Name -> Type -> Type -> Type
substMnd Maybe Name
maybeMndVar Type
esVar Type
resTy'

  let fnName :: Name
fnName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
toSmartConName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name
  [Name]
fnArgs <- (Type -> Q Name) -> Cxt -> Q [Name]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Q Name -> Type -> Q Name
forall a b. a -> b -> a
const (Q Name -> Type -> Q Name) -> Q Name -> Type -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x") Cxt
operationParams

  let
    fnBody :: Exp
fnBody = Name -> Exp
VarE 'send Exp -> Exp -> Exp
`AppE` (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Exp
f -> Exp -> Exp -> Exp
AppE Exp
f (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) (Name -> Exp
ConE Name
name) [Name]
fnArgs
    fnSig :: Type
fnSig = [TyVarBndr] -> Cxt -> Type -> Type
ForallT [] (Type -> Name -> Type -> Type
UInfixT Type
effTy ''(:>) Type
esVar Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: Cxt
operationCtx)
      (Cxt -> Type -> Type -> Type -> Type
makeTyp Cxt
operationParams Type
esVar Type
effTy Type
resTy)

  [Dec] -> Q [Dec]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
    Maybe Dec -> [Dec]
forall a. Maybe a -> [a]
maybeToList ((Fixity -> Name -> Dec
`InfixD` Name
name) (Fixity -> Dec) -> Maybe Fixity -> Maybe Dec
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Fixity
fixity) [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
    [ Name -> Type -> Dec
SigD Name
fnName Type
fnSig | Bool
shouldMakeSig ] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
    [ Name -> [Clause] -> Dec
FunD Name
fnName [[Pat] -> Body -> [Dec] -> Clause
Clause (Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fnArgs) (Exp -> Body
NormalB Exp
fnBody) []] ]

  where
    -- Uncapitalize the first letter / remove the ':' in operator constructors
    toSmartConName :: String -> String
    toSmartConName :: String -> String
toSmartConName (Char
':' : String
xs) = String
xs
    toSmartConName (Char
x : String
xs)   = Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
    toSmartConName String
_          = String -> String
forall a. HasCallStack => String -> a
error String
"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 :: Type -> Q Cxt
extractCtx (ForallT [TyVarBndr]
_ Cxt
ctx Type
_) = Cxt -> Q Cxt
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Cxt
ctx
    extractCtx Type
ty = String -> Q Cxt
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q Cxt) -> String -> Q Cxt
forall a b. (a -> b) -> a -> b
$ Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"The constructor with type'" Doc -> Doc -> Doc
<> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty Doc -> Doc -> Doc
<> String -> Doc
text String
"' 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 :: Type -> Q (Cxt, (Type, Either Name Name, Type))
extractParams (ForallT [TyVarBndr]
_ Cxt
_ Type
t) = Type -> Q (Cxt, (Type, Either Name Name, Type))
extractParams Type
t
    extractParams (SigT Type
t Type
_) = Type -> Q (Cxt, (Type, Either Name Name, Type))
extractParams Type
t
    extractParams (ParensT Type
t) = Type -> Q (Cxt, (Type, Either Name Name, Type))
extractParams Type
t
    extractParams (Type
ArrowT `AppT` Type
a `AppT` Type
t) = do
      (Cxt
args, (Type, Either Name Name, Type)
ret) <- Type -> Q (Cxt, (Type, Either Name Name, Type))
extractParams Type
t
      (Cxt, (Type, Either Name Name, Type))
-> Q (Cxt, (Type, Either Name Name, Type))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type
a Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: Cxt
args, (Type, Either Name Name, Type)
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 (Type
effTy `AppT` VarT Name
mndVar `AppT` Type
resTy) = (Cxt, (Type, Either Name Name, Type))
-> Q (Cxt, (Type, Either Name Name, Type))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([], (Type
effTy, Name -> Either Name Name
forall a b. b -> Either a b
Right Name
mndVar, Type
resTy))
    extractParams (Type
effTy `AppT` (ConT Name
eff `AppT` VarT Name
esVar) `AppT` Type
resTy)
      | Name
eff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Eff = (Cxt, (Type, Either Name Name, Type))
-> Q (Cxt, (Type, Either Name Name, Type))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([], (Type
effTy, Name -> Either Name Name
forall a b. a -> Either a b
Left Name
esVar, Type
resTy))
    extractParams ty :: Type
ty@(Type
_ `AppT` Type
m `AppT` Type
_) = String -> Q (Cxt, (Type, Either Name Name, Type))
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q (Cxt, (Type, Either Name Name, Type)))
-> String -> Q (Cxt, (Type, Either Name Name, Type))
forall a b. (a -> b) -> a -> b
$ Doc -> String
forall a. Show a => a -> String
show
      (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"The effect monad argument '" Doc -> Doc -> Doc
<> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
m
      Doc -> Doc -> Doc
<> String -> Doc
text String
"' in the effect '" Doc -> Doc -> Doc
<> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty Doc -> Doc -> Doc
<> String -> Doc
text String
"' is not a type variable nor in shape 'Eff es'"
    extractParams Type
t = String -> Q (Cxt, (Type, Either Name Name, Type))
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q (Cxt, (Type, Either Name Name, Type)))
-> String -> Q (Cxt, (Type, Either Name Name, Type))
forall a b. (a -> b) -> a -> b
$ Doc -> String
forall a. Show a => a -> String
show
      (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"The type '" Doc -> Doc -> Doc
<> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
t
      Doc -> Doc -> Doc
<> String -> Doc
text String
"' 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 :: Cxt -> Type -> Type -> Type -> Type
makeTyp [] Type
esVar Type
_ Type
resTy = Name -> Type
ConT ''Eff Type -> Type -> Type
`AppT` Type
esVar Type -> Type -> Type
`AppT` Type
resTy
    makeTyp (Type
parTy : Cxt
pars) Type
esVar Type
effTy Type
resTy =
      Type
ArrowT Type -> Type -> Type
`AppT` Type
parTy Type -> Type -> Type
`AppT` Cxt -> Type -> Type -> Type -> Type
makeTyp Cxt
pars Type
esVar Type
effTy Type
resTy

    -- Substitute in 'Eff es' for the 'm' variable
    substMnd :: Maybe Name -> Type -> Type -> Type
    substMnd :: Maybe Name -> Type -> Type -> Type
substMnd Maybe Name
Nothing Type
_           = Type -> Type
forall a. a -> a
id
    substMnd (Just Name
mndVar) Type
esVar = Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution (Name -> Type -> Map Name Type
forall k a. k -> a -> Map k a
Map.singleton Name
mndVar (Type -> Map Name Type) -> Type -> Map Name Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Eff Type -> Type -> Type
`AppT` Type
esVar)