[major library reorganization, created Jhc.Monad, moved more things to Jhc.List, split up monolithic prelude more. got rid of IOErrorCont, relying on internal target specific mechanism for dealing with IOErrors, simplified IO code
John Meacham <john@repetae.net>**20061110055924] addfile ./lib/base/Jhc/Monad.hs
hunk ./E/E.hs 308
--- the IOErrorCont type from Jhc.IO
-tCont = ELit (litCons { litName = tc_IOErrorCont, litArgs = [], litType = eStar })
-tvrCont = tvr { tvrIdent = 0, tvrType = tCont }
hunk ./E/FromHs.hs 412
-            (True,"void") -> cFun $ \rs -> (,) (ELam tvrCont . ELam tvrWorld) $
+            (True,"void") -> cFun $ \rs -> (,) (ELam tvrWorld) $
hunk ./E/FromHs.hs 422
-                    True -> cFun $ \rs -> (,) (ELam tvrCont . ELam tvrWorld) $
+                    True -> cFun $ \rs -> (,) (ELam tvrWorld) $
hunk ./E/LetFloat.hs 115
-canFloatPast t | ELit LitCons { litName = n } <- getType t, n == tc_IOErrorCont = True -- getType t == ELit (litCons tc_IOErrorCont [] (ESort EStar)) = True
hunk ./E/Show.hs 143
-        f e | e == tCont     = return $ atom $ text "IOErrorCont"
hunk ./FrontEnd/HsPretty.hs 559
+ppHsPat (HsPUnboxedTuple ps) = parenListzh . map ppHsPat $ ps
hunk ./Main.hs 61
+import Name.Names
+import Name.VConsts
hunk ./Main.hs 630
+    let theTarget = ELit litCons { litName = dc_Target, litArgs = [ELit (LitInt targetIndex tIntzh)], litType = ELit litCons { litName = tc_Target, litArgs = [], litType = eStar } }
+        targetIndex = if fopts FO.ViaGhc then 1 else 0
+    prog <- return $ runIdentity $ flip programMapDs prog $ \(t,e) -> return $ if tvrIdent t == toId v_target then (t { tvrInfo = setProperty prop_INLINE mempty },theTarget) else (t,e)
+
hunk ./Name/Names.hs 64
-dc_JustIO = toName DataConstructor ("Jhc.IO", "JustIO")
hunk ./Name/Names.hs 69
+dc_Target = toName DataConstructor  ("Jhc.Options","Target#")
hunk ./Name/Names.hs 74
-tc_IOErrorCont = toName TypeConstructor ("Jhc.IO","IOErrorCont")
hunk ./Name/Names.hs 75
-tc_IOError = toName TypeConstructor     ("Prelude.IOError","IOError")
hunk ./Name/Names.hs 77
-tc_IO = toName TypeConstructor ("Jhc.IO", "IO")
-tc_World__ = toName TypeConstructor ("Jhc.Prim","World__")
+tc_IO = toName TypeConstructor       ("Jhc.IO", "IO")
+tc_World__ = toName TypeConstructor  ("Jhc.Prim","World__")
hunk ./Name/Names.hs 80
-tc_Bool = toName TypeConstructor ("Jhc.Order","Bool")
-tc_List = toName TypeConstructor ("Jhc.Basics","[]")
-tc_Ptr = toName TypeConstructor ("Foreign.Ptr","Ptr")
+tc_Bool = toName TypeConstructor  ("Jhc.Order","Bool")
+tc_Target = toName TypeConstructor  ("Jhc.Options","Target")
+tc_List = toName TypeConstructor  ("Jhc.Basics","[]")
+tc_Ptr = toName TypeConstructor   ("Foreign.Ptr","Ptr")
hunk ./Name/Names.hs 93
-v_error = toName Val ("Prelude","error")
+v_target = toName Val  ("Jhc.Options","target")
+v_error = toName Val ("Jhc.IO","error")
hunk ./Name/Names.hs 103
-v_filter = toName Val ("Prelude","filter")
+v_filter = toName Val ("Jhc.List","filter")
hunk ./Name/Names.hs 106
-v_undefinedIOErrorCont = toName Val ("Jhc.IO","undefinedIOErrorCont")
hunk ./Name/Names.hs 109
-    func_bind = toName Val ("Prelude",">>="),
-    func_bind_ = toName Val ("Prelude",">>"),
+    func_bind = toName Val ("Jhc.Monad",">>="),
+    func_bind_ = toName Val ("Jhc.Monad",">>"),
hunk ./Name/Names.hs 132
-    func_runExpr = toName Val ("Jhc.IO","runExpr"),
+    func_runExpr = toName Val ("Prelude.IO","runExpr"),
hunk ./Name/Names.hs 147
-class_Functor = toName ClassName ("Prelude","Functor")
-class_Monad = toName ClassName ("Prelude","Monad")
+class_Functor = toName ClassName ("Jhc.Monad","Functor")
+class_Monad = toName ClassName ("Jhc.Monad","Monad")
hunk ./data/PrimitiveOperators-in.hs 122
-buildPeek cn t p = ELam tvr $ ELam tvrCont $ ELam tvrWorld (unbox' (EVar tvr) dc_Addr tvr' rest)  where
+buildPeek cn t p = ELam tvr $ ELam tvrWorld (unbox' (EVar tvr) dc_Addr tvr' rest)  where
hunk ./data/PrimitiveOperators-in.hs 150
-createIO t pv = toIO t (ELam tvrCont $ ELam tvrWorld $  eCaseTup  (pv tvrWorld) [tvrWorld2,rtVar] (eJustIO (EVar tvrWorld2) (EVar rtVar))) where
+createIO t pv = toIO t (ELam tvrWorld $  eCaseTup  (pv tvrWorld) [tvrWorld2,rtVar] (eJustIO (EVar tvrWorld2) (EVar rtVar))) where
hunk ./data/PrimitiveOperators-in.hs 154
-createIO_ pv = toIO tUnit (ELam tvrCont $ ELam tvrWorld $  eStrictLet tvrWorld2 (pv tvrWorld)  (eJustIO (EVar tvrWorld2) vUnit)) where
+createIO_ pv = toIO tUnit (ELam tvrWorld $  eStrictLet tvrWorld2 (pv tvrWorld)  (eJustIO (EVar tvrWorld2) vUnit)) where
hunk ./lib/base/Data/IORef.hs 25
-newIORef v = IO $ \_ w -> newRef__ v w
+newIORef v = IO $ \w -> newRef__ v w
hunk ./lib/base/Data/IORef.hs 30
-readIORef r = IO $ \_ w -> readRef__ r w
+readIORef r = IO $ \w -> readRef__ r w
hunk ./lib/base/Data/IORef.hs 34
-writeIORef r v = IO $ \_ w -> case writeRef__ r v w of w' -> (# w', () #)
+writeIORef r v = IO $ \w -> case writeRef__ r v w of w' -> (# w', () #)
hunk ./lib/base/Data/IORef.hs 45
-modifyIORef ref f = IO $ \_ w -> case readRef__ ref w of
+modifyIORef ref f = IO $ \w -> case readRef__ ref w of
hunk ./lib/base/Data/IORef.hs 51
-atomicModifyIORef r f = IO $ \_ w -> case readRef__ r w of
+atomicModifyIORef r f = IO $ \w -> case readRef__ r w of
hunk ./lib/base/Jhc/Enum.hs 8
+import Jhc.Int
hunk ./lib/base/Jhc/Enum.hs 60
-foreign import primitive increment :: Int -> Int
-foreign import primitive decrement :: Int -> Int
-foreign import primitive plus :: Int -> Int -> Int
-foreign import primitive minus :: Int -> Int -> Int
hunk ./lib/base/Jhc/Hole.hs 21
-newHole = IO $ \_ world -> newHole__ world
+newHole = IO $ \world -> newHole__ world
hunk ./lib/base/Jhc/Hole.hs 30
-fillHole r v = IO $ \_ world -> case fillHole__ r v world of
+fillHole r v = IO $ \world -> case fillHole__ r v world of
hunk ./lib/base/Jhc/IO.hs 1
-{-# OPTIONS_JHC -funboxed-tuples #-}
+{-# OPTIONS_JHC -N -funboxed-tuples #-}
hunk ./lib/base/Jhc/IO.hs 5
---    IOResult(..),
hunk ./lib/base/Jhc/IO.hs 6
-    IOErrorCont(),
hunk ./lib/base/Jhc/IO.hs 15
-    undefinedIOErrorCont,
hunk ./lib/base/Jhc/IO.hs 16
+    error,
+    IOError(),
+    showIOError,
+    userError,
hunk ./lib/base/Jhc/IO.hs 23
-import Jhc.Hole
-import Jhc.JumpPoint
hunk ./lib/base/Jhc/IO.hs 24
-import Prelude.IOError
+import Jhc.Basics
+import Jhc.Order
+import Foreign.C.Types
+import qualified Jhc.Options
hunk ./lib/base/Jhc/IO.hs 30
-data IOErrorCont = IOErrorCont JumpPoint (Hole IOError)
+-- basic types
hunk ./lib/base/Jhc/IO.hs 32
---data IOResult a = FailIO World__ IOError | JustIO World__ a
--- data IOResult a = JustIO World__ a
+newtype IO a = IO (World__ -> (# World__, a #))
hunk ./lib/base/Jhc/IO.hs 34
-newtype IO a = IO (IOErrorCont -> World__ -> (# World__, a #))
+unIO :: IO a -> World__ -> (# World__, a #)
+unIO (IO x) = x
hunk ./lib/base/Jhc/IO.hs 38
-undefinedIOErrorCont :: IOErrorCont
-undefinedIOErrorCont = IOErrorCont errorJumpPoint errorHole
-
-showError :: IOError -> IO b
-showError (IOError z) = do
-    putStrLn z
-    exitFailure
-
-errorContinuation :: IO a -> IO a
-errorContinuation x = catch x showError
+-- unsafe operations
hunk ./lib/base/Jhc/IO.hs 43
-        IO y -> case y undefinedIOErrorCont world of
+        IO y -> case y world of
hunk ./lib/base/Jhc/IO.hs 48
-unsafeInterleaveIO action = IO $ \c w -> (# w , case action' c w of (# _,  a #) -> a #)
+unsafeInterleaveIO action = IO $ \w -> (# w , case action' w of (# _,  a #) -> a #)
hunk ./lib/base/Jhc/IO.hs 51
-instance Monad IO where
-    return x = IO $ \_ w -> (# w,  x #)
-    IO x >>= f = IO $ \c w -> case x c w of
-        (# w, v #) -> case f v of
-            IO g -> g c w
-    IO x >> IO y = IO $ \c w -> case x c w of
-        (# w,  _ #) -> y c w
-    fail s = ioError $ userError s
hunk ./lib/base/Jhc/IO.hs 52
-instance Functor IO where
-    fmap f a = a >>= \x -> return (f x)
+-- IO Exception handling
+
+newtype IOError = IOError String
+    deriving(Eq)
+
+showIOError :: IOError -> String
+showIOError (IOError x) = x
+
+userError       :: String  -> IOError
+userError str	=  IOError  str
+
+showError :: IOError -> IO b
+showError (IOError z) = putErrLn z `thenIO_` exitFailure
+
+errorContinuation :: IO a -> IO a
+errorContinuation x = catch x showError
+
+ioError    ::  IOError -> IO a
+ioError e  = case Jhc.Options.target of
+    Jhc.Options.GhcHs -> IO $ \w -> raiseIO__ e w
+    _ -> showError e
+
+
+catch :: IO a -> (IOError -> IO a) -> IO a
+catch (IO m) k =  case Jhc.Options.target of
+    Jhc.Options.GhcHs -> IO $ \s -> catch__ m (\ex -> unIO (k ex)) s
+    _ -> IO m  -- no catching on other targets just yet
+
+
+-- IO fixpoint operation
hunk ./lib/base/Jhc/IO.hs 86
-fixIO k = IO $ \c w -> let
+fixIO k = IO $ \w -> let
hunk ./lib/base/Jhc/IO.hs 88
-                    IO z -> case z c w of
+                    IO z -> case z w of
hunk ./lib/base/Jhc/IO.hs 95
-getJumpPoint :: IO IOErrorCont
-getJumpPoint = IO $ \ ioe w -> (# w, ioe #)
-
-ioError    ::  IOError -> IO a
-ioError e   =  do
-    IOErrorCont jp he <- getJumpPoint
-    fillHole he e
-    jumpJumpPoint__ jp
-
hunk ./lib/base/Jhc/IO.hs 96
+-- some primitives
hunk ./lib/base/Jhc/IO.hs 98
-catch ::  IO a -> (IOError -> IO a) -> IO a
-catch (IO x) fn = do
-    hole <- newHole
-    withJumpPoint__ $ \jp b -> case b of
-        False -> IO $ \_ w -> x (IOErrorCont jp hole) w
-        True -> readHole hole >>= fn
hunk ./lib/base/Jhc/IO.hs 101
-
-
--- throws away first argument. but causes second argument to artificially depend on it.
hunk ./lib/base/Jhc/IO.hs 105
-strictReturn a = IO $ \_ w -> (# w, worldDep__ w a #)
+strictReturn a = IO $ \w -> (# w, worldDep__ w a #)
hunk ./lib/base/Jhc/IO.hs 107
-{-# INLINE runMain, runExpr #-}
+{-# INLINE runMain #-}
hunk ./lib/base/Jhc/IO.hs 110
-runMain main w = case run undefinedIOErrorCont w of
+runMain main w = case run w of
hunk ./lib/base/Jhc/IO.hs 113
-    IO run = catch main $ \e -> do
-            putStrLn "\nUncaught Exception:"
-            putStrLn $ showIOError e
+    IO run = catch main $ \e ->
+            putErrLn "\nUncaught Exception:" `thenIO_`
+            putErrLn (showIOError e)         `thenIO_`
hunk ./lib/base/Jhc/IO.hs 119
--- | this is wrapped around arbitrary showable expressions when used as the main entry point
-runExpr :: Show a => a -> World__ -> World__
-runExpr x w = runNoWrapper (print x) w
-
hunk ./lib/base/Jhc/IO.hs 122
-runNoWrapper (IO run) w =
-    case run undefinedIOErrorCont w of
-        (# w, _ #) -> w
+runNoWrapper (IO run) w = case run w of (# w, _ #) -> w
hunk ./lib/base/Jhc/IO.hs 125
-exitFailure = IO $ \_ w -> exitFailure__ w
+exitFailure = IO $ \w -> exitFailure__ w
hunk ./lib/base/Jhc/IO.hs 130
+thenIO_ :: IO a -> IO b -> IO b
+IO a `thenIO_` IO b = IO $ \w -> case a w of
+    (# w', _ #) -> b w'
+
+IO a `thenIO` b = IO $ \w -> case a w of
+    (# w', v #) -> unIO (b v) w'
+
+{-# NOINLINE error #-}
+error s = unsafePerformIO $
+    putErrLn "error:"  `thenIO_`
+    putErrLn s         `thenIO_`
+    exitFailure
+
+-- | no the implicit unsafeCoerce__ here!
+foreign import primitive catch__ :: (World__ -> (# World__,a #)) -> (b -> World__ -> (# World__,a #)) -> World__ -> (# World__,a #)
+foreign import primitive raiseIO__ :: a -> World__ -> (# World__,b #)
+
+
+putErrLn :: [Char] -> IO ()
+putErrLn [] = putChar '\n'
+putErrLn (c:cs) = putChar c `thenIO_` putErrLn cs
+putChar :: Char -> IO ()
+putChar c = c_putwchar (charToCWchar c)
+
+foreign import primitive "integralCast" charToCWchar :: Char -> CWchar
+foreign import ccall "stdio.h putwchar" c_putwchar :: CWchar -> IO ()
hunk ./lib/base/Jhc/List.hs 1
+{-# OPTIONS_JHC -N #-}
hunk ./lib/base/Jhc/List.hs 5
+import Jhc.IO(error)
+import Jhc.Int
+import Jhc.Order
+import Jhc.Monad
+
hunk ./lib/base/Jhc/List.hs 85
+filter :: (a -> Bool) -> [a] -> [a]
+filter p []                 = []
+filter p (x:xs) | p x       = x : filter p xs
+                | otherwise = filter p xs
+
+infixl 9  !!
hunk ./lib/base/Jhc/List.hs 93
-xs !! n | n < 0   =  error "Prelude.(!!): negative index\n"
+xs !! n | n < zero  =  error "Prelude.(!!): negative index\n"
hunk ./lib/base/Jhc/List.hs 98
-                sub (y:ys) n = if n == 0
+                sub (y:ys) n = if n == zero
hunk ./lib/base/Jhc/List.hs 100
-                               else sub ys $! (n - 1)
+                               else sub ys $! (n `minus` one)
hunk ./lib/base/Jhc/Monad.hs 1
+{-# OPTIONS_JHC -N #-}
+
+module Jhc.Monad where
+
+import Jhc.Basics
+import Jhc.IO
+
+-- Monadic classes
+
+infixl 1  >>, >>=
+infixr 1  =<<
+
+class Functor f  where
+    fmap              :: (a -> b) -> f a -> f b
+
+{- INLINE return, fail, (>>=), (>>) -}
+class Monad m  where
+    (>>=)  :: m a -> (a -> m b) -> m b
+    (>>)   :: m a -> m b -> m b
+    return :: a -> m a
+    fail   :: String -> m a
+
+        -- Minimal complete definition:
+        --      (>>=), return
+    m >> k  =  m >>= \_ -> k
+    fail s  = error s
+
+mapM             :: Monad m => (a -> m b) -> [a] -> m [b]
+mapM f as = go as where
+    go [] = return []
+    go (a:as) = do
+        a' <- f a
+        as' <- go as
+        return (a':as')
+
+mapM_            :: Monad m => (a -> m b) -> [a] -> m ()
+mapM_ f as = go as where
+    go [] = return ()
+    go (a:as) = f a >> go as
+
+(=<<)            :: Monad m => (a -> m b) -> m a -> m b
+f =<< x          =  x >>= f
+
+
+
+instance Monad [] where
+    return x = [x]
+    xs >>= f = concatMap f xs
+    fail _ = []
+
+instance Functor [] where
+    fmap f (x:xs) = f x : fmap f xs
+    fmap f [] = []
+
+instance Monad IO where
+    return x = IO $ \w -> (# w, x #)
+    IO x >>= f = IO $ \w -> case x w of
+        (# w, v #) -> case f v of
+            IO g -> g w
+    IO x >> IO y = IO $ \w -> case x w of
+        (# w,  _ #) -> y w
+    fail s = ioError $ userError s
+
+instance Functor IO where
+    fmap f a = a >>= \x -> return (f x)
+
+
hunk ./lib/base/Prelude/IO.hs 5
+    runExpr,
hunk ./lib/base/Prelude/IO.hs 113
+-- | this is wrapped around arbitrary showable expressions when used as the main entry point
+runExpr :: Show a => a -> World__ -> World__
+runExpr x w = runNoWrapper (print x) w
+
hunk ./lib/base/Prelude/IOError.hs 1
-module Prelude.IOError where
+module Prelude.IOError(IOError(),showIOError,userError) where
hunk ./lib/base/Prelude/IOError.hs 3
+import Jhc.IO
hunk ./lib/base/Prelude/IOError.hs 5
-newtype IOError = IOError String
-    deriving(Show,Eq)
-
-showIOError :: IOError -> String
-showIOError (IOError x) = x
+instance Show IOError where
+    showsPrec _ s = showString (showIOError s)
hunk ./lib/base/Prelude/IOError.hs 9
+
+
hunk ./lib/base/Prelude/IOError.hs 62
-userError       :: String  -> IOError
-userError str	=  IOError  str
hunk ./lib/base/Prelude.hs 11
-
+    error,
hunk ./lib/base/Prelude.hs 27
+    module Jhc.Monad,
hunk ./lib/base/Prelude.hs 49
+import Jhc.Monad
hunk ./lib/base/Prelude.hs 61
-infixl 1  >>, >>=
-infixr 1  =<<
+--infixl 1  >>, >>=
+--infixr 1  =<<
hunk ./lib/base/Prelude.hs 289
- -- Monadic classes
-
-class Functor f  where
-    fmap              :: (a -> b) -> f a -> f b
-
-{- INLINE return, fail, (>>=), (>>) -}
-class Monad m  where
-    (>>=)  :: m a -> (a -> m b) -> m b
-    (>>)   :: m a -> m b -> m b
-    return :: a -> m a
-    fail   :: String -> m a
-
-        -- Minimal complete definition:
-        --      (>>=), return
-    m >> k  =  m >>= \_ -> k
-    fail s  = error s
-
---sequence       :: Monad m => [m a] -> m [a]
---sequence       =  foldr mcons (return [])
---                    where mcons p q = p >>= \x -> q >>= \y -> return (x:y)
---sequence_      :: Monad m => [m a] -> m ()
---sequence_      =  foldr (>>) (return ())
-
--- The xxxM functions take list arguments, but lift the function or
--- list element to a monad type
-
--- manually deforested for now
-
-mapM             :: Monad m => (a -> m b) -> [a] -> m [b]
---mapM f as        =  sequence (map f as)
-mapM f as = go as where
-    go [] = return []
-    go (a:as) = do
-        a' <- f a
-        as' <- go as
-        return (a':as')
-
-mapM_            :: Monad m => (a -> m b) -> [a] -> m ()
---mapM_ f as       =  sequence_ (map f as)
-mapM_ f as = go as where
-    go [] = return ()
-    go (a:as) = f a >> go as
-
-(=<<)            :: Monad m => (a -> m b) -> m a -> m b
-f =<< x          =  x >>= f
-
hunk ./lib/base/Prelude.hs 298
-instance Monad [] where
-    return x = [x]
-    xs >>= f = concatMap f xs
-    fail _ = []
-
-
-
-
-instance Functor [] where
-    fmap f (x:xs) = f x : fmap f xs
-    fmap f [] = []
hunk ./lib/base/Prelude.hs 300
--- Basic combinators
+instance Functor Maybe where
+    fmap _ Nothing = Nothing
+    fmap f (Just x) = Just (f x)
hunk ./lib/base/Prelude.hs 335
--- module PreludeList (
---    map, (++), filter, concat, concatMap,
---    head, last, tail, init, null, length, (!!),
---    foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
---    iterate, repeat, replicate, cycle,
---    take, drop, splitAt, takeWhile, dropWhile, span, break,
---    lines, words, unlines, unwords, reverse, and, or,
---    any, all, elem, notElem, lookup,
---    sum, product, maximum, minimum,
---    zip, zip3, zipWith, zipWith3, unzip, unzip3)
---  where
-
-
-infixl 9  !!
-infix  4  `elem`, `notElem`
-
-
-
-filter :: (a -> Bool) -> [a] -> [a]
-filter p []                 = []
-filter p (x:xs) | p x       = x : filter p xs
-                | otherwise = filter p xs
-
-
---concat :: [[a]] -> [a]
---concat xss = foldr (++) [] xss
-
-
---concatMap :: (a -> [b]) -> [a] -> [b]
---concatMap f = foldr ((++) . f) []
---concatMap f = concat . map f
-
--- head and tail extract the first element and remaining elements,
--- respectively, of a list, which must be non-empty.  last and init
--- are the dual functions working from the end of a finite list,
--- rather than the beginning.
-
-
hunk ./lib/base/Prelude.hs 538
---unwords []       =  ""
---unwords ws       =  foldr1 (\w s -> w ++ ' ':s) ws
-
--- reverse xs returns the elements of xs in reverse order.  xs must be finite.
-
-
--- and returns the conjunction of a Boolean list.  For the result to be
--- True, the list must be finite; False, however, results from a False
--- value at a finite index of a finite or infinite list.  or is the
--- disjunctive dual of and.
-
--- from Jhc.List
---and, or          :: [Bool] -> Bool
---and              =  foldr (&&) True
---or               =  foldr (||) False
-
--- Applied to a predicate and a list, any determines if any element
--- of the list satisfies the predicate.  Similarly, for all.
-
---any, all         :: (a -> Bool) -> [a] -> Bool
---any p            =  or . map p
---all p            =  and . map p
hunk ./lib/base/Prelude.hs 542
+infix  4  `elem`, `notElem`
+
hunk ./lib/base/Prelude.hs 601
--- We don't inline this so there is a better chance calls to it will be recognized as bottom
-
-{-# NOINLINE error #-}
-error s = unsafePerformIO $ do
-    putStrLn "error:"
-    putStrLn s
-    exitFailure
-
-
-