{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- |
-- Module : Test.Method.Dynamic
-- Description:
-- License: BSD-3
-- Maintainer: autotaker@gmail.com
-- Stability: experimental
module Test.Method.Dynamic
  ( DynamicShow,
    Dynamic,
    castMethod,
    dynArg,
    DynamicLike (..),
    FromDyn (..),
    ToDyn (..),
    Typeable,
  )
where

import Control.Method (Method (Args, Base, Ret, curryMethod, uncurryMethod))
import Control.Method.Internal (type (:*))
import Data.Dynamic (Dynamic)
import qualified Data.Dynamic as D
import Data.Typeable (Proxy (Proxy), Typeable, typeRep)
import GHC.Generics
  ( Generic (Rep, from, to),
    K1 (K1),
    M1 (M1),
    U1 (U1),
    type (:*:) ((:*:)),
    type (:+:) (L1, R1),
  )
import Test.Method.Matcher (Matcher)

-- | Dynamic value whose content is showable.
-- Using this type instead of 'Dynamic' is recommended because it gives better error messages.
data DynamicShow = DynamicShow !Dynamic String

instance Show DynamicShow where
  show :: DynamicShow -> String
show (DynamicShow Dynamic
v String
s) = String
"<<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeTypeRep -> String
forall a. Show a => a -> String
show (Dynamic -> SomeTypeRep
D.dynTypeRep Dynamic
v) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">>"

-- | @FromDyn a b@ provides a function to convert type @a@ to type @b@,
-- where @b@ is a type whose dynamic type occurences are replaced by concrete types.
--
-- For example: @FromDyn (Int, Dynamic, Maybe Dynamic) (Int, Bool, Maybe String)@
class FromDyn a b where
  -- | convert dynamic value to specified type. It thows runtime exception if
  -- the dynamic value does not have specified type.
  fromDyn :: a -> b
  default fromDyn :: (Generic a, Generic b, FromDyn' (Rep a) (Rep b)) => a -> b
  fromDyn = Rep b Any -> b
forall a x. Generic a => Rep a x -> a
to (Rep b Any -> b) -> (a -> Rep b Any) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> Rep b Any
forall (f :: * -> *) (g :: * -> *) a. FromDyn' f g => f a -> g a
fromDyn' (Rep a Any -> Rep b Any) -> (a -> Rep a Any) -> a -> Rep b Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

-- | @ToDyn a b@ provides a function to convert type @b@ to type @a@, where
-- @b@ is a type whose dynamic type occurences are replaced by concrete types.
--
-- For example: @ToDyn (Int, Dynamic, Maybe Dynamic) (Int, Bool, Maybe String)@
class ToDyn a b where
  -- | convert value of specified type to dynamic value
  toDyn :: b -> a
  default toDyn :: (Generic a, Generic b, ToDyn' (Rep a) (Rep b)) => b -> a
  toDyn = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> (b -> Rep a Any) -> b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep b Any -> Rep a Any
forall (f :: * -> *) (g :: * -> *) a. ToDyn' f g => g a -> f a
toDyn' (Rep b Any -> Rep a Any) -> (b -> Rep b Any) -> b -> Rep a Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Rep b Any
forall a x. Generic a => a -> Rep a x
from

class FromDyn' f g where
  fromDyn' :: f a -> g a

class ToDyn' f g where
  toDyn' :: g a -> f a

instance (FromDyn' f f', FromDyn' g g') => FromDyn' (f :+: g) (f' :+: g') where
  {-# INLINE fromDyn' #-}
  fromDyn' :: (:+:) f g a -> (:+:) f' g' a
fromDyn' (L1 f a
a) = f' a -> (:+:) f' g' a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f a -> f' a
forall (f :: * -> *) (g :: * -> *) a. FromDyn' f g => f a -> g a
fromDyn' f a
a)
  fromDyn' (R1 g a
b) = g' a -> (:+:) f' g' a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g a -> g' a
forall (f :: * -> *) (g :: * -> *) a. FromDyn' f g => f a -> g a
fromDyn' g a
b)

