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)
  42 import PrelErr(error)
  43 import PrelPack(unpackCString)
  44
  45 -- Stuff needed by Hugs for desugaring.  Do not mess with these!
  46 -- They need to correspond exactly to versions written in
  47 -- the Hugs standalone Prelude.
  48
  49 -- hugs doesn't know about RealWorld and so throws this
  50 -- away if the original type signature is used
  51 -- hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
  52 --
  53 -- The first arg is an IO value created by Hugs, without the
  54 -- newtype ST wrapper.  What we do here place a wrapper around
  55 -- it, so that it can be called from GHC-land, which uses a
  56 -- different IO representation.
  57 --
  58 -- This is all very delicate and relies crucially on the non-inlined
  59 -- connectWorlds fn to create an artificial dependency of the hugs_ioaction
  60 -- on the grealworld.  That's needed to stop the simplifier floating
  61 -- the case outside of the \ grealworld.
  62 hugsprimMkIO :: (rw -> (a,rw)) -> IO a
  63 hugsprimMkIO hugs_ioaction
  64    = IO ( \ grealworld -> case hugs_ioaction
  65                                   (connectWorlds grealworld) of
  66                              (res, hrealworld') -> (# grealworld, res #)
  67         )
  68
  69 {-# NOINLINE connectWorlds #-}
  70 connectWorlds :: State# RealWorld -> a    -- really, -> Hugs' RealWorld
  71 connectWorlds hrealworld
  72    = error "connectWorlds: hugs entered the RealWorld"
  73
  74
  75
  76
  77 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
  78 hugsprimCreateAdjThunk fun typestr callconv
  79    = error "hugsprimCreateAdjThunk in combined mode: unimplemented"
  80
  81 fromDouble :: Fractional a => Double -> a
  82 fromDouble n = fromRational (toRational n)
  83
  84 hugsprimEqChar       :: Char -> Char -> Bool
  85 hugsprimEqChar c1 c2  = c1 == c2
  86
  87 hugsprimPmInt        :: Num a => Int -> a -> Bool
  88 hugsprimPmInt n x     = fromInt n == x
  89
  90 hugsprimPmInteger    :: Num a => Integer -> a -> Bool
  91 hugsprimPmInteger n x = fromInteger n == x
  92
  93 hugsprimPmDouble     :: Fractional a => Double -> a -> Bool
  94 hugsprimPmDouble n x  = fromDouble n == x
  95
  96 -- The following primitives are only needed if (n+k) patterns are enabled:
  97 hugsprimPmSub           :: Integral a => Int -> a -> a
  98 hugsprimPmSub n x        = x - fromInt n
  99
 100 hugsprimPmFromInteger   :: Integral a => Integer -> a
 101 hugsprimPmFromInteger    = fromIntegral
 102
 103 hugsprimPmSubtract      :: Integral a => a -> a -> a
 104 hugsprimPmSubtract x y   = x - y
 105
 106 hugsprimPmLe            :: Integral a => a -> a -> Bool
 107 hugsprimPmLe x y         = x <= y
 108
 109 hugsprimUnpackString :: Addr -> String
 110 hugsprimUnpackString a = unpackCString a
 111
 112 -- ToDo: make the message more informative.
 113 hugsprimPmFail       :: a
 114 hugsprimPmFail        = error "Pattern Match Failure"
 115
 116 hugsprimCompAux      :: Ord a => a -> a -> Ordering -> Ordering
 117 hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
 118
 119 hugsprimError        :: String -> a
 120 hugsprimError s       = error s
 121
 122 hugsprimShowField    :: Show a => String -> a -> ShowS
 123 hugsprimShowField m v = showString m . showChar '=' . shows v
 124
 125 hugsprimReadField    :: Read a => String -> ReadS a
 126 hugsprimReadField m s0 = [ r | (t,  s1) <- lex s0, t == m,
 127                                ("=",s2) <- lex s1,
 128                                r        <- reads s2 ]
 129
 130
 131 -- used when Hugs invokes top level function
 132 {-
 133 hugsprimRunIO_toplevel :: IO a -> ()
 134 hugsprimRunIO_toplevel m
 135    = protect 5 (fst (unST composite_action realWorld))
 136      where
 137         composite_action
 138            = do writeIORef prelCleanupAfterRunAction Nothing
 139                 m
 140                 cleanup_handles <- readIORef prelCleanupAfterRunAction
 141                 case cleanup_handles of
 142                    Nothing -> return ()
 143                    Just xx -> xx
 144
 145         realWorld = error "primRunIO: entered the RealWorld"
 146         protect :: Int -> () -> ()
 147         protect 0 comp
 148            = comp
 149         protect n comp
 150            = primCatch (protect (n-1) comp)
 151                        (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
 152 -}
 153
 154 hugsprimRunIO_toplevel :: IO a -> ()
 155 hugsprimRunIO_toplevel m
 156     = unsafePerformIO (
 157          catchException (m >> hFlush stderr >> hFlush stdout)
 158                         (\e -> putStr ("error: " ++ show e ++ "\n"))
 159       )
 160 \end{code}