-- | Reimplementation of Dynamic that supports dynBind
--
-- We don't have access to the internal representation of Dynamic, otherwise
-- we would not have to redefine it completely. Note that we use this only
-- internally, so the incompatibility with "our" Dynamic from the standard 
-- Dynamic is not important.
{-# LANGUAGE MagicHash #-}
module Control.Distributed.Process.Internal.Dynamic 
  ( Dynamic(..)
  , toDyn
  , fromDyn
  , fromDynamic
  , dynTypeRep
  , dynApply
  , dynApp
  , dynBind
  , dynBind'
  , dynKleisli
  , GHC.unsafeCoerce#
  ) where

import Data.Typeable 
  ( Typeable
  , TypeRep
  , typeOf
  , funResultTy
  , TyCon
  , splitTyConApp
  , mkFunTy
  )
import Data.Typeable.Internal (funTc)
import qualified GHC.Prim as GHC (Any, unsafeCoerce#)
import Data.Maybe (fromMaybe)

data Dynamic = Dynamic TypeRep GHC.Any
  deriving Typeable

toDyn :: Typeable a => a -> Dynamic
toDyn x = Dynamic (typeOf x) (GHC.unsafeCoerce# x)

fromDyn :: Typeable a => Dynamic -> a -> a
fromDyn (Dynamic rep val) a =
  if rep == typeOf a 
    then GHC.unsafeCoerce# val
    else a

fromDynamic :: forall a. Typeable a => Dynamic -> Maybe a
fromDynamic (Dynamic rep val) = 
  if rep == typeOf (undefined :: a)
    then Just (GHC.unsafeCoerce# val)
    else Nothing

dynTypeRep :: Dynamic -> TypeRep
dynTypeRep (Dynamic t _) = t

instance Show Dynamic where
  show = show . dynTypeRep

dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
dynApply (Dynamic t1 f) (Dynamic t2 x) =
  case funResultTy t1 t2 of
    Just t3 -> Just (Dynamic t3 (GHC.unsafeCoerce# f x))
    Nothing -> Nothing

dynApp :: Dynamic -> Dynamic -> Dynamic
dynApp f x = fromMaybe (error typeError) (dynApply f x)
  where
    typeError  = "Type error in dynamic application.\n" 
              ++ "Can't apply function " ++ show f
              ++ " to argument " ++ show x

dynBind :: TyCon -> (forall a b. m a -> (a -> m b) -> m b) -> Dynamic -> Dynamic -> Maybe Dynamic
dynBind m bind (Dynamic t1 x) (Dynamic t2 f) = 
  case splitTyConApp t1 of
    (m', [a]) | m' == m ->
      case funResultTy t2 a of
        Just mb -> Just (Dynamic mb (GHC.unsafeCoerce# bind x f))
        _  -> Nothing
    _ -> Nothing 

dynBind' :: TyCon -> (forall a b. m a -> (a -> m b) -> m b) -> Dynamic -> Dynamic -> Dynamic
dynBind' m bind x f = fromMaybe (error typeError) (dynBind m bind x f)
  where
    typeError = "Type error in dynamic bind.\nCan't bind " ++ show x ++ " to " ++ show f




-- | Dynamically typed Kleisli composition
dynKleisli :: TyCon  
           -> (forall a b c. (a -> m b) -> (b -> m c) -> a -> m c) 
           -> Dynamic 
           -> Dynamic 
           -> Maybe Dynamic
dynKleisli m comp (Dynamic tf f) (Dynamic tg g) = 
  case splitTyConApp tf of
    (arr1, [a, mb]) | arr1 == funTc -> 
      case splitTyConApp tg of
        (arr2, [b, mc]) | arr2 == funTc ->
          case splitTyConApp mb of
            (m', [b']) | m' == m && b' == b ->
              case splitTyConApp mc of
                (m'', [_c]) | m'' == m ->
                  Just (Dynamic (mkFunTy a mc) (GHC.unsafeCoerce# comp f g))  
                _ -> 
                  Nothing
            _ ->
              Nothing
        _ ->
          Nothing
    _ ->
      Nothing