instance (FromDyn' f f', FromDyn' g g') => FromDyn' (f :*: g) (f' :*: g') where
  {-# INLINE fromDyn' #-}
  fromDyn' :: (:*:) f g a -> (:*:) f' g' a
fromDyn' (f a
a :*: g a
b) = f a -> f' a
forall (f :: * -> *) (g :: * -> *) a. FromDyn' f g => f a -> g a
fromDyn' f a
a f' a -> g' a -> (:*:) f' g' a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a -> g' a
forall (f :: * -> *) (g :: * -> *) a. FromDyn' f g => f a -> g a
fromDyn' g a
b

instance (FromDyn a a') => FromDyn' (K1 i a) (K1 i a') where
  {-# INLINE fromDyn' #-}
  fromDyn' :: K1 i a a -> K1 i a' a
fromDyn' (K1 a
a) = a' -> K1 i a' a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> a'
forall a b. FromDyn a b => a -> b
fromDyn a
a)

instance FromDyn' U1 U1 where
  {-# INLINE fromDyn' #-}
  fromDyn' :: U1 a -> U1 a
fromDyn' U1 a
_ = U1 a
forall k (p :: k). U1 p
U1

instance (FromDyn' f f') => FromDyn' (M1 i t f) (M1 i t f') where
  {-# INLINE fromDyn' #-}
  fromDyn' :: M1 i t f a -> M1 i t f' a
fromDyn' (M1 f a
a) = f' a -> M1 i t f' a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> f' a
forall (f :: * -> *) (g :: * -> *) a. FromDyn' f g => f a -> g a
fromDyn' f a
a)

instance Typeable a => FromDyn Dynamic a where
  fromDyn :: Dynamic -> a
fromDyn = Dynamic -> a
forall a d. (Typeable a, DynamicLike d, Show d) => d -> a
fromDynamic

instance (Typeable a, Show a) => FromDyn DynamicShow a where
  fromDyn :: DynamicShow -> a
fromDyn = DynamicShow -> a
forall a d. (Typeable a, DynamicLike d, Show d) => d -> a
fromDynamic

instance {-# INCOHERENT #-} FromDyn a a where
  {-# INLINE fromDyn #-}
  fromDyn :: a -> a
fromDyn = a -> a
forall a. a -> a
id

instance (ToDyn' f f', ToDyn' g g') => ToDyn' (f :+: g) (f' :+: g') where
  {-# INLINE toDyn' #-}
  toDyn' :: (:+:) f' g' a -> (:+:) f g a
toDyn' (L1 f' a
a) = f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f' a -> f a
forall (f :: * -> *) (g :: * -> *) a. ToDyn' f g => g a -> f a
toDyn' f' a
a)
  toDyn' (R1 g' a
b) = g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g' a -> g a
forall (f :: * -> *) (g :: * -> *) a. ToDyn' f g => g a -> f a
toDyn' g' a
b)

instance (ToDyn' f f', ToDyn' g g') => ToDyn' (f :*: g) (f' :*: g') where
  {-# INLINE toDyn' #-}
  toDyn' :: (:*:) f' g' a -> (:*:) f g a
toDyn' (f' a
a :*: g' a
b) = f' a -> f a
forall (f :: * -> *) (g :: * -> *) a. ToDyn' f g => g a -> f a
toDyn' f' a
a f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g' a -> g a
forall (f :: * -> *) (g :: * -> *) a. ToDyn' f g => g a -> f a
toDyn' g' a
b

instance (ToDyn a a') => ToDyn' (K1 i a) (K1 i a') where
  {-# INLINE toDyn' #-}
  toDyn' :: K1 i a' a -> K1 i a a
toDyn' (K1 a'
a) = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a' -> a
forall a b. ToDyn a b => b -> a
toDyn a'
a)

instance ToDyn' U1 U1 where
  {-# INLINE toDyn' #-}
  toDyn' :: U1 a -> U1 a
toDyn' U1 a
_ = U1 a
forall k (p :: k). U1 p
U1

instance (ToDyn' f f') => ToDyn' (M1 i t f) (M1 i t f') where
  {-# INLINE toDyn' #-}
  toDyn' :: M1 i t f' a -> M1 i t f a
toDyn' (M1 f' a
a) = f a -> M1 i t f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f' a -> f a
forall (f :: * -> *) (g :: * -> *) a. ToDyn' f g => g a -> f a
toDyn' f' a
a)

