shaniqua-plugins/src/altdata/AltData/Dynamic.hs

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

------------------------------------------------------------------------