-- 
-- (c) Susumu Katayama
--
{-# LANGUAGE MagicHash, ExistentialQuantification, PolymorphicComponents, TemplateHaskell, ImpredicativeTypes #-}
module MagicHaskeller.FakeDynamic(
        Dynamic,
        fromDyn,
        fromDynamic,
        dynApply,
        dynApp,
        dynAppErr,
        unsafeFromDyn, -- :: Dynamic -> a
        unsafeToDyn, -- :: Type -> a -> Dynamic
        aLittleSafeFromDyn, -- :: Type -> Dynamic -> a
        fromPD,
        dynamic, dynamicH
        -- I (susumu) believe this is enough, provided unsafeFromDyn does not invoke typeOf for type checking. (Otherwise there would be ambiguity error.)
                                 ) where

import Data.Typeable

import GHC.Exts

import MagicHaskeller.Types
import MagicHaskeller.TyConLib
import Control.Monad

import qualified MagicHaskeller.PolyDynamic as PD

import MagicHaskeller.ReadTHType(thTypeToType)
import MagicHaskeller.ReadTypeRep(trToType)
import Language.Haskell.TH hiding (Type)
import MagicHaskeller.MHTH
import Data.Typeable(typeOf)



newtype Dynamic = Dynamic {Dynamic -> forall a. a
unsafeFromDyn::forall a. a}

unsafeToDyn :: TyConLib -> Type -> a -> e -> Dynamic
unsafeToDyn :: TyConLib -> Type -> a -> e -> Dynamic
unsafeToDyn TyConLib
_ Type
tr a
a e
e = (forall a. a) -> Dynamic
Dynamic (a -> a
unsafeCoerce# a
a)

aLittleSafeFromDyn :: Type -> Dynamic -> a
aLittleSafeFromDyn :: Type -> Dynamic -> a
aLittleSafeFromDyn Type
_ (Dynamic forall a. a
o) = a
forall a. a
o

fromDyn :: Typeable a => TyConLib -> Dynamic -> a -> a
fromDyn :: TyConLib -> Dynamic -> a -> a
fromDyn TyConLib
tcl (Dynamic forall a. a
o) a
dflt = a
forall a. a
o
fromDynamic :: MonadPlus m => Type -> Dynamic -> m a
fromDynamic :: Type -> Dynamic -> m a
fromDynamic Type
tr (Dynamic forall a. a
o) = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. a
o

instance Show Dynamic where
   showsPrec :: Int -> Dynamic -> ShowS
showsPrec Int
_ Dynamic
_ = String -> ShowS
showString String
"<< FakeDynamic >>"

dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
dynApply Dynamic
f Dynamic
x = Dynamic -> Maybe Dynamic
forall k1. k1 -> Maybe k1
Just (Dynamic -> Dynamic -> Dynamic
dynApp Dynamic
f Dynamic
x)

dynApp :: Dynamic -> Dynamic -> Dynamic
dynApp :: Dynamic -> Dynamic -> Dynamic
dynApp (Dynamic forall a. a
f) (Dynamic forall a. a
x) = (forall a. a) -> Dynamic
Dynamic ((Any -> Any -> a
unsafeCoerce# Any
forall a. a
f) Any
forall a. a
x)
dynAppErr :: String -> Dynamic -> Dynamic -> Dynamic
dynAppErr :: String -> Dynamic -> Dynamic -> Dynamic
dynAppErr String
_ Dynamic
f Dynamic
x = Dynamic -> Dynamic -> Dynamic
dynApp Dynamic
f Dynamic
x

fromPD :: PD.Dynamic -> Dynamic
fromPD :: Dynamic -> Dynamic
fromPD = (forall a. a) -> Dynamic
Dynamic  ((forall a. a) -> Dynamic)
-> (Dynamic -> forall a. a) -> Dynamic -> Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Dynamic -> forall a. a
PD.unsafeFromDyn


-- 以下はMyDynamicからとってきたもので，PolyDynamicにあるのと全く同じ．
{-
$(dynamic [|tcl|] [| (,) :: forall a b. a->b->(a,b) |])
のようにできるようにする．CLEANのdynamicみたいな感じ．
-}
dynamic :: ExpQ -> ExpQ -> ExpQ
dynamic :: ExpQ -> ExpQ -> ExpQ
dynamic ExpQ
eqtcl ExpQ
eq = ExpQ
eq ExpQ -> (Exp -> ExpQ) -> ExpQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExpQ -> Exp -> ExpQ
p' ExpQ
eqtcl

-- Quasi-quotes with higher-rank types are not permitted. When that is the case, take the type info apart from the expression.
-- E.g. $(dynamicH [|tcl|] 'foo [t| forall a b. a->b->(a,b) |]) is equivalent to $(dynamic [|tcl|] [| foo :: forall a b. a->b->(a,b) |])
dynamicH :: ExpQ -> Name -> TypeQ -> ExpQ
dynamicH :: ExpQ -> Name -> TypeQ -> ExpQ
dynamicH ExpQ
eqtcl Name
nm TypeQ
tq = do Type
t <- TypeQ
tq
                          ExpQ -> Exp -> Type -> ExpQ
px ExpQ
eqtcl (Name -> Exp
VarE Name
nm) Type
t
-- p' is like MagicHaskeller.p'
p' :: ExpQ -> Exp -> ExpQ
p' ExpQ
eqtcl (SigE Exp
e Type
ty) = ExpQ -> Exp -> Type -> ExpQ
px ExpQ
eqtcl Exp
e Type
ty
p' ExpQ
eqtcl Exp
e           = [| unsafeToDyn $eqtcl (trToType $eqtcl (typeOf $(return e)))    $(return e)  $(expToExpExp e) |]

px :: ExpQ -> Exp -> Type -> ExpQ
px ExpQ
eqtcl Exp
e Type
ty        = [| unsafeToDyn $eqtcl (thTypeToType $eqtcl $(typeToExpType ty)) $(return se) $(expToExpExp se) |]
    where se :: Exp
se = Exp -> Type -> Exp
SigE Exp
e Type
ty