175 lines
5.5 KiB
Haskell
175 lines
5.5 KiB
Haskell
{-# OPTIONS -cpp -fglasgow-exts #-}
|
|
--
|
|
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
|
|
--
|
|
-- This library is free software; you can redistribute it and/or
|
|
-- modify it under the terms of the GNU Lesser General Public
|
|
-- License as published by the Free Software Foundation; either
|
|
-- version 2.1 of the License, or (at your option) any later version.
|
|
--
|
|
-- This library is distributed in the hope that it will be useful,
|
|
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
-- Lesser General Public License for more details.
|
|
--
|
|
-- You should have received a copy of the GNU Lesser General Public
|
|
-- License along with this library; if not, write to the Free Software
|
|
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
|
|
-- USA
|
|
--
|
|
|
|
--
|
|
-- reimplement the Data.Dynamic library to use equality over the
|
|
-- canonical name of a type, rather than on integer keys. The later is
|
|
-- how the Haskell library works, and is broken for our situation:
|
|
-- static versus dynamic instances of the same type seem to generate
|
|
-- different keys, meaning equal types are not detected as such.
|
|
--
|
|
|
|
module AltData.Dynamic (
|
|
|
|
Dynamic, -- must be abstract
|
|
toDyn, -- :: Typeable a => a -> Dynamic
|
|
fromDyn, -- :: Typeable a => Dynamic -> Maybe a
|
|
fromDynamic,
|
|
dynApp,
|
|
dynApply,
|
|
dynAppHList,
|
|
|
|
typecase,
|
|
(-->),
|
|
|
|
_Int,
|
|
_Char,
|
|
_Bool,
|
|
_String,
|
|
_IntToInt,
|
|
|
|
) where
|
|
|
|
import AltData.Typeable
|
|
import Data.Maybe
|
|
import System.IO.Unsafe ( unsafePerformIO )
|
|
import GHC.Base ( unsafeCoerce# )
|
|
import Data.List
|
|
|
|
data Dynamic = Dynamic TypeRep Obj
|
|
|
|
type Obj = forall a . a
|
|
|
|
instance Show Dynamic where
|
|
-- the instance just prints the type representation.
|
|
showsPrec _ (Dynamic t _) =
|
|
showString "<" .
|
|
showsPrec 0 t .
|
|
showString ">"
|
|
|
|
instance Typeable Dynamic where
|
|
#if __GLASGOW_HASKELL__ >= 603
|
|
typeOf _ = mkTyConApp (mkTyCon "AltData.Dynamic") []
|
|
#else
|
|
typeOf _ = mkAppTy (mkTyCon "AltData.Dyanmic") []
|
|
#endif
|
|
|
|
--
|
|
-- must be monomophic, see Data.Dynamic
|
|
--
|
|
toDyn :: Typeable a => a -> Dynamic
|
|
toDyn v = Dynamic (typeOf v) (unsafeCoerce# v)
|
|
|
|
--
|
|
-- Converts a 'Dynamic' object back into an ordinary Haskell value of
|
|
-- the correct type. (this is the same as fromDynamic)
|
|
--
|
|
-- Uses string comparison of the name of the type, rather than the
|
|
-- hashed key of the type, which doesn't work for plugins, which mix
|
|
-- static and dynamic loaded code.
|
|
--
|
|
-- TypeRep is abstract, unfortunately.
|
|
--
|
|
fromDyn :: Typeable a => Dynamic -> Maybe a
|
|
|
|
fromDyn (Dynamic t v) =
|
|
case unsafeCoerce# v of
|
|
r | t == typeOf r -> Just r
|
|
| otherwise -> unsafePerformIO (putStrLn $
|
|
"Couldn't match `" ++show(typeOf r) ++
|
|
"' against `" ++show t ++"'"++
|
|
"\n\tExpected type: " ++show(typeOf r) ++
|
|
"\n\tInferred type: " ++show t
|
|
) `seq` Nothing
|
|
|
|
fromDynamic d = case fromDyn d of
|
|
Just v -> v
|
|
Nothing -> error ("\nType error in dynamic unwrapping.\n" ++
|
|
"In value `" ++ show d ++ "'")
|
|
|
|
dynApp :: Dynamic -> Dynamic -> Dynamic
|
|
dynApp f x = case dynApply f x of
|
|
Just r -> r
|
|
Nothing -> error ("Type error in dynamic application.\n" ++
|
|
"Can't apply function " ++ show f ++
|
|
" to argument " ++ show x)
|
|
|
|
--
|
|
-- (f::(a->b)) `dynApply` (x::a) = (f a)::b
|
|
--
|
|
dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
|
|
dynApply (Dynamic t1 f) (Dynamic t2 x) =
|
|
#if __GLASGOW_HASKELL__ >= 603
|
|
case funResultTy t1 t2 of
|
|
#else
|
|
case applyTy t1 t2 of
|
|
#endif
|
|
Just t3 -> Just (Dynamic t3 ((unsafeCoerce# f) x))
|
|
Nothing -> Nothing
|
|
|
|
|
|
--
|
|
-- hmm
|
|
--
|
|
dynAppHList :: Dynamic -> [Dynamic] -> Dynamic
|
|
dynAppHList fn [] = fn -- partial applicaiton
|
|
dynAppHList fn (x:xs) = (fn `dynApp` x) `dynAppHList` xs
|
|
|
|
-- ---------------------------------------------------------------------
|
|
--
|
|
-- Implementation of typecase, without patterns, based on "Dynamic
|
|
-- typing in a statically typed language". Mart\'in Abadi, Luca
|
|
-- Cardelli, Benjamin Pierce and Gordon Plotkin. ACM Trans. Prog. Lang.
|
|
-- and Syst. 13(2):237-268, 1991.
|
|
--
|
|
-- Doesn't provide the behaviour that if the value is not a Dynamic,
|
|
-- then typecase returns a error. Need low-level ops for that.
|
|
--
|
|
|
|
-- typecase :: Typeable u => Dynamic -> [(TypeRep, Dynamic)] -> u -> u
|
|
|
|
typecase :: Typeable u
|
|
=> Dynamic -- selector
|
|
-> [(Dynamic, Dynamic)] -- branches
|
|
-> u -- else arm
|
|
-> u -- return type
|
|
|
|
typecase dv@(Dynamic ty _) alts dflt =
|
|
case find (hasType ty) alts of
|
|
Nothing -> dflt
|
|
Just v -> fromDynamic $ snd v `dynApp` dv
|
|
|
|
where hasType t ((Dynamic u _),_) = t == u
|
|
|
|
infixl 6 -->
|
|
(-->) :: Typeable b => a -> b -> (a,Dynamic)
|
|
a --> b = (a,toDyn b)
|
|
|
|
--
|
|
-- need a way to generate a Dynamic prelude
|
|
--
|
|
_Int = toDyn ( undefined :: Int )
|
|
_Char = toDyn ( undefined :: Char )
|
|
_Bool = toDyn ( undefined :: Bool )
|
|
_String = toDyn ( undefined :: [Char] )
|
|
_IntToInt = toDyn ( undefined :: Int -> Int )
|
|
|
|
------------------------------------------------------------------------
|