2005-04-24 08:51:33 +00:00

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 )
------------------------------------------------------------------------