{-# LANGUAGE UndecidableInstances #-}
module Control.Apply.Unordered.Mono
(
applyByType
, reorderArgs
, (?)
, applyByUniqueType
, reorderUniqueArgs
, (?!)
, MatchArgResult(..)
, MatchFirstArg
, HasAMatch
, ApplyByType(ApplyByTypeResult)
, HasUniqueMatch
, CheckAmbiguousMatch
, HasArgResult(..)
, HasArg
, ReorderArgs
, ReorderUniqueArgs
) where
import Data.Proxy (Proxy(..))
import GHC.TypeLits (TypeError, ErrorMessage(..))
applyByType
:: forall a f matches.
( matches ~ HasAMatch a f f
, ApplyByType matches a f
)
=> f -> a -> ApplyByTypeResult matches a f
applyByType :: f -> a -> ApplyByTypeResult matches a f
applyByType = Proxy matches -> f -> a -> ApplyByTypeResult matches a f
forall (matches :: MatchArgResult) a f.
ApplyByType matches a f =>
Proxy matches -> f -> a -> ApplyByTypeResult matches a f
applyByTypeImpl (Proxy matches
forall k (t :: k). Proxy t
Proxy :: Proxy matches)
{-# INLINE applyByType #-}
infixl 1 ?
(?)
:: forall a f matches.
( matches ~ HasAMatch a f f
, ApplyByType matches a f
)
=> f -> a -> ApplyByTypeResult matches a f
? :: f -> a -> ApplyByTypeResult matches a f
(?) = f -> a -> ApplyByTypeResult matches a f
forall a f (matches :: MatchArgResult).
(matches ~ HasAMatch a f f, ApplyByType matches a f) =>
f -> a -> ApplyByTypeResult matches a f
applyByType
{-# INLINE (?) #-}
applyByUniqueType
:: forall a f matches.
( matches ~ HasUniqueMatch a f f
, ApplyByType matches a f
)
=> f -> a -> ApplyByTypeResult matches a f
applyByUniqueType :: f -> a -> ApplyByTypeResult matches a f
applyByUniqueType = Proxy matches -> f -> a -> ApplyByTypeResult matches a f
forall (matches :: MatchArgResult) a f.
ApplyByType matches a f =>
Proxy matches -> f -> a -> ApplyByTypeResult matches a f
applyByTypeImpl (Proxy matches
forall k (t :: k). Proxy t
Proxy :: Proxy matches)
{-# INLINE applyByUniqueType #-}
infixl 1 ?!
(?!)
:: forall a f matches.
( matches ~ HasUniqueMatch a f f
, ApplyByType matches a f
)
=> f -> a -> ApplyByTypeResult matches a f
?! :: f -> a -> ApplyByTypeResult matches a f
(?!) = f -> a -> ApplyByTypeResult matches a f
forall a f (matches :: MatchArgResult).
(matches ~ HasUniqueMatch a f f, ApplyByType matches a f) =>
f -> a -> ApplyByTypeResult matches a f
applyByUniqueType
{-# INLINE (?!) #-}
reorderArgs :: forall f g. ReorderArgs (HasArg f) f g => f -> g
reorderArgs :: f -> g
reorderArgs = Proxy (HasArg f) -> f -> g
forall (fHasArg :: HasArgResult) f g.
ReorderArgs fHasArg f g =>
Proxy fHasArg -> f -> g
reorderArgsImpl (Proxy (HasArg f)
forall k (t :: k). Proxy t
Proxy :: Proxy (HasArg f))
{-# INLINE reorderArgs #-}
reorderUniqueArgs :: forall f g. ReorderUniqueArgs (HasArg f) f g => f -> g
reorderUniqueArgs :: f -> g
reorderUniqueArgs = Proxy (HasArg f) -> f -> g
forall (fHasArg :: HasArgResult) f g.
ReorderUniqueArgs fHasArg f g =>
Proxy fHasArg -> f -> g
reorderUniqueArgsImpl (Proxy (HasArg f)
forall k (t :: k). Proxy t
Proxy :: Proxy (HasArg f))
{-# INLINE reorderUniqueArgs #-}
data MatchArgResult
= Matches
| Doesn'tMatch
| NoArgToMatch
type family MatchFirstArg a f :: MatchArgResult where
MatchFirstArg a (a -> _) = 'Matches
MatchFirstArg a (b -> _) = 'Doesn'tMatch
MatchFirstArg _ _ = 'NoArgToMatch
type family HasAMatch a f f0 :: MatchArgResult where
HasAMatch a (a -> _) f0 = MatchFirstArg a f0
HasAMatch a (b -> r) f0 = HasAMatch a r f0
HasAMatch a _ f0 = TypeError (NoMatchErrorMsg a f0)
class ApplyByType (matches :: MatchArgResult) a f where
type ApplyByTypeResult matches a f
applyByTypeImpl
:: Proxy matches
-> f
-> a
-> ApplyByTypeResult matches a f
instance ApplyByType 'Matches a (a -> r) where
type ApplyByTypeResult 'Matches a (a -> r) = r
applyByTypeImpl :: Proxy 'Matches
-> (a -> r) -> a -> ApplyByTypeResult 'Matches a (a -> r)
applyByTypeImpl Proxy 'Matches
_ a -> r
f a
x = a -> r
f a
x
{-# INLINE applyByTypeImpl #-}
instance ApplyByType (MatchFirstArg a r) a r
=> ApplyByType 'Doesn'tMatch a (b -> r) where
type ApplyByTypeResult 'Doesn'tMatch a (b -> r) =
b -> ApplyByTypeResult (MatchFirstArg a r) a r
applyByTypeImpl :: Proxy 'Doesn'tMatch
-> (b -> r) -> a -> ApplyByTypeResult 'Doesn'tMatch a (b -> r)
applyByTypeImpl Proxy 'Doesn'tMatch
_ b -> r
f a
y =
\b
x -> Proxy (MatchFirstArg a r)
-> r -> a -> ApplyByTypeResult (MatchFirstArg a r) a r
forall (matches :: MatchArgResult) a f.
ApplyByType matches a f =>
Proxy matches -> f -> a -> ApplyByTypeResult matches a f
applyByTypeImpl (Proxy (MatchFirstArg a r)
forall k (t :: k). Proxy t
Proxy :: Proxy (MatchFirstArg a r)) (b -> r
f b
x) a
y
{-# INLINE applyByTypeImpl #-}
instance TypeError (NoMatchForResultErrorMsg a r)
=> ApplyByType 'NoArgToMatch a r where
type ApplyByTypeResult 'NoArgToMatch a r =
TypeError (NoMatchForResultErrorMsg a r)
applyByTypeImpl :: Proxy 'NoArgToMatch
-> r -> a -> ApplyByTypeResult 'NoArgToMatch a r
applyByTypeImpl = [Char] -> Proxy 'NoArgToMatch -> r -> a -> (TypeError ...)
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"
type family HasUniqueMatch a f f0 :: MatchArgResult where
HasUniqueMatch a (a -> r) f0 = CheckAmbiguousMatch a r f0
HasUniqueMatch a (b -> r) f0 = HasUniqueMatch a r f0
HasUniqueMatch a _ f0 = TypeError (NoMatchErrorMsg a f0)
type family CheckAmbiguousMatch a f f0 :: MatchArgResult where
CheckAmbiguousMatch a (a -> _) f0 = TypeError (AmbiguousMatchErrorMsg a f0)
CheckAmbiguousMatch a (b -> r) f0 = CheckAmbiguousMatch a r f0
CheckAmbiguousMatch a _ f0 = MatchFirstArg a f0
data HasArgResult
= ArgPresent
| NoArg
type family HasArg f :: HasArgResult where
HasArg (_ -> _) = 'ArgPresent
HasArg _ = 'NoArg
class ReorderArgs (fHasArg :: HasArgResult) f g where
reorderArgsImpl :: Proxy fHasArg -> f -> g
instance
( matches ~ HasAMatch a (b -> y) (b -> y)
, result ~ ApplyByTypeResult matches a (b -> y)
, ApplyByType matches a (b -> y)
, ReorderArgs (HasArg result) result x
) => ReorderArgs 'ArgPresent (b -> y) (a -> x) where
reorderArgsImpl :: Proxy 'ArgPresent -> (b -> y) -> a -> x
reorderArgsImpl Proxy 'ArgPresent
_ b -> y
f a
x =
Proxy (HasArg result) -> result -> x
forall (fHasArg :: HasArgResult) f g.
ReorderArgs fHasArg f g =>
Proxy fHasArg -> f -> g
reorderArgsImpl (Proxy (HasArg result)
forall k (t :: k). Proxy t
Proxy :: Proxy (HasArg result)) (result -> x) -> result -> x
forall a b. (a -> b) -> a -> b
$
(b -> y) -> a -> ApplyByTypeResult matches a (b -> y)
forall a f (matches :: MatchArgResult).
(matches ~ HasAMatch a f f, ApplyByType matches a f) =>
f -> a -> ApplyByTypeResult matches a f
applyByType b -> y
f a
x
{-# INLINE reorderArgsImpl #-}
instance r1 ~ r2 => ReorderArgs 'NoArg r1 r2 where
reorderArgsImpl :: Proxy 'NoArg -> r1 -> r2
reorderArgsImpl Proxy 'NoArg
_ r1
f = r1
r2
f
{-# INLINE reorderArgsImpl #-}
class ReorderUniqueArgs (fHasArg :: HasArgResult) f g where
reorderUniqueArgsImpl :: Proxy fHasArg -> f -> g
instance
( matches ~ HasUniqueMatch a (b -> y) (b -> y)
, result ~ ApplyByTypeResult matches a (b -> y)
, ApplyByType matches a (b -> y)
, ReorderUniqueArgs (HasArg result) result x
) => ReorderUniqueArgs 'ArgPresent (b -> y) (a -> x) where
reorderUniqueArgsImpl :: Proxy 'ArgPresent -> (b -> y) -> a -> x
reorderUniqueArgsImpl Proxy 'ArgPresent
_ b -> y
f a
x =
Proxy (HasArg result) -> result -> x
forall (fHasArg :: HasArgResult) f g.
ReorderUniqueArgs fHasArg f g =>
Proxy fHasArg -> f -> g
reorderUniqueArgsImpl (Proxy (HasArg result)
forall k (t :: k). Proxy t
Proxy :: Proxy (HasArg result)) (result -> x) -> result -> x
forall a b. (a -> b) -> a -> b
$
(b -> y) -> a -> ApplyByTypeResult matches a (b -> y)
forall a f (matches :: MatchArgResult).
(matches ~ HasUniqueMatch a f f, ApplyByType matches a f) =>
f -> a -> ApplyByTypeResult matches a f
applyByUniqueType b -> y
f a
x
{-# INLINE reorderUniqueArgsImpl #-}
instance r1 ~ r2 => ReorderUniqueArgs 'NoArg r1 r2 where
reorderUniqueArgsImpl :: Proxy 'NoArg -> r1 -> r2
reorderUniqueArgsImpl Proxy 'NoArg
_ r1
f = r1
r2
f
{-# INLINE reorderUniqueArgsImpl #-}
type NoMatchErrorMsg a f =
'Text "Parameter type " ':$$:
'Text " " ':<>: 'ShowType a ':$$:
'Text "does not occur in the arguments of the function type " ':$$:
'Text " " ':<>: 'ShowType f ':$$:
'Text "and so cannot be applied via type directed application."
type NoMatchForResultErrorMsg a r =
'Text "Parameter type " ':$$:
'Text " " ':<>: 'ShowType a ':$$:
'Text "does not occur in the arguments of the function that returns " ':$$:
'Text " " ':<>: 'ShowType r ':$$:
'Text "and so cannot be applied via type directed application."
type AmbiguousMatchErrorMsg a f =
'Text "Parameter type " ':$$:
'Text " " :<>: 'ShowType a ':<>:
'Text " occurs multiple times in the arguments of the function type " ':$$:
'Text " " ':<>: 'ShowType f ':$$:
'Text "and so cannot be applied via unique type directed application."