/usr/lib/hugs/packages/hugsbase/Hugs/Internals.hs is in hugs 98.200609.21-5.3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 | ----------------------------------------------------------------
-- Primitives for accessing Hugs internals.
--
-- NB These primitives are an _experimental_ feature which may be
-- removed in future versions of Hugs.
-- They can only be used if hugs was configured with the
-- "--enable-internal-prims" flag.
--
-- The primitives defined in this module provide the means with
-- which to implement simple error-recovery and debugging facilities
-- in Haskell.
--
-- The error catching primitive only works if the "failOnError" flag
-- is FALSE - ie Hugs was invoked with the "-f" flag.
--
-- Despite appearances, these primitives are referentially transparent
-- (with the exception of the rarely used pointer equality operations)
-- (The proof is really neat - but there just isn't enough space in the margin)
----------------------------------------------------------------
module Hugs.Internals(
ptrEq,
Name,
nameString,
nameInfo,
nameEq,
Cell,
getCell,
cellPtrEq,
CellKind(..),
classifyCell,
catchError,
Addr,
nameCode,
Instr(..),
instrAt, instrsAt,
) where
import Hugs.Prelude hiding ( Addr )
----------------------------------------------------------------
-- pointer equality
----------------------------------------------------------------
-- breaks referential transparency - use with care
primitive ptrEq "unsafePtrEq" :: a -> a -> Bool
----------------------------------------------------------------
-- Name
----------------------------------------------------------------
data Name
-- newtype Name = Name Int
-- returns (arity, precedence, associativity)
primitive nameInfo :: Name -> (Int, Int, Char)
primitive nameString :: Name -> String
primitive nameEq :: Name -> Name -> Bool
instance Show Name where
showsPrec _ nm = showString (nameString nm)
instance Eq Name where
(==) = nameEq
----------------------------------------------------------------
-- Cell
-- Note: cellPtrEq breaks referential transparency - use with care
----------------------------------------------------------------
data Cell
primitive getCell :: a -> Cell
primitive cellPtrEq :: Cell -> Cell -> Bool
primitive catchError "catchError2" :: a -> Either Cell a
instance Show Cell where
showsPrec _ _ = showString "{Cell}"
----------------------------------------------------------------
-- CellType
----------------------------------------------------------------
data CellKind
= Apply Cell [Cell]
| Fun Name
| Con Name
| Tuple Int
| Int Int
| Integer Integer
| Float Float
| Double Double
| Char Char
| Prim String
| Error Cell
deriving (Show)
primitive classifyCell :: Bool -> Cell -> IO CellKind
----------------------------------------------------------------
-- Addr
----------------------------------------------------------------
newtype Addr = Addr Int deriving (Eq, Show)
s :: Addr -> Addr
s (Addr a) = Addr (a+1)
primitive nameCode :: Name -> Addr
primitive intAt :: Addr -> Int
primitive floatAt :: Addr -> Float
primitive doubleAt :: Addr -> Double
primitive cellAt :: Addr -> Cell
primitive nameAt :: Addr -> Name
primitive textAt :: Addr -> String
primitive addrAt :: Addr -> Addr
primitive bytecodeAt :: Addr -> Bytecode
----------------------------------------------------------------
-- Bytecode
----------------------------------------------------------------
newtype Bytecode = Bytecode Int deriving (Eq, Show)
iLOAD = Bytecode 0
iCELL = Bytecode 1
iCHAR = Bytecode 2
iINT = Bytecode 3
iFLOAT = Bytecode 4
iSTRING = Bytecode 5
iMKAP = Bytecode 6
iUPDATE = Bytecode 7
iUPDAP = Bytecode 8
iEVAL = Bytecode 9
iRETURN = Bytecode 10
iTEST = Bytecode 11
iGOTO = Bytecode 12
iSETSTK = Bytecode 13
iROOT = Bytecode 14
iDICT = Bytecode 15
iFAIL = Bytecode 16
iALLOC = Bytecode 17
iSLIDE = Bytecode 18
iSTAP = Bytecode 19
iTABLE = Bytecode 20
iLEVAL = Bytecode 21
iRUPDAP = Bytecode 22
iRUPDATE = Bytecode 23
data Instr
= LOAD Int
| CELL Cell
| CHAR Char
| INT Int
| FLOAT Float
| DOUBLE Double
| STRING String
| MKAP Int
| UPDATE Int
| UPDAP Int
| EVAL
| RETURN
| TEST Name Addr
| GOTO Addr
| SETSTK Int
| ROOT Int
| DICT Int
| FAIL
| ALLOC Int
| SLIDE Int
| STAP
| TABLE
| LEVAL Int
| RUPDAP
| RUPDATE
deriving (Show)
instrAt :: Addr -> (Instr, Addr)
instrAt pc = case bytecodeAt pc of
i | i == iLOAD -> (LOAD (intAt (s pc)), s (s pc))
i | i == iCELL -> (CELL (cellAt (s pc)), s (s pc))
i | i == iCHAR -> (CHAR (toEnum (intAt (s pc))), s (s pc))
i | i == iINT -> (INT (intAt (s pc)), s (s pc))
i | i == iFLOAT -> (FLOAT (floatAt (s pc)), s (s pc))
i | i == iSTRING -> (STRING (textAt (s pc)), s (s pc))
i | i == iMKAP -> (MKAP (intAt (s pc)), s (s pc))
i | i == iUPDATE -> (UPDATE (intAt (s pc)), s (s pc))
i | i == iUPDAP -> (UPDAP (intAt (s pc)), s (s pc))
i | i == iEVAL -> (EVAL , s pc)
i | i == iRETURN -> (RETURN , s pc)
i | i == iTEST -> (TEST (nameAt (s pc)) (addrAt (s (s (pc)))), s (s (s pc)))
i | i == iGOTO -> (GOTO (addrAt (s pc)), s (s pc))
i | i == iSETSTK -> (SETSTK (intAt (s pc)), s (s pc))
i | i == iROOT -> (ROOT (intAt (s pc)), s (s pc))
i | i == iDICT -> (DICT (intAt (s pc)), s (s pc))
i | i == iFAIL -> (FAIL , s pc)
i | i == iALLOC -> (ALLOC (intAt (s pc)), s (s pc))
i | i == iSLIDE -> (SLIDE (intAt (s pc)), s (s pc))
i | i == iSTAP -> (STAP , s pc)
i | i == iTABLE -> (TABLE , s pc)
i | i == iLEVAL -> (LEVAL (intAt (s pc)), s (s pc))
i | i == iRUPDAP -> (RUPDAP , s pc)
i | i == iRUPDATE -> (RUPDATE , s pc)
-- list of instructions starting at given address
instrsAt :: Addr -> [Instr]
instrsAt pc = let (i, pc') = instrAt pc in i : instrsAt pc'
----------------------------------------------------------------
----------------------------------------------------------------
-- tests
----------------------------------------------------------------
-- test1, test2 :: Either Cell Int
--
-- test1 = catchError (error "foo")
-- test2 = catchError 1
--
--
-- test3, test4, test5 :: Int
--
-- test3 = myCatch (1+error "foo") 2
-- test4 = myCatch 1 (error "bar")
-- test5 = myCatch (error "foo") (error "bar")
--
--
-- test6, test7, test8, test9 :: IO ()
--
-- test6 = printString "abcdefg"
-- test7 = printString (error "a" : "bcdefg")
-- test8 = printString ("abc" ++ error "defg")
-- test9 = printString (error "a" : "bc" ++ error "defg")
--
-- -- if an error occurs, replace it with a default (hopefully error-free) value
-- myCatch :: a -> a -> a
-- myCatch x deflt = case catchError x of
-- Right x' -> x'
-- Left _ -> deflt
--
-- -- lazily print a string - catching any errors as necessary
-- printString :: String -> IO ()
-- printString str =
-- case catchError str of
-- Left _ -> putStr "<error>"
-- Right [] -> return ()
-- Right (c:cs) -> case catchError c of
-- Left _ -> putStr "<error>" >> printString cs
-- Right c' -> putChar c' >> printString cs
|