{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- | This module contains mechanisms for deriving necessary instances for a new 'Effect' typeclass to work with
-- @avail@. If you only need functionalities from @mtl@, @monad-control@, @unliftio@ and @capability@, you don't need
-- to use this module.
--
-- You need these extensions when using the module:
--
-- @
-- DataKinds
-- DerivingStrategies
-- FlexibleContexts
-- FlexibleInstances
-- GeneralizedNewtypeDeriving
-- StandaloneDeriving
-- TemplateHaskell
-- TypeFamilies
-- UndecidableInstances
-- @
module Avail.Derive
  ( -- * Deriving
    avail, avail'
  , -- * Helpers for deriving instances for multi-param classes
    with1, with2, with3, with4, with5, withN,
    with1', with2', with3', with4', with5', withN'
  , -- * Necessary reexports - do not use directly
    M (UnsafeLift)
  ) where

import           Avail.Internal
import           Language.Haskell.TH hiding (Type)
import qualified Language.Haskell.TH as TH

-- | Derive necessary instances for an 'Effect' typeclass to work with @avail@. Specifically, this only works with
-- typeclasses without superclasses; see 'avail'' for a version that takes care of superclasses.
avail :: Q TH.Type -> Q [Dec]
avail :: Q Type -> Q [Dec]
avail = [Q Type] -> Q Type -> Q [Dec]
avail' []

-- | Derive necessary instances for an 'Effect' typeclass to work with @avail@. This is a generalized version of
-- 'avail' that allows you to pass in a list of superclasses.
--
-- For superclasses @Sup :: ['Effect']@ and current class @Cls :: 'Effect'@, the code generated is:
--
-- @
-- instance 'IsEff' Cls where
--   type 'Superclasses' Cls = Sup
-- deriving newtype instance (Cls m, 'Eff' Cls) => Cls ('M' m)
-- @
--
-- Although this is very little code, it is still boilerplate and defining them by hand is error-prone. Therefore,
-- /please/ do not define instances for 'M' by hand (except when doing dirty hacks); use this function instead.
avail' :: [Q TH.Type] -> Q TH.Type -> Q [Dec]
avail' :: [Q Type] -> Q Type -> Q [Dec]
avail' = (Q Type -> Q Type) -> [Q Type] -> Q Type -> Q [Dec]
avail'' ((Q Type -> Q Type) -> [Q Type] -> Q Type -> Q [Dec])
-> (Q Type -> Q Type) -> [Q Type] -> Q Type -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \Q Type
m -> [t| M $m |]

avail'' :: (Q TH.Type -> Q TH.Type) -> [Q TH.Type] -> Q TH.Type -> Q [Dec]
avail'' :: (Q Type -> Q Type) -> [Q Type] -> Q Type -> Q [Dec]
avail'' Q Type -> Q Type
mm [Q Type]
pre Q Type
cls = do
  Name
mName <- String -> Q Name
newName String
"m"
  let m :: Q Type
m = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
VarT Name
mName
  [d|
    instance IsEff $cls where
      type Superclasses $cls = $(makeList <$> sequence pre)
    deriving newtype instance ($cls $m, Eff $cls) => $cls $(mm m) |]
  where
    makeList :: [Type] -> Type
makeList []       = Type
PromotedNilT
    makeList (Type
x : [Type]
xs) = Type
PromotedConsT Type -> Type -> Type
`AppT` Type
x Type -> Type -> Type
`AppT` [Type] -> Type
makeList [Type]
xs

-- | Introduce one type variable @a@.
with1 :: (Q TH.Type -> Q a) -> Q a
with1 :: (Q Type -> Q a) -> Q a
with1 = String -> (Q Type -> Q a) -> Q a
forall a. String -> (Q Type -> Q a) -> Q a
with1' String
"a"

-- | Introduce one type variable with given name.
with1' :: String -> (Q TH.Type -> Q a) -> Q a
with1' :: String -> (Q Type -> Q a) -> Q a
with1' String
n Q Type -> Q a
f = [String] -> ([Q Type] -> Q a) -> Q a
forall a. [String] -> ([Q Type] -> Q a) -> Q a
withN' [String
n] (\[Q Type
a] -> Q Type -> Q a
f Q Type
a)

-- | Introduce two type variables @a, b@.
with2 :: (Q TH.Type -> Q TH.Type -> Q a) -> Q a
with2 :: (Q Type -> Q Type -> Q a) -> Q a
with2 = String -> String -> (Q Type -> Q Type -> Q a) -> Q a
forall a. String -> String -> (Q Type -> Q Type -> Q a) -> Q a
with2' String
"a" String
"b"

-- | Introduce two type variables with given names.
with2' :: String -> String -> (Q TH.Type -> Q TH.Type -> Q a) -> Q a
with2' :: String -> String -> (Q Type -> Q Type -> Q a) -> Q a
with2' String
n1 String
n2 Q Type -> Q Type -> Q a
f = [String] -> ([Q Type] -> Q a) -> Q a
forall a. [String] -> ([Q Type] -> Q a) -> Q a
withN' [String
n1, String
n2] (\[Q Type
a, Q Type
b] -> Q Type -> Q Type -> Q a
f Q Type
a Q Type
b)