instance Typeable a => ToDyn Dynamic a where
  toDyn :: a -> Dynamic
toDyn = a -> Dynamic
forall a. Typeable a => a -> Dynamic
D.toDyn

instance (Typeable a, Show a) => ToDyn DynamicShow a where
  toDyn :: a -> DynamicShow
toDyn = a -> DynamicShow
forall a. (Typeable a, Show a) => a -> DynamicShow
toDynamicShow

instance {-# INCOHERENT #-} ToDyn a a where
  {-# INLINE toDyn #-}
  toDyn :: a -> a
toDyn = a -> a
forall a. a -> a
id

instance (FromDyn a a', ToDyn b b') => ToDyn (a -> b) (a' -> b') where
  toDyn :: (a' -> b') -> a -> b
toDyn a' -> b'
f a
a = b' -> b
forall a b. ToDyn a b => b -> a
toDyn (b' -> b) -> b' -> b
forall a b. (a -> b) -> a -> b
$ a' -> b'
f (a -> a'
forall a b. FromDyn a b => a -> b
fromDyn a
a)

instance (ToDyn a a', FromDyn b b') => FromDyn (a -> b) (a' -> b') where
  fromDyn :: (a -> b) -> a' -> b'
fromDyn a -> b
f a'
a = b -> b'
forall a b. FromDyn a b => a -> b
fromDyn (b -> b') -> b -> b'
forall a b. (a -> b) -> a -> b
$ a -> b
f (a' -> a
forall a b. ToDyn a b => b -> a
toDyn a'
a)

instance (FromDyn a b, FromDyn c d) => FromDyn (a :* c) (b :* d)

instance (ToDyn a b, ToDyn c d) => ToDyn (a :* c) (b :* d)

instance (FromDyn a b) => FromDyn [a] [b]

instance (ToDyn a b) => ToDyn [a] [b]

instance (FromDyn a b) => FromDyn (Maybe a) (Maybe b)

instance (ToDyn a b) => ToDyn (Maybe a) (Maybe b)

instance (FromDyn a a', FromDyn b b') => FromDyn (Either a b) (Either a' b')

instance (ToDyn a a', ToDyn b b') => ToDyn (Either a b) (Either a' b')

instance (FromDyn a a', FromDyn b b') => FromDyn (a, b) (a', b')

instance (ToDyn a a', ToDyn b b') => ToDyn (a, b) (a', b')

instance (FromDyn a a', FromDyn b b', FromDyn c c') => FromDyn (a, b, c) (a', b', c')

instance (ToDyn a a', ToDyn b b', ToDyn c c') => ToDyn (a, b, c) (a', b', c')

instance (FromDyn a a', FromDyn b b', FromDyn c c', FromDyn d d') => FromDyn (a, b, c, d) (a', b', c', d')

instance (ToDyn a a', ToDyn b b', ToDyn c c', ToDyn d d') => ToDyn (a, b, c, d) (a', b', c', d')

instance (FromDyn a a', FromDyn b b', FromDyn c c', FromDyn d d', FromDyn e e') => FromDyn (a, b, c, d, e) (a', b', c', d', e')

instance (ToDyn a a', ToDyn b b', ToDyn c c', ToDyn d d', ToDyn e e') => ToDyn (a, b, c, d, e) (a', b', c', d', e')

instance (FromDyn a a', FromDyn b b', FromDyn c c', FromDyn d d', FromDyn e e', FromDyn f f') => FromDyn (a, b, c, d, e, f) (a', b', c', d', e', f')

instance (ToDyn a a', ToDyn b b', ToDyn c c', ToDyn d d', ToDyn e e', ToDyn f f') => ToDyn (a, b, c, d, e, f) (a', b', c', d', e', f')

instance (FromDyn a a', FromDyn b b', FromDyn c c', FromDyn d d', FromDyn e e', FromDyn f f', FromDyn g g') => FromDyn (a, b, c, d, e, f, g) (a', b', c', d', e', f', g')

instance (ToDyn a a', ToDyn b b', ToDyn c c', ToDyn d d', ToDyn e e', ToDyn f f', ToDyn g g') => ToDyn (a, b, c, d, e, f, g) (a', b', c', d', e', f', g')

-- | convert a dynamically-typed method to a polymorphic method.
--
--   @
--   fDyn :: String -> DynamicShow -> Dynamic -> IO [DynamicShow]
--   fDyn = ...
--   fPoly :: (Typeable a, Show a, Typeable b, Typeable c, Show c) => String -> a -> b -> IO [c]
--   fPoly = castMethod fDyn
--   @
castMethod ::
  ( ToDyn (Args method) (Args method'),
    FromDyn (Ret method) (Ret method'),
    Method method,
    Method method',
    Base method ~ Base method'
  ) =>
  method ->
  method'
castMethod :: method -> method'
castMethod method
method = (Args method' -> Base method' (Ret method')) -> method'
forall method.
Method method =>
(Args method -> Base method (Ret method)) -> method
curryMethod ((Args method' -> Base method' (Ret method')) -> method')
-> (Args method' -> Base method' (Ret method')) -> method'
forall a b. (a -> b) -> a -> b
$ \Args method'
args ->
  Ret method -> Ret method'
forall a b. FromDyn a b => a -> b
fromDyn (Ret method -> Ret method')
-> Base method' (Ret method) -> Base method' (Ret method')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> method -> Args method -> Base method (Ret method)
forall method.
Method method =>
method -> Args method -> Base method (Ret method)
uncurryMethod method
method (Args method' -> Args method
forall a b. ToDyn a b => b -> a
toDyn Args method'
args)
{-# INLINE [1] castMethod #-}

{-# RULES
"castMethod/id" castMethod = id
  #-}

fromDynamic :: forall a d. (Typeable a, DynamicLike d, Show d) => d -> a
fromDynamic :: d -> a
fromDynamic d
v =
  Dynamic -> a -> a
forall a. Typeable a => Dynamic -> a -> a
D.fromDyn (d -> Dynamic
forall a. DynamicLike a => a -> Dynamic
asDyn d
v) (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$
    String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"cannot cast " String -> ShowS
forall a. [a] -> [a] -> [a]
++ d -> String
forall a. Show a => a -> String
show d
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeTypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))

toDynamicShow :: (Typeable a, Show a) => a -> DynamicShow
toDynamicShow :: a -> DynamicShow
toDynamicShow a
a = Dynamic -> String -> DynamicShow
DynamicShow (a -> Dynamic
forall a. Typeable a => a -> Dynamic
D.toDyn a
a) (a -> String
forall a. Show a => a -> String
show a
a)

-- | Generalizes 'Dynamic' and 'DynamicShow'
class DynamicLike a where
  asDyn :: a -> Dynamic

instance DynamicLike Dynamic where
  asDyn :: Dynamic -> Dynamic
asDyn = Dynamic -> Dynamic
forall a. a -> a
id

instance DynamicLike DynamicShow where
  asDyn :: DynamicShow -> Dynamic
asDyn (DynamicShow Dynamic
a String
_) = Dynamic
a

-- | Convert given matcher to dynamic matcher. The dynamic matcher
-- matches a dynamic value only if the value has the type of given matcher.
dynArg :: (Typeable a, DynamicLike b) => Matcher a -> Matcher b
dynArg :: Matcher a -> Matcher b
dynArg Matcher a
matcher b
dv =
  Bool -> Matcher a -> Maybe a -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Matcher a
matcher (Maybe a -> Bool) -> Maybe a -> Bool
forall a b. (a -> b) -> a -> b
$ Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
D.fromDynamic (Dynamic -> Maybe a) -> Dynamic -> Maybe a
forall a b. (a -> b) -> a -> b
$ b -> Dynamic
forall a. DynamicLike a => a -> Dynamic
asDyn b
dv