ghc/lib/std/PrelHugs.lhs

   1 % ------------------------------------------------------------------------------
   2 % $Id: PrelHugs.lhs,v 1.13 2000/06/30 13:39:35 simonmar Exp $
   3 %
   4 % (c) The University of Glasgow, 2000
   5 %
   6
   7 \begin{code}
   8 {-# OPTIONS -fno-implicit-prelude -#include "Assembler.h" -#include "../../rts/Schedule.h" -#include "../../rts/ForeignCall.h" #-}
   9
  10 module PrelHugs (
  11    hugsprimPmInt,
  12    hugsprimPmInteger,
  13    hugsprimPmDouble,
  14    hugsprimPmSub,
  15    hugsprimPmFromInteger,
  16    hugsprimPmSubtract,
  17    hugsprimPmLe,
  18    hugsprimRunIO_toplevel,
  19    hugsprimEqChar,
  20    fromDouble,
  21    hugsprimMkIO,
  22    hugsprimCreateAdjThunk,
  23    hugsprimUnpackString,
  24    hugsprimPmFail,
  25    hugsprimCompAux,
  26    hugsprimError,
  27    hugsprimShowField,
  28    hugsprimReadField
  29 )
  30 where
  31 import PrelGHC
  32 import PrelBase
  33 import PrelNum
  34 import PrelReal(Integral)
  35 import Prelude(fromIntegral)
  36 import IO(putStr,hFlush,stdout,stderr)
  37 import PrelException(catch,catchException)
  38 import PrelIOBase(IO(..),unsafePerformIO)
  39 import PrelShow(show,shows,showString,showChar,Show,ShowS)
  40 import PrelRead(Read,ReadS,lex,reads)
  41 import PrelFloat(Double)
  42 import PrelReal(Fractional,fromRational,toRational)
  43 import PrelAddr(Addr(..),nullAddr)
  44 import PrelStable(StablePtr,makeStablePtr)
  45 import PrelErr(error)
  46 import PrelPack(unpackCString)
  47 import List(length)
  48
  49 -- Stuff needed by Hugs for desugaring.  Do not mess with these!
  50 -- They need to correspond exactly to versions written in
  51 -- the Hugs standalone Prelude.
  52
  53 -- hugs doesn't know about RealWorld and so throws this
  54 -- away if the original type signature is used
  55 -- hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
  56 --
  57 -- The first arg is an IO value created by Hugs, without the
  58 -- newtype ST wrapper.  What we do here place a wrapper around
  59 -- it, so that it can be called from GHC-land, which uses a
  60 -- different IO representation.
  61 --
  62 -- This is all very delicate and relies crucially on the non-inlined
  63 -- connectWorlds fn to create an artificial dependency of the hugs_ioaction
  64 -- on the grealworld.  That's needed to stop the simplifier floating
  65 -- the case outside of the \ grealworld.
  66 hugsprimMkIO :: (rw -> (a,rw)) -> IO a
  67 hugsprimMkIO hugs_ioaction
  68    = IO ( \ grealworld -> case hugs_ioaction
  69                                   (connectWorlds grealworld) of
  70                              (res, hrealworld') -> (# grealworld, res #)
  71         )
  72
  73 {-# NOINLINE connectWorlds #-}
  74 connectWorlds :: State# RealWorld -> a    -- really, -> Hugs' RealWorld
  75 connectWorlds hrealworld
  76    = error "connectWorlds: hugs entered the RealWorld"
  77
  78
  79
  80 -- StgAddr createAdjThunk ( StgStablePtr stableptr,
  81 --                          StgAddr      typestr,
  82 --                          StgChar      callconv )
  83
  84 foreign import "createAdjThunk" unsafe hugsCreateAdjThunk
  85         :: StablePtr (a -> b) -> Addr{-mallocville String-} -> Char -> IO Addr
  86 foreign import "malloc" unsafe malloc
  87         :: Int -> IO Addr
  88 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
  89 hugsprimCreateAdjThunk fun typestr callconv
  90    = do sp <- makeStablePtr fun
  91         p  <- copy_String_to_cstring typestr  -- is never freed
  92         a  <- hugsCreateAdjThunk sp p callconv
  93         return a
  94      where
  95         copy_String_to_cstring :: String -> IO Addr
  96         copy_String_to_cstring s
  97            = malloc (1 + length s) >>= \ptr0 ->
  98              let loop off []     = writeCharOffAddr ptr0 off (chr 0)
  99                                    >> return ptr0
 100                  loop off (c:cs) = writeCharOffAddr ptr0 off c
 101                                    >> loop (off+1) cs
 102              in
 103                  if   isNullAddr ptr0
 104                  then error "copy_String_to_cstring: malloc failed"
 105                  else loop 0 s
 106
 107         isNullAddr a = a == nullAddr
 108
 109         writeCharOffAddr :: Addr -> Int -> Char -> IO ()
 110         writeCharOffAddr (A# buf#) (I# n#) (C# c#)
 111            = IO ( \ s# ->
 112                   case (writeCharOffAddr# buf# n# c# s#) of
 113                      s2# -> (# s2#, () #) )
 114
 115
 116
 117 fromDouble :: Fractional a => Double -> a
 118 fromDouble n = fromRational (toRational n)
 119
 120 hugsprimEqChar       :: Char -> Char -> Bool
 121 hugsprimEqChar c1 c2  = c1 == c2
 122
 123 hugsprimPmInt        :: Num a => Int -> a -> Bool
 124 hugsprimPmInt n x     = fromInt n == x
 125
 126 hugsprimPmInteger    :: Num a => Integer -> a -> Bool
 127 hugsprimPmInteger n x = fromInteger n == x
 128
 129 hugsprimPmDouble     :: Fractional a => Double -> a -> Bool
 130 hugsprimPmDouble n x  = fromDouble n == x
 131
 132 -- The following primitives are only needed if (n+k) patterns are enabled:
 133 hugsprimPmSub           :: Integral a => Int -> a -> a
 134 hugsprimPmSub n x        = x - fromInt n
 135
 136 hugsprimPmFromInteger   :: Integral a => Integer -> a
 137 hugsprimPmFromInteger    = fromIntegral
 138
 139 hugsprimPmSubtract      :: Integral a => a -> a -> a
 140 hugsprimPmSubtract x y   = x - y
 141
 142 hugsprimPmLe            :: Integral a => a -> a -> Bool
 143 hugsprimPmLe x y         = x <= y
 144
 145 hugsprimUnpackString :: Addr -> String
 146 hugsprimUnpackString a = unpackCString a
 147
 148 -- ToDo: make the message more informative.
 149 hugsprimPmFail       :: a
 150 hugsprimPmFail        = error "Pattern Match Failure"
 151
 152 hugsprimCompAux      :: Ord a => a -> a -> Ordering -> Ordering
 153 hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
 154
 155 hugsprimError        :: String -> a
 156 hugsprimError s       = error s
 157
 158 hugsprimShowField    :: Show a => String -> a -> ShowS
 159 hugsprimShowField m v = showString m . showChar '=' . shows v
 160
 161 hugsprimReadField    :: Read a => String -> ReadS a
 162 hugsprimReadField m s0 = [ r | (t,  s1) <- lex s0, t == m,
 163                                ("=",s2) <- lex s1,
 164                                r        <- reads s2 ]
 165
 166
 167 -- used when Hugs invokes top level function
 168 {-
 169 hugsprimRunIO_toplevel :: IO a -> ()
 170 hugsprimRunIO_toplevel m
 171    = protect 5 (fst (unST composite_action realWorld))
 172      where
 173         composite_action
 174            = do writeIORef prelCleanupAfterRunAction Nothing
 175                 m
 176                 cleanup_handles <- readIORef prelCleanupAfterRunAction
 177                 case cleanup_handles of
 178                    Nothing -> return ()
 179                    Just xx -> xx
 180
 181         realWorld = error "primRunIO: entered the RealWorld"
 182         protect :: Int -> () -> ()
 183         protect 0 comp
 184            = comp
 185         protect n comp
 186            = primCatch (protect (n-1) comp)
 187                        (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
 188 -}
 189
 190 hugsprimRunIO_toplevel :: IO a -> ()
 191 hugsprimRunIO_toplevel m
 192     = unsafePerformIO (
 193          catchException (m >> hFlush stderr >> hFlush stdout)
 194                         (\e -> putStr ("error: " ++ show e ++ "\n"))
 195       )
 196 \end{code}