{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}

-- | A wrapper for the new GHC (and Hugs) Dynamic module.
-- The main improvement over the original Dynamic module is
-- that we provide flavours of TypeableXXXX for kinds with
-- arguments other than *, a feature used by "DisplayView".
module Util.Dynamics (
        Typeable(..), -- inherited from Dynamic
        TypeRep, -- same as Dynamic.TypeRep


        Dyn, -- equal to Dynamic.Dynamic
        toDyn, -- inherited from Dynamic.toDyn
        fromDynamic, -- inherited from Dynamic.fromDynamic
        fromDynamicWE, -- :: Dyn -> WithError a

        coerce, -- read Dyn or (match) error
        coerceIO, -- read Dyn or fail with typeMismatch
        typeMismatch,
        dynCast, -- Cast to another value of the same type, or
           -- error (useful for extracting from existential types).
        dynCastOpt
        )
where

import qualified Data.Dynamic
import Data.Typeable

import Util.Computation
import Util.Debug(debug)

fromDynamic :: Typeable a => Dyn -> Maybe a
fromDynamic :: Dyn -> Maybe a
fromDynamic = Dyn -> Maybe a
forall a. Typeable a => Dyn -> Maybe a
Data.Dynamic.fromDynamic

-- | Like 'fromDynamic' but provides an error message indicating what
-- types are getting confused.
fromDynamicWE :: Typeable a => Dyn -> WithError a
fromDynamicWE :: Dyn -> WithError a
fromDynamicWE Dyn
dyn =
   case Dyn -> Maybe a
forall a. Typeable a => Dyn -> Maybe a
fromDynamic Dyn
dyn of
      Just a
a -> a -> WithError a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
      (aOpt :: Maybe a
aOpt @ Maybe a
Nothing) ->
         String -> WithError a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Dynamic type error.  Looking for "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Maybe a -> a
forall a. Maybe a -> a
typeHack Maybe a
aOpt))
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but found a " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dyn -> String
forall a. Show a => a -> String
show Dyn
dyn)
   where
      typeHack :: Maybe a -> a
      typeHack :: Maybe a -> a
typeHack Maybe a
_ = a
forall a. HasCallStack => a
undefined
type Dyn = Data.Dynamic.Dynamic

toDyn :: Typeable a => a -> Dyn
toDyn :: a -> Dyn
toDyn = a -> Dyn
forall a. Typeable a => a -> Dyn
Data.Dynamic.toDyn

coerce  :: Typeable a => Dyn -> a
coerce :: Dyn -> a
coerce Dyn
d =
   case Dyn -> Maybe a
forall a. Typeable a => Dyn -> Maybe a
fromDynamic Dyn
d of
      Just a
x -> a
x

coerceIO :: Typeable a => Dyn -> IO a
coerceIO :: Dyn -> IO a
coerceIO Dyn
d =
   case Dyn -> Maybe a
forall a. Typeable a => Dyn -> Maybe a
fromDynamic Dyn
d of
      Maybe a
Nothing ->
         do
            String -> IO ()
forall a. Show a => a -> IO ()
debug String
"Dynamics.coerceIO failure"
            IOError -> IO a
forall a. IOError -> IO a
ioError IOError
typeMismatch
      (Just a
x) -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

typeMismatch :: IOError
typeMismatch :: IOError
typeMismatch =
        String -> IOError
userError String
"internal type of dynamics does not match expected type"

dynCast :: (Typeable a,Typeable b) => String -> a -> b
dynCast :: String -> a -> b
dynCast String
mess a
value = case a -> Maybe b
forall a b. (Typeable a, Typeable b) => a -> Maybe b
dynCastOpt a
value of
   Maybe b
Nothing -> String -> b
forall a. HasCallStack => String -> a
error (String
"Dynamics.dynCast failure in "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
mess)
   Just b
value2 -> b
value2

dynCastOpt :: (Typeable a,Typeable b) => a -> Maybe b
dynCastOpt :: a -> Maybe b
dynCastOpt = a -> Maybe b
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast