ghc/lib/std/PrelHugs.lhs

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