home *** CD-ROM | disk | FTP | other *** search
/ PSION CD 2 / PsionCDVol2.iso / Programs / 876 / hugs.sis / ST.hs < prev    next >
Encoding:
Text File  |  2000-09-21  |  4.2 KB  |  122 lines
  1. -----------------------------------------------------------------------------
  2. -- Strict State Thread module
  3. -- 
  4. -- This library provides support for both lazy and strict state threads,
  5. -- as described in the PLDI '94 paper by John Launchbury and Simon Peyton
  6. -- Jones.  In addition to the monad ST, it also provides mutable variables
  7. -- STRef and mutable arrays STArray.  It is identical to the LazyST
  8. -- module except that the ST instance is strict.
  9. --
  10. -- Suitable for use with Hugs 98.
  11. -----------------------------------------------------------------------------
  12.  
  13. module ST 
  14.     ( ST
  15.     , runST
  16.     , thenLazyST, thenStrictST, returnST
  17.     , unsafeInterleaveST
  18.     , fixST 
  19.     , stToIO
  20.     , unsafeIOtoST
  21.  
  22.     , STRef
  23.       -- instance Eq (STRef s a)
  24.     , newSTRef
  25.     , readSTRef
  26.     , writeSTRef 
  27.  
  28.         , STArray
  29.           -- instance Eq (STArray s ix elt)
  30.         , newSTArray
  31.         , boundsSTArray
  32.         , readSTArray
  33.         , writeSTArray
  34.         , thawSTArray
  35.         , freezeSTArray
  36.         , unsafeFreezeSTArray
  37.         , Ix
  38.     ) where
  39.  
  40. import Array(Array,Ix(index),bounds,assocs)
  41. import IOExts(unsafePerformIO)
  42. import Monad   
  43.  
  44. -----------------------------------------------------------------------------
  45.  
  46. data ST s a      -- implemented as an internal primitive
  47.  
  48. primitive runST                        :: (forall s. ST s a) -> a
  49. primitive returnST     "STReturn"      :: a -> ST s a
  50. primitive thenLazyST   "STLazyBind"    :: ST s a -> (a -> ST s b) -> ST s b
  51. primitive thenStrictST "STStrictBind"  :: ST s a -> (a -> ST s b) -> ST s b
  52. primitive unsafeInterleaveST "STInter" :: ST s a -> ST s a
  53. primitive fixST        "STFix"         :: (a -> ST s a) -> ST s a
  54.  
  55. primitive stToIO    "primSTtoIO"   :: ST s a -> IO a
  56.  
  57. unsafeIOtoST        :: IO a -> ST s a
  58. unsafeIOtoST         = returnST . unsafePerformIO
  59.  
  60. instance Functor (ST s) where
  61.     fmap = liftM
  62.  
  63. instance Monad (ST s) where
  64.     (>>=)  = thenStrictST
  65.     return = returnST
  66.  
  67. -----------------------------------------------------------------------------
  68.  
  69. data STRef s a   -- implemented as an internal primitive
  70.  
  71. primitive newSTRef   "STNew"      :: a -> ST s (STRef s a)
  72. primitive readSTRef  "STDeref"    :: STRef s a -> ST s a
  73. primitive writeSTRef "STAssign"   :: STRef s a -> a -> ST s ()
  74. primitive eqSTRef    "STMutVarEq" :: STRef s a -> STRef s a -> Bool
  75.  
  76. instance Eq (STRef s a) where (==) = eqSTRef
  77.  
  78. -----------------------------------------------------------------------------
  79.  
  80. data STArray s ix elt -- implemented as an internal primitive
  81.  
  82. newSTArray          :: Ix ix => (ix,ix) -> elt -> ST s (STArray s ix elt)
  83. boundsSTArray       :: Ix ix => STArray s ix elt -> (ix, ix)
  84. readSTArray         :: Ix ix => STArray s ix elt -> ix -> ST s elt
  85. writeSTArray        :: Ix ix => STArray s ix elt -> ix -> elt -> ST s ()
  86. thawSTArray         :: Ix ix => Array ix elt -> ST s (STArray s ix elt)
  87. freezeSTArray       :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
  88. unsafeFreezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
  89.  
  90. newSTArray bs e      = primNewArr bs (rangeSize bs) e
  91. boundsSTArray a      = primBounds a
  92. readSTArray a i      = primReadArr index a i
  93. writeSTArray a i e   = primWriteArr index a i e
  94. thawSTArray arr      = newSTArray (bounds arr) err `thenStrictST` \ stArr ->
  95.                let 
  96.                          fillin [] = returnST stArr
  97.                          fillin ((ix,v):ixvs) = writeSTArray stArr ix v
  98.                           `thenStrictST` \ _ -> fillin ixvs
  99.                in fillin (assocs arr)
  100.  where
  101.   err = error "thawArray: element not overwritten" -- shouldnae happen
  102. freezeSTArray a      = primFreeze a
  103. unsafeFreezeSTArray  = freezeSTArray  -- not as fast as GHC
  104.  
  105. instance Eq (STArray s ix elt) where
  106.   (==) = eqSTArray
  107.  
  108. primitive primNewArr   "STNewArr"
  109.           :: (a,a) -> Int -> b -> ST s (STArray s a b)
  110. primitive primReadArr  "STReadArr"
  111.           :: ((a,a) -> a -> Int) -> STArray s a b -> a -> ST s b
  112. primitive primWriteArr "STWriteArr"
  113.           :: ((a,a) -> a -> Int) -> STArray s a b -> a -> b -> ST s ()
  114. primitive primFreeze   "STFreeze"
  115.           :: STArray s a b -> ST s (Array a b)
  116. primitive primBounds   "STBounds"
  117.           :: STArray s a b -> (a,a)
  118. primitive eqSTArray    "STArrEq"
  119.           :: STArray s a b -> STArray s a b -> Bool
  120.  
  121. -----------------------------------------------------------------------------
  122.