hugs 98.200609.21-5.4 / usr / lib / hugs / packages / hugsbase / Hugs / Internals.hs

----------------------------------------------------------------
-- 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