home *** CD-ROM | disk | FTP | other *** search
/ PSION CD 2 / PsionCDVol2.iso / Programs / 876 / hugs.sis / HugsDynamic.hs < prev    next >
Encoding:
Text File  |  2000-09-21  |  5.0 KB  |  170 lines
  1. -----------------------------------------------------------------------------
  2. -- A simple "dynamic typing" library
  3. -----------------------------------------------------------------------------
  4. module HugsDynamic
  5.    ( Typeable(typeOf)
  6.    , Dynamic, toDynamic, fromDynamic, dynApply  -- the primitives
  7.    , fromDyn, dynApp                            -- raise errors instead of Maybes
  8.    , intToDyn, fromDynInt, strToDyn, fromDynStr -- specialised versions
  9.    , Tycon(..), Type(..)                   -- added by sof
  10.    ) where
  11.  
  12. -- Added nicer printers for better error messages  -- jcp
  13.  
  14. import IOExts(unsafePerformIO)
  15.  
  16. data Tycon = Tycon String     deriving Eq
  17.  
  18. instance Show Tycon where
  19.   showsPrec p (Tycon s) = showString s
  20.  
  21. data Type  = App Tycon [Type] deriving Eq
  22.  
  23. instance Show Type where
  24.   showsPrec p (App tycon tys) 
  25.     | tycon == listTC && onearg 
  26.     = showString "[" . shows arg1 . showString "]"
  27.     | tycon == funTC && twoarg 
  28.     = showParen (p > 8) $
  29.       showsPrec 9 arg1 . showString " -> " . showsPrec 8 arg2
  30.     | tycon == tup2TC && twoarg 
  31.     = showString "(" . showsPrec 0 arg1 . showString ", " . showsPrec 0 arg2 .
  32.       showString ")"
  33.     | zeroarg
  34.     = showsPrec p tycon 
  35.     | otherwise
  36.     = showParen (p > 9) $
  37.       showsPrec p tycon . showArgs tys
  38.    where
  39.     (arg1 : arg2 : _) = tys
  40.     l = length tys
  41.     zeroarg = l == 0
  42.     onearg = l == 1
  43.     twoarg = l == 2  
  44.     showArgs [] = id
  45.     showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as 
  46.  
  47. unitTC    = Tycon "()"
  48. intTC     = Tycon "Int"
  49. integerTC = Tycon "Integer"
  50. floatTC   = Tycon "Float"
  51. doubleTC  = Tycon "Double"
  52. charTC    = Tycon "Char"
  53. ioTC      = Tycon "IO"
  54. funTC     = Tycon "->"
  55. listTC    = Tycon "[]"
  56. tup2TC    = Tycon "(,)"
  57.  
  58. -- ToDo: Either might be more useful for reporting errors
  59. tyApp :: Type -> Type -> Maybe Type
  60. tyApp (App tc [t1,t2]) t3
  61.   | tc == funTC
  62.   = if t1 == t3 then Just t2 else Nothing
  63. tyApp _ _ = Nothing
  64.  
  65. ---------------------------------------------------------------
  66.  
  67. class Typeable a where
  68.   typeOf :: a -> Type
  69.  
  70. instance Typeable ()      where typeOf x = App unitTC    []
  71. instance Typeable Int     where typeOf x = App intTC     []
  72. instance Typeable Integer where typeOf x = App integerTC []
  73. instance Typeable Float   where typeOf x = App floatTC   []
  74. instance Typeable Double  where typeOf x = App doubleTC  []
  75. instance Typeable Char    where typeOf x = App charTC    []
  76.  
  77. instance Typeable a => Typeable (IO a) where 
  78.   typeOf m = 
  79.     case unsafePerformIO m of { r ->
  80.     App ioTC  [typeOf r]
  81.     }
  82.  
  83. instance (Typeable a, Typeable b) => Typeable (a -> b) where
  84.   typeOf f = 
  85.     -- We use case to bind arg and result to avoid excess polymorphism
  86.     case undefined of { arg ->
  87.     case f arg     of { result ->
  88.     App funTC [typeOf arg, typeOf result]
  89.     }}
  90.  
  91. instance Typeable a => Typeable [a] where
  92.   typeOf xs = App listTC [typeOf (head xs)]
  93.  
  94. instance (Typeable a, Typeable b) => Typeable (a,b) where
  95.   typeOf p = App tup2TC [typeOf (fst p), typeOf (snd p)]
  96.  
  97. ----------------------------------------------------------------
  98.  
  99. data Object  = Object -- dummy type - we're going to switch the typechecker off
  100.  
  101. data Dynamic = Dynamic Type Object
  102. instance Show Dynamic where
  103.   showsPrec _ (Dynamic ty _) = showString "<<" . showsPrec 0 ty . showString ">>"
  104.  
  105. toDynamic :: Typeable a => a -> Dynamic
  106. toDynamic x = Dynamic (typeOf x) (unsafeCoerce x)
  107.  
  108. fromDynamic :: Typeable a => Dynamic -> Maybe a
  109. fromDynamic (Dynamic ty x) =
  110.   -- We use case to bind r to avoid excess polymorphism
  111.   case unsafeCoerce x of { r -> 
  112.   if ty == typeOf r then Just r else Nothing
  113.   }
  114.  
  115. dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
  116. dynApply (Dynamic t1 f) (Dynamic t2 x) =
  117.   tyApp t1 t2   >>= \ t3 -> 
  118.   return (Dynamic t3 ((unsafeCoerce f) x))
  119.  
  120. ----------------------------------------------------------------
  121.  
  122. fromDyn :: Typeable a => Dynamic -> a
  123. fromDyn d = res
  124.    where res = case fromDynamic d of
  125.                 Just r -> r
  126.                 Nothing -> error ("fromDyn failed.  Expecting " ++
  127.                                   show expectedType ++
  128.                                   " found " ++ show d) 
  129.          expectedType = toDynamic res
  130.  
  131. intToDyn :: Int -> Dynamic
  132. intToDyn = toDynamic
  133.  
  134. strToDyn :: String -> Dynamic
  135. strToDyn = toDynamic
  136.  
  137. fromDynInt :: Dynamic -> Int
  138. fromDynInt = fromDyn
  139.  
  140. fromDynStr :: Dynamic -> String
  141. fromDynStr = fromDyn
  142.  
  143. runDyn :: Dynamic -> IO ()
  144. runDyn = fromDyn
  145.  
  146. dynApp :: Dynamic -> Dynamic -> Dynamic
  147. dynApp f x = case dynApply f x of 
  148.              Just r -> r
  149.              Nothing -> error ("Type error in dynamic application.\n" ++
  150.                                "Can't apply function " ++ show f ++
  151.                                " to argument " ++ show x)
  152.  
  153.  
  154. ----------------------------------------------------------------
  155.  
  156. test1 = toDynamic (1::Int)
  157. test2 = toDynamic ((+) :: Int -> Int -> Int)
  158. test3 = dynApp test2 test1
  159. test4 = dynApp test3 test1
  160. test5 = fromDyn test4 
  161.  
  162. test5,test6,test7 :: Int
  163. test6 = fromDyn test1
  164. test7 = fromDyn test2
  165.  
  166. ----------------------------------------------------------------
  167.  
  168. primitive unsafeCoerce "primUnsafeCoerce" :: a -> b
  169.  
  170.