{-# LANGUAGE TypeInType, GADTs, ScopedTypeVariables, FlexibleInstances,
TypeOperators, ConstraintKinds, TypeFamilies, PartialTypeSignatures,
UndecidableInstances, ViewPatterns, RankNTypes, TypeApplications,
MultiParamTypeClasses, UndecidableSuperClasses, TemplateHaskell,
StandaloneDeriving, DerivingStrategies, GeneralizedNewtypeDeriving #-}
module Monad.Capabilities
(
Capabilities(),
CapsT,
emptyCaps,
buildCaps,
CapabilitiesBuilder(..),
CapImpl(..),
getCap,
overrideCap,
addCap,
insertCap,
withCap,
checkCap,
adjustCap,
Context(..),
HasContext,
newContext,
askContext,
localContext,
type HasCap,
type HasCaps,
type HasNoCap,
HasCapDecision(..),
makeCap
) where
import Control.Monad.Trans.Reader
import Data.Kind (Type, Constraint)
import Data.Traversable
import Data.Proxy
import Data.Type.Equality
import Data.List (foldl1')
import GHC.TypeLits (TypeError, ErrorMessage(..))
import Type.Reflection (Typeable)
import Data.Coerce (coerce)
import Unsafe.Coerce (unsafeCoerce)
import qualified Data.TypeRepMap as TypeRepMap
import Data.TypeRepMap (TypeRepMap)
import qualified Language.Haskell.TH as TH
type MonadK = Type -> Type
type CapK = MonadK -> Type
newtype Capabilities (caps :: [CapK]) (m :: MonadK) =
Capabilities (TypeRepMap (CapElem m))
emptyCaps :: Capabilities '[] m
emptyCaps :: Capabilities '[] m
emptyCaps = TypeRepMap (CapElem m) -> Capabilities '[] m
forall (caps :: [CapK]) (m :: MonadK).
TypeRepMap (CapElem m) -> Capabilities caps m
Capabilities TypeRepMap (CapElem m)
forall k (f :: k -> *). TypeRepMap f
TypeRepMap.empty
deriving newtype instance Show (Capabilities caps m)
type CapsT caps m = ReaderT (Capabilities caps m) m
data CapImpl cap icaps m where
CapImpl ::
WithSpine icaps =>
{ CapImpl cap icaps m
-> forall (caps :: [CapK]).
HasCaps icaps caps =>
cap (CapsT caps m)
getCapImpl :: forall caps. HasCaps icaps caps => cap (CapsT caps m)
} ->
CapImpl cap icaps m
newtype CapElem m cap =
CapElem { CapElem m cap -> forall (caps :: [CapK]). cap (CapsT caps m)
getCapElem :: forall caps. cap (CapsT caps m) }
overCapElem ::
(forall caps. cap (CapsT caps m) -> cap' (CapsT caps m')) ->
CapElem m cap ->
CapElem m' cap'
overCapElem :: (forall (caps :: [CapK]).
cap (CapsT caps m) -> cap' (CapsT caps m'))
-> CapElem m cap -> CapElem m' cap'
overCapElem forall (caps :: [CapK]). cap (CapsT caps m) -> cap' (CapsT caps m')
f (CapElem forall (caps :: [CapK]). cap (CapsT caps m)
cap) = (forall (caps :: [CapK]). cap' (CapsT caps m')) -> CapElem m' cap'
forall (m :: MonadK) (cap :: CapK).
(forall (caps :: [CapK]). cap (CapsT caps m)) -> CapElem m cap
CapElem (cap (CapsT caps m) -> cap' (CapsT caps m')
forall (caps :: [CapK]). cap (CapsT caps m) -> cap' (CapsT caps m')
f cap (CapsT caps m)
forall (caps :: [CapK]). cap (CapsT caps m)
cap)
class WithSpine xs where
onSpine ::
forall r.
Proxy xs ->
((xs ~ '[]) => r) ->
(forall y ys.
(xs ~ (y : ys)) =>
WithSpine ys =>
Proxy y ->
Proxy ys ->
r) ->
r
instance WithSpine '[] where
onSpine :: Proxy '[]
-> (('[] ~ '[]) => r)
-> (forall (y :: k) (ys :: [k]).
('[] ~ (y : ys), WithSpine ys) =>
Proxy y -> Proxy ys -> r)
-> r
onSpine Proxy '[]
_ ('[] ~ '[]) => r
onNil forall (y :: k) (ys :: [k]).
('[] ~ (y : ys), WithSpine ys) =>
Proxy y -> Proxy ys -> r
_ = r
('[] ~ '[]) => r
onNil
instance WithSpine xs => WithSpine (x : xs) where
onSpine :: Proxy (x : xs)
-> (((x : xs) ~ '[]) => r)
-> (forall (y :: k) (ys :: [k]).
((x : xs) ~ (y : ys), WithSpine ys) =>
Proxy y -> Proxy ys -> r)
-> r
onSpine Proxy (x : xs)
_ ((x : xs) ~ '[]) => r
_ forall (y :: k) (ys :: [k]).
((x : xs) ~ (y : ys), WithSpine ys) =>
Proxy y -> Proxy ys -> r
onCons = Proxy x -> Proxy xs -> r
forall (y :: k) (ys :: [k]).
((x : xs) ~ (y : ys), WithSpine ys) =>
Proxy y -> Proxy ys -> r
onCons Proxy x
forall k (t :: k). Proxy t
Proxy Proxy xs
forall k (t :: k). Proxy t
Proxy
toCapElem ::
forall cap icaps m.
CapImpl cap icaps m ->
CapElem m cap
toCapElem :: CapImpl cap icaps m -> CapElem m cap
toCapElem (CapImpl forall (caps :: [CapK]). HasCaps icaps caps => cap (CapsT caps m)
cap) = (forall (caps :: [CapK]). cap (CapsT caps m)) -> CapElem m cap
forall (m :: MonadK) (cap :: CapK).
(forall (caps :: [CapK]). cap (CapsT caps m)) -> CapElem m cap
CapElem
(Proxy icaps
-> Proxy caps
-> (HasCaps icaps caps => cap (CapsT caps m))
-> cap (CapsT caps m)
forall k (icaps :: [k]) (caps :: [k]).
WithSpine icaps =>
Proxy icaps
-> Proxy caps -> forall r. (HasCaps icaps caps => r) -> r
fiatHasElems (Proxy icaps
forall k (t :: k). Proxy t
Proxy @icaps) (Proxy caps
forall k (t :: k). Proxy t
Proxy @caps) HasCaps icaps caps => cap (CapsT caps m)
forall (caps :: [CapK]). HasCaps icaps caps => cap (CapsT caps m)
cap :: forall caps. cap (CapsT caps m))
fiatHasElems ::
forall icaps caps.
WithSpine icaps =>
Proxy icaps ->
Proxy caps ->
forall r. (HasCaps icaps caps => r) -> r
fiatHasElems :: Proxy icaps
-> Proxy caps -> forall r. (HasCaps icaps caps => r) -> r
fiatHasElems Proxy icaps
Proxy Proxy caps
Proxy HasCaps icaps caps => r
r =
Proxy icaps
-> ((icaps ~ '[]) => r)
-> (forall (y :: k) (ys :: [k]).
(icaps ~ (y : ys), WithSpine ys) =>
Proxy y -> Proxy ys -> r)
-> r
forall k (xs :: [k]) r.
WithSpine xs =>
Proxy xs
-> ((xs ~ '[]) => r)
-> (forall (y :: k) (ys :: [k]).
(xs ~ (y : ys), WithSpine ys) =>
Proxy y -> Proxy ys -> r)
-> r
onSpine (Proxy icaps
forall k (t :: k). Proxy t
Proxy @icaps)
(icaps ~ '[]) => r
HasCaps icaps caps => r
r
(\(Proxy y
Proxy :: Proxy cap) (Proxy ys
Proxy :: Proxy icaps') ->
case HasCap y caps :~: (() :: Constraint)
forall (c :: Constraint). c :~: (() :: Constraint)
unsafeUnitConstr @(HasCap cap caps) of
HasCap y caps :~: (() :: Constraint)
Refl -> Proxy ys -> Proxy caps -> (HasCaps ys caps => r) -> r
forall k (icaps :: [k]) (caps :: [k]).
WithSpine icaps =>
Proxy icaps
-> Proxy caps -> forall r. (HasCaps icaps caps => r) -> r
fiatHasElems (Proxy ys
forall k (t :: k). Proxy t
Proxy @icaps') (Proxy caps
forall k (t :: k). Proxy t
Proxy @caps) HasCaps icaps caps => r
HasCaps ys caps => r
r)
data CapabilitiesBuilder (allCaps :: [CapK]) (caps :: [CapK]) (m :: MonadK) where
AddCap ::
(Typeable cap, HasCaps icaps allCaps, HasNoCap cap caps) =>
CapImpl cap icaps m ->
CapabilitiesBuilder allCaps caps m ->
CapabilitiesBuilder allCaps (cap : caps) m
BaseCaps ::
Capabilities caps m ->
CapabilitiesBuilder allCaps caps m
buildCaps :: forall caps m. CapabilitiesBuilder caps caps m -> Capabilities caps m
buildCaps :: CapabilitiesBuilder caps caps m -> Capabilities caps m
buildCaps = TypeRepMap (CapElem m) -> Capabilities caps m
forall (caps :: [CapK]) (m :: MonadK).
TypeRepMap (CapElem m) -> Capabilities caps m
Capabilities (TypeRepMap (CapElem m) -> Capabilities caps m)
-> (CapabilitiesBuilder caps caps m -> TypeRepMap (CapElem m))
-> CapabilitiesBuilder caps caps m
-> Capabilities caps m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CapabilitiesBuilder caps caps m -> TypeRepMap (CapElem m)
forall (caps' :: [CapK]).
CapabilitiesBuilder caps caps' m -> TypeRepMap (CapElem m)
go
where
go ::
CapabilitiesBuilder caps caps' m ->
TypeRepMap (CapElem m)
go :: CapabilitiesBuilder caps caps' m -> TypeRepMap (CapElem m)
go (BaseCaps (Capabilities TypeRepMap (CapElem m)
caps)) = TypeRepMap (CapElem m)
caps
go (AddCap CapImpl cap icaps m
capImpl CapabilitiesBuilder caps caps m
otherCaps) =
CapElem m cap -> TypeRepMap (CapElem m) -> TypeRepMap (CapElem m)
forall k (a :: k) (f :: k -> *).
Typeable a =>
f a -> TypeRepMap f -> TypeRepMap f
TypeRepMap.insert (CapImpl cap icaps m -> CapElem m cap
forall (cap :: CapK) (icaps :: [CapK]) (m :: MonadK).
CapImpl cap icaps m -> CapElem m cap
toCapElem CapImpl cap icaps m
capImpl) (CapabilitiesBuilder caps caps m -> TypeRepMap (CapElem m)
forall (caps' :: [CapK]).
CapabilitiesBuilder caps caps' m -> TypeRepMap (CapElem m)
go CapabilitiesBuilder caps caps m
otherCaps)
type family HasCap cap caps :: Constraint where
HasCap cap (cap : _) = ()
HasCap cap (cap' : caps) = HasCap cap caps
HasCap cap '[] =
TypeError
(Text "Capability " :<>:
ShowType cap :<>:
Text " must be available")
type family HasCaps icaps caps :: Constraint where
HasCaps '[] _ = ()
HasCaps (icap : icaps) caps = (HasCap icap caps, HasCaps icaps caps)
type family HasNoCap cap caps :: Constraint where
HasNoCap cap (cap : _) =
TypeError
(Text "Capability " :<>:
ShowType cap :<>:
Text " is already present")
HasNoCap cap (cap' : caps) = HasNoCap cap caps
HasNoCap cap '[] = ()
getCap :: forall cap m caps. (Typeable cap, HasCap cap caps) => Capabilities caps m -> cap (CapsT caps m)
getCap :: Capabilities caps m -> cap (CapsT caps m)
getCap (Capabilities TypeRepMap (CapElem m)
m) =
case TypeRepMap (CapElem m) -> Maybe (CapElem m cap)
forall k (a :: k) (f :: k -> *).
Typeable a =>
TypeRepMap f -> Maybe (f a)
TypeRepMap.lookup TypeRepMap (CapElem m)
m of
Maybe (CapElem m cap)
Nothing -> String -> cap (CapsT caps m)
forall a. HasCallStack => String -> a
error String
"getCap: impossible"
Just CapElem m cap
e -> CapElem m cap -> forall (caps :: [CapK]). cap (CapsT caps m)
forall (m :: MonadK) (cap :: CapK).
CapElem m cap -> forall (caps :: [CapK]). cap (CapsT caps m)
getCapElem CapElem m cap
e
unsafeInsertCap ::
(Typeable cap, HasCaps icaps caps') =>
CapImpl cap icaps m ->
Capabilities caps m ->
Capabilities caps' m
unsafeInsertCap :: CapImpl cap icaps m -> Capabilities caps m -> Capabilities caps' m
unsafeInsertCap CapImpl cap icaps m
capImpl (Capabilities TypeRepMap (CapElem m)
caps) =
TypeRepMap (CapElem m) -> Capabilities caps' m
forall (caps :: [CapK]) (m :: MonadK).
TypeRepMap (CapElem m) -> Capabilities caps m
Capabilities (CapElem m cap -> TypeRepMap (CapElem m) -> TypeRepMap (CapElem m)
forall k (a :: k) (f :: k -> *).
Typeable a =>
f a -> TypeRepMap f -> TypeRepMap f
TypeRepMap.insert (CapImpl cap icaps m -> CapElem m cap
forall (cap :: CapK) (icaps :: [CapK]) (m :: MonadK).
CapImpl cap icaps m -> CapElem m cap
toCapElem CapImpl cap icaps m
capImpl) TypeRepMap (CapElem m)
caps)
insertCap ::
(Typeable cap, HasCaps icaps (cap : caps)) =>
CapImpl cap icaps m ->
Capabilities caps m ->
Capabilities (cap : caps) m
insertCap :: CapImpl cap icaps m
-> Capabilities caps m -> Capabilities (cap : caps) m
insertCap = CapImpl cap icaps m
-> Capabilities caps m -> Capabilities (cap : caps) m
forall (cap :: CapK) (icaps :: [CapK]) (caps' :: [CapK])
(m :: MonadK) (caps :: [CapK]).
(Typeable cap, HasCaps icaps caps') =>
CapImpl cap icaps m -> Capabilities caps m -> Capabilities caps' m
unsafeInsertCap
addCap ::
(Typeable cap, HasNoCap cap caps, HasCaps icaps (cap : caps)) =>
CapImpl cap icaps m ->
Capabilities caps m ->
Capabilities (cap : caps) m
addCap :: CapImpl cap icaps m
-> Capabilities caps m -> Capabilities (cap : caps) m
addCap CapImpl cap icaps m
capImpl Capabilities caps m
caps = CapabilitiesBuilder (cap : caps) (cap : caps) m
-> Capabilities (cap : caps) m
forall (caps :: [CapK]) (m :: MonadK).
CapabilitiesBuilder caps caps m -> Capabilities caps m
buildCaps (CapImpl cap icaps m
-> CapabilitiesBuilder (cap : caps) caps m
-> CapabilitiesBuilder (cap : caps) (cap : caps) m
forall (cap :: CapK) (icaps :: [CapK]) (allCaps :: [CapK])
(caps :: [CapK]) (m :: MonadK).
(Typeable cap, HasCaps icaps allCaps, HasNoCap cap caps) =>
CapImpl cap icaps m
-> CapabilitiesBuilder allCaps caps m
-> CapabilitiesBuilder allCaps (cap : caps) m
AddCap CapImpl cap icaps m
capImpl (CapabilitiesBuilder (cap : caps) caps m
-> CapabilitiesBuilder (cap : caps) (cap : caps) m)
-> CapabilitiesBuilder (cap : caps) caps m
-> CapabilitiesBuilder (cap : caps) (cap : caps) m
forall a b. (a -> b) -> a -> b
$ Capabilities caps m -> CapabilitiesBuilder (cap : caps) caps m
forall (caps :: [CapK]) (m :: MonadK) (allCaps :: [CapK]).
Capabilities caps m -> CapabilitiesBuilder allCaps caps m
BaseCaps Capabilities caps m
caps)
overrideCap ::
(Typeable cap, HasCap cap caps, HasCaps icaps caps) =>
CapImpl cap icaps m ->
Capabilities caps m ->
Capabilities caps m
overrideCap :: CapImpl cap icaps m -> Capabilities caps m -> Capabilities caps m
overrideCap = CapImpl cap icaps m -> Capabilities caps m -> Capabilities caps m
forall (cap :: CapK) (icaps :: [CapK]) (caps' :: [CapK])
(m :: MonadK) (caps :: [CapK]).
(Typeable cap, HasCaps icaps caps') =>
CapImpl cap icaps m -> Capabilities caps m -> Capabilities caps' m
unsafeInsertCap
adjustCap ::
forall cap caps m.
(Typeable cap, HasCap cap caps) =>
(forall caps'. cap (CapsT caps' m) -> cap (CapsT caps' m)) ->
Capabilities caps m ->
Capabilities caps m
adjustCap :: (forall (caps' :: [CapK]).
cap (CapsT caps' m) -> cap (CapsT caps' m))
-> Capabilities caps m -> Capabilities caps m
adjustCap forall (caps' :: [CapK]).
cap (CapsT caps' m) -> cap (CapsT caps' m)
f (Capabilities TypeRepMap (CapElem m)
caps) =
TypeRepMap (CapElem m) -> Capabilities caps m
forall (caps :: [CapK]) (m :: MonadK).
TypeRepMap (CapElem m) -> Capabilities caps m
Capabilities ((CapElem m cap -> CapElem m cap)
-> TypeRepMap (CapElem m) -> TypeRepMap (CapElem m)
forall k (a :: k) (f :: k -> *).
Typeable a =>
(f a -> f a) -> TypeRepMap f -> TypeRepMap f
TypeRepMap.adjust ((forall (caps' :: [CapK]).
cap (CapsT caps' m) -> cap (CapsT caps' m))
-> CapElem m cap -> CapElem m cap
forall (cap :: CapK) (m :: MonadK) (cap' :: CapK) (m' :: MonadK).
(forall (caps :: [CapK]).
cap (CapsT caps m) -> cap' (CapsT caps m'))
-> CapElem m cap -> CapElem m' cap'
overCapElem forall (caps' :: [CapK]).
cap (CapsT caps' m) -> cap (CapsT caps' m)
f) TypeRepMap (CapElem m)
caps)
withCap :: (Typeable cap, HasCap cap caps) => (cap (CapsT caps m) -> CapsT caps m a) -> CapsT caps m a
withCap :: (cap (CapsT caps m) -> CapsT caps m a) -> CapsT caps m a
withCap cap (CapsT caps m) -> CapsT caps m a
cont = (Capabilities caps m -> m a) -> CapsT caps m a
forall r (m :: MonadK) a. (r -> m a) -> ReaderT r m a
ReaderT ((Capabilities caps m -> m a) -> CapsT caps m a)
-> (Capabilities caps m -> m a) -> CapsT caps m a
forall a b. (a -> b) -> a -> b
$ \Capabilities caps m
caps -> CapsT caps m a -> Capabilities caps m -> m a
forall r (m :: MonadK) a. ReaderT r m a -> r -> m a
runReaderT (cap (CapsT caps m) -> CapsT caps m a
cont (Capabilities caps m -> cap (CapsT caps m)
forall (cap :: CapK) (m :: MonadK) (caps :: [CapK]).
(Typeable cap, HasCap cap caps) =>
Capabilities caps m -> cap (CapsT caps m)
getCap Capabilities caps m
caps)) Capabilities caps m
caps
data HasCapDecision cap caps where
HasNoCap :: HasNoCap cap caps => HasCapDecision cap caps
HasCap :: HasCap cap caps => HasCapDecision cap caps
instance Show (HasCapDecision cap caps) where
show :: HasCapDecision cap caps -> String
show HasCapDecision cap caps
HasNoCap = String
"HasNoCap"
show HasCapDecision cap caps
HasCap = String
"HasCap"
checkCap :: forall cap caps m. Typeable cap => Capabilities caps m -> HasCapDecision cap caps
checkCap :: Capabilities caps m -> HasCapDecision cap caps
checkCap (Capabilities TypeRepMap (CapElem m)
m) =
if TypeRepMap (CapElem m) -> Bool
forall k (a :: k) (f :: k -> *). Typeable a => TypeRepMap f -> Bool
TypeRepMap.member @cap TypeRepMap (CapElem m)
m
then case HasCap cap caps :~: (() :: Constraint)
forall (c :: Constraint). c :~: (() :: Constraint)
unsafeUnitConstr @(HasCap cap caps) of HasCap cap caps :~: (() :: Constraint)
Refl -> HasCapDecision cap caps
forall k (cap :: k) (caps :: [k]).
HasCap cap caps =>
HasCapDecision cap caps
HasCap
else case HasNoCap cap caps :~: (() :: Constraint)
forall (c :: Constraint). c :~: (() :: Constraint)
unsafeUnitConstr @(HasNoCap cap caps) of HasNoCap cap caps :~: (() :: Constraint)
Refl -> HasCapDecision cap caps
forall k (cap :: k) (caps :: [k]).
HasNoCap cap caps =>
HasCapDecision cap caps
HasNoCap
unsafeUnitConstr :: c :~: (() :: Constraint)
unsafeUnitConstr :: c :~: (() :: Constraint)
unsafeUnitConstr = (Any :~: Any) -> c :~: (() :: Constraint)
forall a b. a -> b
unsafeCoerce Any :~: Any
forall k (a :: k). a :~: a
Refl
newtype Context x (m :: MonadK) = Context x
class (Typeable x, HasCap (Context x) caps) => HasContext x caps
instance (Typeable x, HasCap (Context x) caps) => HasContext x caps
newContext :: forall x m. x -> CapImpl (Context x) '[] m
newContext :: x -> CapImpl (Context x) '[] m
newContext x
x = (forall (caps :: [CapK]).
HasCaps '[] caps =>
Context x (CapsT caps m))
-> CapImpl (Context x) '[] m
forall (icaps :: [CapK]) (cap :: CapK) (m :: MonadK).
WithSpine icaps =>
(forall (caps :: [CapK]). HasCaps icaps caps => cap (CapsT caps m))
-> CapImpl cap icaps m
CapImpl (x -> Context x (CapsT caps m)
forall x (m :: MonadK). x -> Context x m
Context x
x)
askContext :: (HasContext x caps, Applicative m) => CapsT caps m x
askContext :: CapsT caps m x
askContext = (Context x (CapsT caps m) -> CapsT caps m x) -> CapsT caps m x
forall (cap :: CapK) (caps :: [CapK]) (m :: MonadK) a.
(Typeable cap, HasCap cap caps) =>
(cap (CapsT caps m) -> CapsT caps m a) -> CapsT caps m a
withCap (\(Context x
x) -> x -> CapsT caps m x
forall (f :: MonadK) a. Applicative f => a -> f a
pure x
x)
localContext :: forall x caps m a. (HasContext x caps) => (x -> x) -> CapsT caps m a -> CapsT caps m a
localContext :: (x -> x) -> CapsT caps m a -> CapsT caps m a
localContext x -> x
f = (Capabilities caps m -> Capabilities caps m)
-> CapsT caps m a -> CapsT caps m a
forall r (m :: MonadK) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local ((forall (caps' :: [CapK]).
Context x (CapsT caps' m) -> Context x (CapsT caps' m))
-> Capabilities caps m -> Capabilities caps m
forall (cap :: CapK) (caps :: [CapK]) (m :: MonadK).
(Typeable cap, HasCap cap caps) =>
(forall (caps' :: [CapK]).
cap (CapsT caps' m) -> cap (CapsT caps' m))
-> Capabilities caps m -> Capabilities caps m
adjustCap @(Context x) ((x -> x) -> Context x (CapsT caps' m) -> Context x (CapsT caps' m)
coerce x -> x
f))
makeCap :: TH.Name -> TH.DecsQ
makeCap :: Name -> DecsQ
makeCap Name
capName = do
let className :: Name
className = String -> Name
TH.mkName (String
"Monad" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
TH.nameBase Name
capName)
Info
info <- Name -> Q Info
TH.reify Name
capName
([VarBangType]
vbts, [TyVarBndr]
tyVars) <-
case Info
info of
TH.TyConI (TH.DataD Cxt
_ Name
_ [TyVarBndr]
tyVars Maybe Kind
_ [TH.RecC Name
_ [VarBangType]
vbts] [DerivClause]
_) -> ([VarBangType], [TyVarBndr]) -> Q ([VarBangType], [TyVarBndr])
forall (m :: MonadK) a. Monad m => a -> m a
return ([VarBangType]
vbts, [TyVarBndr]
tyVars)
TH.TyConI (TH.NewtypeD Cxt
_ Name
_ [TyVarBndr]
tyVars Maybe Kind
_ (TH.RecC Name
_ [VarBangType]
vbts) [DerivClause]
_) -> ([VarBangType], [TyVarBndr]) -> Q ([VarBangType], [TyVarBndr])
forall (m :: MonadK) a. Monad m => a -> m a
return ([VarBangType]
vbts, [TyVarBndr]
tyVars)
Info
_ -> String -> Q ([VarBangType], [TyVarBndr])
forall (m :: MonadK) a. MonadFail m => String -> m a
fail String
"Capabilities must be single-constructor record types"
(TyVarBndr
mVar, [TyVarBndr]
extraTyVars) <-
case [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
reverse [TyVarBndr]
tyVars of
(TyVarBndr
tv:[TyVarBndr]
tvs) -> (TyVarBndr, [TyVarBndr]) -> Q (TyVarBndr, [TyVarBndr])
forall (m :: MonadK) a. Monad m => a -> m a
return (TyVarBndr
tv, [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
reverse [TyVarBndr]
tvs)
[TyVarBndr]
_ -> String -> Q (TyVarBndr, [TyVarBndr])
forall (m :: MonadK) a. MonadFail m => String -> m a
fail String
"Capability must have a monadic parameter"
let
parametrize :: Name -> TypeQ
parametrize Name
name = (TypeQ -> TypeQ -> TypeQ) -> [TypeQ] -> TypeQ
forall a. (a -> a -> a) -> [a] -> a
foldl1' TypeQ -> TypeQ -> TypeQ
TH.appT (Name -> TypeQ
TH.conT Name
name TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
: (TyVarBndr -> TypeQ) -> [TyVarBndr] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> TypeQ
tyVarBndrT [TyVarBndr]
extraTyVars)
capType :: TypeQ
capType = Name -> TypeQ
parametrize Name
capName
classType :: TypeQ
classType = Name -> TypeQ
parametrize Name
className
[(Name, Name, Kind, Cxt)]
methodSpecs <- [VarBangType]
-> (VarBangType -> Q (Name, Name, Kind, Cxt))
-> Q [(Name, Name, Kind, Cxt)]
forall (t :: MonadK) (f :: MonadK) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [VarBangType]
vbts ((VarBangType -> Q (Name, Name, Kind, Cxt))
-> Q [(Name, Name, Kind, Cxt)])
-> (VarBangType -> Q (Name, Name, Kind, Cxt))
-> Q [(Name, Name, Kind, Cxt)]
forall a b. (a -> b) -> a -> b
$ \(Name
fieldName, Bang
_, Kind
ty) -> do
Name
methodName <-
case Name -> String
TH.nameBase Name
fieldName of
(Char
'_':String
methodName) -> Name -> Q Name
forall (m :: MonadK) a. Monad m => a -> m a
return (Name -> Q Name) -> Name -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName String
methodName
String
_ -> String -> Q Name
forall (m :: MonadK) a. MonadFail m => String -> m a
fail String
"Capability method names must start with underscores"
Cxt
tyArgList <-
let
toArgList :: Kind -> Cxt
toArgList (Kind
TH.ArrowT `TH.AppT` Kind
a `TH.AppT` Kind
b) = Kind
aKind -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:Kind -> Cxt
toArgList Kind
b
toArgList (TH.ForallT [TyVarBndr]
_ Cxt
_ Kind
a) = Kind -> Cxt
toArgList Kind
a
toArgList Kind
_ = []
in
Cxt -> Q Cxt
forall (m :: MonadK) a. Monad m => a -> m a
return (Cxt -> Q Cxt) -> Cxt -> Q Cxt
forall a b. (a -> b) -> a -> b
$ Kind -> Cxt
toArgList Kind
ty
(Name, Name, Kind, Cxt) -> Q (Name, Name, Kind, Cxt)
forall (m :: MonadK) a. Monad m => a -> m a
return (Name
methodName, Name
fieldName, Kind
ty, Cxt
tyArgList)
[Dec]
class_decs <- (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> DecsQ
forall (f :: MonadK) a b. Functor f => (a -> b) -> f a -> f b
<$>
Q Cxt -> Name -> [TyVarBndr] -> [FunDep] -> [Q Dec] -> Q Dec
TH.classD
([TypeQ] -> Q Cxt
TH.cxt [])
Name
className
[TyVarBndr]
tyVars
[]
[ Name -> TypeQ -> Q Dec
TH.sigD Name
methodName (Kind -> TypeQ
forall (m :: MonadK) a. Monad m => a -> m a
return Kind
ty)
| (Name
methodName, Name
_, Kind
ty, Cxt
_) <- [(Name, Name, Kind, Cxt)]
methodSpecs
]
let
methodDec :: Name -> Name -> Cxt -> Q Dec
methodDec Name
methodName Name
fieldName Cxt
tyArgList = do
Name -> [ClauseQ] -> Q Dec
TH.funD Name
methodName
[do
[Name]
argNames <- do
[(Int, Kind)] -> ((Int, Kind) -> Q Name) -> Q [Name]
forall (t :: MonadK) (f :: MonadK) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([Int] -> Cxt -> [(Int, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] Cxt
tyArgList) (((Int, Kind) -> Q Name) -> Q [Name])
-> ((Int, Kind) -> Q Name) -> Q [Name]
forall a b. (a -> b) -> a -> b
$ \(Int
i, Kind
_tyArg) ->
String -> Q Name
TH.newName (String
"arg" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
i::Int))
let
pats :: [PatQ]
pats = (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
TH.varP [Name]
argNames
args :: [ExpQ]
args = (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
TH.varE [Name]
argNames
body :: BodyQ
body = ExpQ -> BodyQ
TH.normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ do
Name
lamName <- String -> Q Name
TH.newName String
"cap"
ExpQ -> ExpQ -> ExpQ
TH.appE (ExpQ -> TypeQ -> ExpQ
TH.appTypeE [e|withCap|] TypeQ
capType) (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
PatQ -> ExpQ -> ExpQ
TH.lam1E (Name -> PatQ
TH.varP Name
lamName) (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
(ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall a. (a -> a -> a) -> [a] -> a
foldl1' ExpQ -> ExpQ -> ExpQ
TH.appE (Name -> ExpQ
TH.varE Name
fieldName ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: Name -> ExpQ
TH.varE Name
lamName ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: [ExpQ]
args)
[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
TH.clause [PatQ]
pats BodyQ
body []
]
[Dec]
instance_decs <- (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> DecsQ
forall (f :: MonadK) a b. Functor f => (a -> b) -> f a -> f b
<$> do
Name
rVar <- String -> Q Name
TH.newName String
"r"
Name
capsVar <- String -> Q Name
TH.newName String
"caps"
let typeableConstraints :: [TypeQ]
typeableConstraints = [ [t|Typeable $(tyVarBndrT v)|] | TyVarBndr
v <- [TyVarBndr]
extraTyVars ]
Q Cxt -> TypeQ -> [Q Dec] -> Q Dec
TH.instanceD
([TypeQ] -> Q Cxt
TH.cxt ([TypeQ] -> Q Cxt) -> [TypeQ] -> Q Cxt
forall a b. (a -> b) -> a -> b
$
[ [t|HasCap $capType $(TH.varT capsVar)|],
[t| $(TH.varT rVar) ~ Capabilities $(TH.varT capsVar) $(tyVarBndrT' mVar) |]
] [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++ [TypeQ]
typeableConstraints)
[t| $classType (ReaderT $(TH.varT rVar) $(tyVarBndrT' mVar)) |]
[ Name -> Name -> Cxt -> Q Dec
methodDec Name
methodName Name
fieldName Cxt
tyArgList
| (Name
methodName, Name
fieldName, Kind
_, Cxt
tyArgList) <- [(Name, Name, Kind, Cxt)]
methodSpecs
]
[Dec] -> DecsQ
forall (m :: MonadK) a. Monad m => a -> m a
return ([Dec]
class_decs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
instance_decs)
where
tyVarBndrT :: TyVarBndr -> TypeQ
tyVarBndrT (TH.PlainTV Name
name) = Name -> TypeQ
TH.varT Name
name
tyVarBndrT (TH.KindedTV Name
name Kind
k) = TypeQ -> Kind -> TypeQ
TH.sigT (Name -> TypeQ
TH.varT Name
name) Kind
k
tyVarBndrT' :: TyVarBndr -> TypeQ
tyVarBndrT' (TH.PlainTV Name
name) = Name -> TypeQ
TH.varT Name
name
tyVarBndrT' (TH.KindedTV Name
name Kind
_) = Name -> TypeQ
TH.varT Name
name