-- | Introduce three type variables @a, b, c@.
with3 :: (Q TH.Type -> Q TH.Type -> Q TH.Type -> Q a) -> Q a
with3 :: (Q Type -> Q Type -> Q Type -> Q a) -> Q a
with3 = String
-> String -> String -> (Q Type -> Q Type -> Q Type -> Q a) -> Q a
forall a.
String
-> String -> String -> (Q Type -> Q Type -> Q Type -> Q a) -> Q a
with3' String
"a" String
"b" String
"c"

-- | Introduce three type variables with given names.
with3' :: String -> String -> String -> (Q TH.Type -> Q TH.Type -> Q TH.Type -> Q a) -> Q a
with3' :: String
-> String -> String -> (Q Type -> Q Type -> Q Type -> Q a) -> Q a
with3' String
n1 String
n2 String
n3 Q Type -> Q Type -> Q Type -> Q a
f = [String] -> ([Q Type] -> Q a) -> Q a
forall a. [String] -> ([Q Type] -> Q a) -> Q a
withN' [String
n1, String
n2, String
n3] (\[Q Type
a, Q Type
b, Q Type
c] -> Q Type -> Q Type -> Q Type -> Q a
f Q Type
a Q Type
b Q Type
c)

-- | Introduce four type variables @a, b, c, d@.
with4 :: (Q TH.Type -> Q TH.Type -> Q TH.Type -> Q TH.Type -> Q a) -> Q a
with4 :: (Q Type -> Q Type -> Q Type -> Q Type -> Q a) -> Q a
with4 = String
-> String
-> String
-> String
-> (Q Type -> Q Type -> Q Type -> Q Type -> Q a)
-> Q a
forall a.
String
-> String
-> String
-> String
-> (Q Type -> Q Type -> Q Type -> Q Type -> Q a)
-> Q a
with4' String
"a" String
"b" String
"c" String
"d"

-- | Introduce four type variables with given names.
with4' :: String -> String -> String -> String -> (Q TH.Type -> Q TH.Type -> Q TH.Type -> Q TH.Type -> Q a) -> Q a
with4' :: String
-> String
-> String
-> String
-> (Q Type -> Q Type -> Q Type -> Q Type -> Q a)
-> Q a
with4' String
n1 String
n2 String
n3 String
n4 Q Type -> Q Type -> Q Type -> Q Type -> Q a
f = [String] -> ([Q Type] -> Q a) -> Q a
forall a. [String] -> ([Q Type] -> Q a) -> Q a
withN' [String
n1, String
n2, String
n3, String
n4] (\[Q Type
a, Q Type
b, Q Type
c, Q Type
d] -> Q Type -> Q Type -> Q Type -> Q Type -> Q a
f Q Type
a Q Type
b Q Type
c Q Type
d)

-- | Introduce five type variables @a, b, c, d, e@.
with5 :: (Q TH.Type -> Q TH.Type -> Q TH.Type -> Q TH.Type -> Q TH.Type -> Q a) -> Q a
with5 :: (Q Type -> Q Type -> Q Type -> Q Type -> Q Type -> Q a) -> Q a
with5 = String
-> String
-> String
-> String
-> String
-> (Q Type -> Q Type -> Q Type -> Q Type -> Q Type -> Q a)
-> Q a
forall a.
String
-> String
-> String
-> String
-> String
-> (Q Type -> Q Type -> Q Type -> Q Type -> Q Type -> Q a)
-> Q a
with5' String
"a" String
"b" String
"c" String
"d" String
"e"

-- | Introduce five type variables with given names.
with5' :: String -> String -> String -> String -> String -> (Q TH.Type -> Q TH.Type -> Q TH.Type -> Q TH.Type -> Q TH.Type -> Q a) -> Q a
with5' :: String
-> String
-> String
-> String
-> String
-> (Q Type -> Q Type -> Q Type -> Q Type -> Q Type -> Q a)
-> Q a
with5' String
n1 String
n2 String
n3 String
n4 String
n5 Q Type -> Q Type -> Q Type -> Q Type -> Q Type -> Q a
f = [String] -> ([Q Type] -> Q a) -> Q a
forall a. [String] -> ([Q Type] -> Q a) -> Q a
withN' [String
n1, String
n2, String
n3, String
n4, String
n5] (\[Q Type
a, Q Type
b, Q Type
c, Q Type
d, Q Type
e] -> Q Type -> Q Type -> Q Type -> Q Type -> Q Type -> Q a
f Q Type
a Q Type
b Q Type
c Q Type
d Q Type
e)

-- | Introduce arbitrarily many type variables @a1, a2, a3, ...@.
withN :: Int -> ([Q TH.Type] -> Q a) -> Q a
withN :: Int -> ([Q Type] -> Q a) -> Q a
withN Int
n = [String] -> ([Q Type] -> Q a) -> Q a
forall a. [String] -> ([Q Type] -> Q a) -> Q a
withN' ([String] -> ([Q Type] -> Q a) -> Q a)
-> [String] -> ([Q Type] -> Q a) -> Q a
forall a b. (a -> b) -> a -> b
$ (Char
'a' Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> [Int] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1..Int
n]

-- | Introduce arbitrarily many type variables with given names.
withN' :: [String] -> ([Q TH.Type] -> Q a) -> Q a
withN' :: [String] -> ([Q Type] -> Q a) -> Q a
withN' [String]
n [Q Type] -> Q a
f = do
  [Type]
as <- (String -> Q Type) -> [String] -> Q [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Name -> Type) -> Q Name -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
VarT (Q Name -> Q Type) -> (String -> Q Name) -> String -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Name
newName) [String]
n
  [Q Type] -> Q a
f (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
as)