From 940841711bb0c30326a5173d8107c2792919641c Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 10 Apr 2000 12:12:28 +0000 Subject: [PATCH] [project @ 2000-04-10 12:12:27 by simonpj] Make it so that (A) All modules imported by Prelude are PrelXXX modules, not library modules (notably Ix, Monad were culprits). This lines up with the Hugs story, and is more intuitive. (B) All things needed implicitly by syntax (e.g. do-notation needs Monad) come from PrelXXX modules, even if they aren't visible when you say 'import Prelude'. These changes simplify the story, and fix the 'looking for [boot] interface for Ix' problem. This change is not quite complete. I'm committing it so Simon can finish it off. --- ghc/compiler/basicTypes/Unique.lhs | 2 - ghc/compiler/coreSyn/CoreSyn.lhs | 2 +- ghc/compiler/deSugar/DsCCall.lhs | 1 - ghc/compiler/prelude/PrelInfo.lhs | 8 +- ghc/compiler/prelude/PrelMods.lhs | 7 +- ghc/compiler/prelude/ThinAir.lhs | 6 +- ghc/compiler/simplCore/SimplCore.lhs | 1 - ghc/lib/std/IO.lhs | 62 +-------- ghc/lib/std/Ix.lhs | 250 +-------------------------------- ghc/lib/std/Monad.lhs | 46 +------ ghc/lib/std/PrelArr.lhs | 253 ++++++++++++++++++++++++++++++++-- ghc/lib/std/PrelArrExtra.lhs | 1 - ghc/lib/std/PrelByteArr.lhs | 1 - ghc/lib/std/PrelHandle.lhs | 2 +- ghc/lib/std/PrelRead.lhs | 17 ++- ghc/lib/std/PrelST.lhs | 1 - ghc/lib/std/Prelude.lhs | 109 ++++++++++++++- 17 files changed, 379 insertions(+), 390 deletions(-) diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 868fe76..a04fbd6 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -138,7 +138,6 @@ module Unique ( ordClassKey, orderingTyConKey, otherwiseIdKey, - packCStringIdKey, parErrorIdKey, parIdKey, patErrorIdKey, @@ -618,7 +617,6 @@ irrefutPatErrorIdKey = mkPreludeMiscIdUnique 15 lexIdKey = mkPreludeMiscIdUnique 16 noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 17 nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 18 -packCStringIdKey = mkPreludeMiscIdUnique 19 parErrorIdKey = mkPreludeMiscIdUnique 20 parIdKey = mkPreludeMiscIdUnique 21 patErrorIdKey = mkPreludeMiscIdUnique 22 diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index febe178..ebe3177 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -52,7 +52,7 @@ import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType ) import Literal ( Literal(MachStr), mkMachInt ) import PrimOp ( PrimOp ) import DataCon ( DataCon, dataConId ) -import ThinAir ( unpackCStringId, unpackCString2Id, addr2IntegerId ) +import ThinAir ( unpackCStringId, unpackCString2Id ) import VarSet import Outputable \end{code} diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index ecab476..052a9a2 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -23,7 +23,6 @@ import CoreUtils ( exprType, mkCoerce ) import Id ( Id, mkWildId ) import MkId ( mkCCallOpId, realWorldPrimId ) import Maybes ( maybeToBool ) -import PrelInfo ( packStringForCId ) import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) import DataCon ( DataCon, splitProductType_maybe, dataConSourceArity, dataConWrapId ) import CallConv diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 4c94443..a241961 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -418,10 +418,10 @@ floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating") realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat") -- Class Ix -ixClass_RDR = clsQual iX_Name SLIT("Ix") -range_RDR = varQual iX_Name SLIT("range") -index_RDR = varQual iX_Name SLIT("index") -inRange_RDR = varQual iX_Name SLIT("inRange") +ixClass_RDR = clsQual pREL_ARR_Name SLIT("Ix") +range_RDR = varQual pREL_ARR_Name SLIT("range") +index_RDR = varQual pREL_ARR_Name SLIT("index") +inRange_RDR = varQual pREL_ARR_Name SLIT("inRange") -- Class CCallable and CReturnable ccallableClass_RDR = clsQual pREL_GHC_Name SLIT("CCallable") diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs index bb9943d..885685d 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -17,8 +17,8 @@ module PrelMods pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE, pREL_IO_BASE, pREL_PACK, pREL_ERR, pREL_NUM, pREL_FLOAT, pREL_REAL, - pREL_GHC_Name, pRELUDE_Name, mONAD_Name, rATIO_Name, - iX_Name, mAIN_Name, pREL_MAIN_Name, pREL_ERR_Name, + pREL_GHC_Name, pRELUDE_Name, + mAIN_Name, pREL_MAIN_Name, pREL_ERR_Name, pREL_BASE_Name, pREL_NUM_Name, pREL_LIST_Name, pREL_TUP_Name, pREL_ADDR_Name, pREL_READ_Name, pREL_PACK_Name, pREL_CONC_Name, pREL_IO_BASE_Name, @@ -57,9 +57,6 @@ pREL_ERR_Name = mkSrcModule "PrelErr" pREL_REAL_Name = mkSrcModule "PrelReal" pREL_FLOAT_Name = mkSrcModule "PrelFloat" -mONAD_Name = mkSrcModule "Monad" -rATIO_Name = mkSrcModule "Ratio" -iX_Name = mkSrcModule "Ix" pREL_MAIN_Name = mkSrcModule "PrelMain" mAIN_Name = mkSrcModule "Main" iNT_Name = mkSrcModule "Int" diff --git a/ghc/compiler/prelude/ThinAir.lhs b/ghc/compiler/prelude/ThinAir.lhs index 62ee2d2..8852598 100644 --- a/ghc/compiler/prelude/ThinAir.lhs +++ b/ghc/compiler/prelude/ThinAir.lhs @@ -12,7 +12,7 @@ module ThinAir ( -- mentioned. Subset of builtinNames. -- Here are the thin-air Ids themselves addr2IntegerId, - packStringForCId, unpackCStringId, unpackCString2Id, + unpackCStringId, unpackCString2Id, unpackCStringAppendId, unpackCStringFoldrId, foldrId, buildId, @@ -57,9 +57,6 @@ thinAirIdNames -- Needed for converting literals to Integers (used in tidyCoreExpr) (varQual pREL_NUM_Name SLIT("addr2Integer"), addr2IntegerIdKey) - -- String literals - , (varQual pREL_PACK_Name SLIT("packCString#"), packCStringIdKey) - -- Folds and builds; introduced by desugaring list comprehensions , (varQual pREL_BASE_Name SLIT("unpackNBytes#"), unpackCString2IdKey) , (varQual pREL_BASE_Name SLIT("unpackCString#"), unpackCStringIdKey) @@ -81,7 +78,6 @@ noRepStrIds = [unpackCString2Id, unpackCStringId] addr2IntegerId = lookupThinAirId addr2IntegerIdKey -packStringForCId = lookupThinAirId packCStringIdKey unpackCStringId = lookupThinAirId unpackCStringIdKey unpackCString2Id = lookupThinAirId unpackCString2IdKey unpackCStringAppendId = lookupThinAirId unpackCStringAppendIdKey diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index dc8ffb8..ff7749e 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -43,7 +43,6 @@ import Name ( mkLocalName, tidyOccName, tidyTopName, NamedThing(..), OccName ) import TyCon ( TyCon, isDataTyCon ) -import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId ) import PrelRules ( builtinRules ) import Type ( Type, isUnLiftedType, diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs index dcad635..daf0d09 100644 --- a/ghc/lib/std/IO.lhs +++ b/ghc/lib/std/IO.lhs @@ -643,65 +643,13 @@ bracket_ before after m = do Left e -> ioError e \end{code} -%********************************************************* -%* * -\subsection{Standard IO} -%* * -%********************************************************* - -The Prelude has from Day 1 provided a collection of common -IO functions. We define these here, but let the Prelude -export them. - -\begin{code} -putChar :: Char -> IO () -putChar c = hPutChar stdout c - -putStr :: String -> IO () -putStr s = hPutStr stdout s - -putStrLn :: String -> IO () -putStrLn s = do putStr s - putChar '\n' - -print :: Show a => a -> IO () -print x = putStrLn (show x) - -getChar :: IO Char -getChar = hGetChar stdin - -getLine :: IO String -getLine = hGetLine stdin - -getContents :: IO String -getContents = hGetContents stdin -interact :: (String -> String) -> IO () -interact f = do s <- getContents - putStr (f s) -readFile :: FilePath -> IO String -readFile name = openFile name ReadMode >>= hGetContents - -writeFile :: FilePath -> String -> IO () -writeFile name str = do - hdl <- openFile name WriteMode - hPutStr hdl str - hClose hdl - -appendFile :: FilePath -> String -> IO () -appendFile name str = do - hdl <- openFile name AppendMode - hPutStr hdl str - hClose hdl - -readLn :: Read a => IO a -readLn = do l <- getLine - r <- readIO l - return r - - -\end{code} +%********************************************************* +%* * +\subsection{The HUGS version of IO +%* * +%********************************************************* #else /* __HUGS__ */ diff --git a/ghc/lib/std/Ix.lhs b/ghc/lib/std/Ix.lhs index ab733ee..e9981df 100644 --- a/ghc/lib/std/Ix.lhs +++ b/ghc/lib/std/Ix.lhs @@ -5,8 +5,6 @@ \section[Ix]{Module @Ix@} \begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - module Ix ( Ix @@ -29,251 +27,11 @@ module Ix -- Implementation checked wrt. Haskell 98 lib report, 1/99. ) where -#ifndef __HUGS__ -import {-# SOURCE #-} PrelErr ( error ) -import PrelTup -import PrelBase -import PrelList( null ) -import PrelEnum -import PrelShow -import PrelNum - -default() -\end{code} - -%********************************************************* -%* * -\subsection{The @Ix@ class} -%* * -%********************************************************* - -\begin{code} -class (Ord a) => Ix a where - range :: (a,a) -> [a] - index, unsafeIndex :: (a,a) -> a -> Int - inRange :: (a,a) -> a -> Bool - - -- Must specify one of index, unsafeIndex - index b i | inRange b i = unsafeIndex b i - | otherwise = error "Error in array index" - unsafeIndex b i = index b i -\end{code} - -%********************************************************* -%* * -\subsection{Instances of @Ix@} -%* * -%********************************************************* - -\begin{code} --- abstract these errors from the relevant index functions so that --- the guts of the function will be small enough to inline. - -{-# NOINLINE indexError #-} -indexError :: Show a => (a,a) -> a -> String -> b -indexError rng i tp - = error (showString "Ix{" . showString tp . showString "}.index: Index " . - showParen True (showsPrec 0 i) . - showString " out of range " $ - showParen True (showsPrec 0 rng) "") - ----------------------------------------------------------------------- -instance Ix Char where - {-# INLINE range #-} - range (m,n) = [m..n] - - {-# INLINE unsafeIndex #-} - unsafeIndex (m,_n) i = fromEnum i - fromEnum m - - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Char" - - inRange (m,n) i = m <= i && i <= n - ----------------------------------------------------------------------- -instance Ix Int where - {-# INLINE range #-} - -- The INLINE stops the build in the RHS from getting inlined, - -- so that callers can fuse with the result of range - range (m,n) = [m..n] - - {-# INLINE unsafeIndex #-} - unsafeIndex (m,_n) i = i - m - - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Int" - - {-# INLINE inRange #-} - inRange (I# m,I# n) (I# i) = m <=# i && i <=# n - ----------------------------------------------------------------------- -instance Ix Integer where - {-# INLINE range #-} - range (m,n) = [m..n] - - {-# INLINE unsafeIndex #-} - unsafeIndex (m,_n) i = fromInteger (i - m) - - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Integer" - - inRange (m,n) i = m <= i && i <= n - - ----------------------------------------------------------------------- -instance Ix Bool where -- as derived - {-# INLINE range #-} - range (m,n) = [m..n] - - {-# INLINE unsafeIndex #-} - unsafeIndex (l,_) i = fromEnum i - fromEnum l - - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Bool" - - inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u - ----------------------------------------------------------------------- -instance Ix Ordering where -- as derived - {-# INLINE range #-} - range (m,n) = [m..n] +import Prelude - {-# INLINE unsafeIndex #-} - unsafeIndex (l,_) i = fromEnum i - fromEnum l +-- This module is empty, because Ix is defined in PrelArr. +-- Reason: it's needed internally in the Prelude. +-- This module serves solely to export it to the user. - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Ordering" - - inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u - ----------------------------------------------------------------------- -instance Ix () where - {-# INLINE range #-} - range ((), ()) = [()] - {-# INLINE unsafeIndex #-} - unsafeIndex ((), ()) () = 0 - {-# INLINE inRange #-} - inRange ((), ()) () = True - {-# INLINE index #-} - index b i = unsafeIndex b i - - ----------------------------------------------------------------------- -instance (Ix a, Ix b) => Ix (a, b) where -- as derived - {-# SPECIALISE instance Ix (Int,Int) #-} - - {- INLINE range #-} - range ((l1,l2),(u1,u2)) = - [ (i1,i2) | i1 <- range (l1,u1), i2 <- range (l2,u2) ] - - {- INLINE unsafeIndex #-} - unsafeIndex ((l1,l2),(u1,u2)) (i1,i2) = - unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2 - - {- INLINE inRange #-} - inRange ((l1,l2),(u1,u2)) (i1,i2) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 - - -- Default method for index - ----------------------------------------------------------------------- -instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where - {-# SPECIALISE instance Ix (Int,Int,Int) #-} - - range ((l1,l2,l3),(u1,u2,u3)) = - [(i1,i2,i3) | i1 <- range (l1,u1), - i2 <- range (l2,u2), - i3 <- range (l3,u3)] - - unsafeIndex ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = - unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( - unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( - unsafeIndex (l1,u1) i1)) - - inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 && - inRange (l3,u3) i3 - - -- Default method for index - ----------------------------------------------------------------------- -instance (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1,a2,a3,a4) where - range ((l1,l2,l3,l4),(u1,u2,u3,u4)) = - [(i1,i2,i3,i4) | i1 <- range (l1,u1), - i2 <- range (l2,u2), - i3 <- range (l3,u3), - i4 <- range (l4,u4)] - - unsafeIndex ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) = - unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * ( - unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( - unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( - unsafeIndex (l1,u1) i1))) - - inRange ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 && - inRange (l3,u3) i3 && inRange (l4,u4) i4 - - -- Default method for index - -instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5) where - range ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) = - [(i1,i2,i3,i4,i5) | i1 <- range (l1,u1), - i2 <- range (l2,u2), - i3 <- range (l3,u3), - i4 <- range (l4,u4), - i5 <- range (l5,u5)] - - unsafeIndex ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) = - unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * ( - unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * ( - unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( - unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( - unsafeIndex (l1,u1) i1)))) - - inRange ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 && - inRange (l3,u3) i3 && inRange (l4,u4) i4 && - inRange (l5,u5) i5 - - -- Default method for index \end{code} -%******************************************************** -%* * -\subsection{Size of @Ix@ interval} -%* * -%******************************************************** - -The @rangeSize@ operator returns the number of elements -in the range for an @Ix@ pair. - -\begin{code} -{-# SPECIALISE unsafeRangeSize :: (Int,Int) -> Int #-} -{-# SPECIALISE unsafeRangeSize :: ((Int,Int),(Int,Int)) -> Int #-} -unsafeRangeSize :: (Ix a) => (a,a) -> Int -unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - -{-# SPECIALISE rangeSize :: (Int,Int) -> Int #-} -{-# SPECIALISE rangeSize :: ((Int,Int),(Int,Int)) -> Int #-} -rangeSize :: (Ix a) => (a,a) -> Int -rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1 - | otherwise = 0 - --- Note that the following is NOT right --- rangeSize (l,h) | l <= h = index b h + 1 --- | otherwise = 0 --- --- Because it might be the case that l m a @@ -39,14 +37,7 @@ module Monad , (=<<) -- :: (Monad m) => (a -> m b) -> m a -> m b ) where -#ifndef __HUGS__ -import PrelList -import PrelTup -import PrelBase -import PrelMaybe ( Maybe(..) ) - -infixr 1 =<< -#endif +import Prelude \end{code} %********************************************************* @@ -80,32 +71,6 @@ instance MonadPlus Maybe where %********************************************************* \begin{code} -#ifdef __HUGS__ --- These functions are defined in the Prelude. --- sequence :: Monad m => [m a] -> m [a] --- sequence_ :: Monad m => [m a] -> m () --- mapM :: Monad m => (a -> m b) -> [a] -> m [b] --- mapM_ :: Monad m => (a -> m b) -> [a] -> m () -#else -sequence :: Monad m => [m a] -> m [a] -{-# INLINE sequence #-} -sequence ms = foldr k (return []) ms - where - k m m' = do { x <- m; xs <- m'; return (x:xs) } - -sequence_ :: Monad m => [m a] -> m () -{-# INLINE sequence_ #-} -sequence_ ms = foldr (>>) (return ()) ms - -mapM :: Monad m => (a -> m b) -> [a] -> m [b] -{-# INLINE mapM #-} -mapM f as = sequence (map f as) - -mapM_ :: Monad m => (a -> m b) -> [a] -> m () -{-# INLINE mapM_ #-} -mapM_ f as = sequence_ (map f as) -#endif - guard :: MonadPlus m => Bool -> m () guard pred | pred = return () @@ -125,15 +90,6 @@ filterM predM (x:xs) = do msum :: MonadPlus m => [m a] -> m a {-# INLINE msum #-} msum = foldr mplus mzero - -#ifdef __HUGS__ --- This function is defined in the Prelude. ---(=<<) :: Monad m => (a -> m b) -> m a -> m b -#else -{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-} -(=<<) :: Monad m => (a -> m b) -> m a -> m b -f =<< x = x >>= f -#endif \end{code} diff --git a/ghc/lib/std/PrelArr.lhs b/ghc/lib/std/PrelArr.lhs index c281130..e930bad 100644 --- a/ghc/lib/std/PrelArr.lhs +++ b/ghc/lib/std/PrelArr.lhs @@ -14,8 +14,9 @@ For byte-arrays see @PrelByteArr@. module PrelArr where import {-# SOURCE #-} PrelErr ( error ) -import Ix import PrelList (foldl) +import PrelEnum +import PrelNum import PrelST import PrelBase import PrelAddr @@ -27,28 +28,241 @@ infixl 9 !, // default () \end{code} + +%********************************************************* +%* * +\subsection{The @Ix@ class} +%* * +%********************************************************* + \begin{code} -{-# SPECIALISE array :: (Int,Int) -> [(Int,b)] -> Array Int b #-} -array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b +class (Ord a) => Ix a where + range :: (a,a) -> [a] + index, unsafeIndex :: (a,a) -> a -> Int + inRange :: (a,a) -> a -> Bool + + -- Must specify one of index, unsafeIndex + index b i | inRange b i = unsafeIndex b i + | otherwise = error "Error in array index" + unsafeIndex b i = index b i +\end{code} -{-# SPECIALISE (!) :: Array Int b -> Int -> b #-} -(!) :: (Ix a) => Array a b -> a -> b -{-# SPECIALISE (//) :: Array Int b -> [(Int,b)] -> Array Int b #-} -(//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b +%********************************************************* +%* * +\subsection{Instances of @Ix@} +%* * +%********************************************************* -{-# SPECIALISE accum :: (b -> c -> b) -> Array Int b -> [(Int,c)] -> Array Int b #-} -accum :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b +\begin{code} +-- abstract these errors from the relevant index functions so that +-- the guts of the function will be small enough to inline. -{-# SPECIALISE accumArray :: (b -> c -> b) -> b -> (Int,Int) -> [(Int,c)] -> Array Int b #-} -accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b +{-# NOINLINE indexError #-} +indexError :: Show a => (a,a) -> a -> String -> b +indexError rng i tp + = error (showString "Ix{" . showString tp . showString "}.index: Index " . + showParen True (showsPrec 0 i) . + showString " out of range " $ + showParen True (showsPrec 0 rng) "") -bounds :: (Ix a) => Array a b -> (a,a) -assocs :: (Ix a) => Array a b -> [(a,b)] -indices :: (Ix a) => Array a b -> [a] +---------------------------------------------------------------------- +instance Ix Char where + {-# INLINE range #-} + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (m,_n) i = fromEnum i - fromEnum m + + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Char" + + inRange (m,n) i = m <= i && i <= n + +---------------------------------------------------------------------- +instance Ix Int where + {-# INLINE range #-} + -- The INLINE stops the build in the RHS from getting inlined, + -- so that callers can fuse with the result of range + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (m,_n) i = i - m + + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Int" + + {-# INLINE inRange #-} + inRange (I# m,I# n) (I# i) = m <=# i && i <=# n + +---------------------------------------------------------------------- +instance Ix Integer where + {-# INLINE range #-} + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (m,_n) i = fromInteger (i - m) + + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Integer" + + inRange (m,n) i = m <= i && i <= n + + +---------------------------------------------------------------------- +instance Ix Bool where -- as derived + {-# INLINE range #-} + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (l,_) i = fromEnum i - fromEnum l + + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Bool" + + inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u + +---------------------------------------------------------------------- +instance Ix Ordering where -- as derived + {-# INLINE range #-} + range (m,n) = [m..n] + + {-# INLINE unsafeIndex #-} + unsafeIndex (l,_) i = fromEnum i - fromEnum l + + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Ordering" + + inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u + +---------------------------------------------------------------------- +instance Ix () where + {-# INLINE range #-} + range ((), ()) = [()] + {-# INLINE unsafeIndex #-} + unsafeIndex ((), ()) () = 0 + {-# INLINE inRange #-} + inRange ((), ()) () = True + {-# INLINE index #-} + index b i = unsafeIndex b i + + +---------------------------------------------------------------------- +instance (Ix a, Ix b) => Ix (a, b) where -- as derived + {-# SPECIALISE instance Ix (Int,Int) #-} + + {- INLINE range #-} + range ((l1,l2),(u1,u2)) = + [ (i1,i2) | i1 <- range (l1,u1), i2 <- range (l2,u2) ] + + {- INLINE unsafeIndex #-} + unsafeIndex ((l1,l2),(u1,u2)) (i1,i2) = + unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2 + + {- INLINE inRange #-} + inRange ((l1,l2),(u1,u2)) (i1,i2) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 + + -- Default method for index + +---------------------------------------------------------------------- +instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where + {-# SPECIALISE instance Ix (Int,Int,Int) #-} + + range ((l1,l2,l3),(u1,u2,u3)) = + [(i1,i2,i3) | i1 <- range (l1,u1), + i2 <- range (l2,u2), + i3 <- range (l3,u3)] + + unsafeIndex ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( + unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( + unsafeIndex (l1,u1) i1)) + + inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 + + -- Default method for index + +---------------------------------------------------------------------- +instance (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1,a2,a3,a4) where + range ((l1,l2,l3,l4),(u1,u2,u3,u4)) = + [(i1,i2,i3,i4) | i1 <- range (l1,u1), + i2 <- range (l2,u2), + i3 <- range (l3,u3), + i4 <- range (l4,u4)] + + unsafeIndex ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) = + unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * ( + unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( + unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( + unsafeIndex (l1,u1) i1))) + + inRange ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 && inRange (l4,u4) i4 + + -- Default method for index + +instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5) where + range ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) = + [(i1,i2,i3,i4,i5) | i1 <- range (l1,u1), + i2 <- range (l2,u2), + i3 <- range (l3,u3), + i4 <- range (l4,u4), + i5 <- range (l5,u5)] + + unsafeIndex ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) = + unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * ( + unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * ( + unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( + unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( + unsafeIndex (l1,u1) i1)))) + + inRange ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 && inRange (l4,u4) i4 && + inRange (l5,u5) i5 + + -- Default method for index +\end{code} + + +%******************************************************** +%* * +\subsection{Size of @Ix@ interval} +%* * +%******************************************************** + +The @rangeSize@ operator returns the number of elements +in the range for an @Ix@ pair. + +\begin{code} +{-# SPECIALISE unsafeRangeSize :: (Int,Int) -> Int #-} +{-# SPECIALISE unsafeRangeSize :: ((Int,Int),(Int,Int)) -> Int #-} +unsafeRangeSize :: (Ix a) => (a,a) -> Int +unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 + +{-# SPECIALISE rangeSize :: (Int,Int) -> Int #-} +{-# SPECIALISE rangeSize :: ((Int,Int),(Int,Int)) -> Int #-} +rangeSize :: (Ix a) => (a,a) -> Int +rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1 + | otherwise = 0 + +-- Note that the following is NOT right +-- rangeSize (l,h) | l <= h = index b h + 1 +-- | otherwise = 0 +-- +-- Because it might be the case that l "array", "!" and "bounds" are basic; the rest can be defined in terms of them \begin{code} +bounds :: (Ix a) => Array a b -> (a,a) {-# INLINE bounds #-} bounds (Array l u _) = (l,u) +assocs :: (Ix a) => Array a b -> [(a,b)] {-# INLINE assocs #-} -- Want to fuse the list comprehension assocs a = [(i, a!i) | i <- indices a] +indices :: (Ix a) => Array a b -> [a] {-# INLINE indices #-} indices = range . bounds @@ -119,12 +336,16 @@ amap :: (Ix a) => (b -> c) -> Array a b -> Array a c amap f a = array b [(i, f (a!i)) | i <- range b] where b = bounds a +{-# SPECIALISE (!) :: Array Int b -> Int -> b #-} +(!) :: (Ix a) => Array a b -> a -> b (Array l u arr#) ! i = let n# = case (index (l,u) i) of { I# x -> x } -- index fails if out of range in case (indexArray# arr# n#) of (# v #) -> v + +array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b {-# INLINE array #-} array ixs ivs = case rangeSize ixs of { I# n -> @@ -155,6 +376,7 @@ arrEleBottom = error "(Array.!): undefined array element" -- These also go better with magic: (//), accum, accumArray -- *** NB *** We INLINE them all so that their foldr's get to the call site +(//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b {-# INLINE (//) #-} old_array // ivs = runST (do @@ -184,6 +406,7 @@ zap_one f arr (i, new_v) rst = do writeSTArray arr i (f old_v new_v) rst +accum :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b {-# INLINE accum #-} accum f old_array ivs = runST (do @@ -194,6 +417,8 @@ accum f old_array ivs freezeSTArray arr ) + +accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b {-# INLINE accumArray #-} accumArray f zero ixs ivs = runST (do diff --git a/ghc/lib/std/PrelArrExtra.lhs b/ghc/lib/std/PrelArrExtra.lhs index 8984c24..a7769b8 100644 --- a/ghc/lib/std/PrelArrExtra.lhs +++ b/ghc/lib/std/PrelArrExtra.lhs @@ -13,7 +13,6 @@ module. module PrelArrExtra where -import Ix import PrelArr import PrelByteArr import PrelST diff --git a/ghc/lib/std/PrelByteArr.lhs b/ghc/lib/std/PrelByteArr.lhs index 3533ee3..f2a1b10 100644 --- a/ghc/lib/std/PrelByteArr.lhs +++ b/ghc/lib/std/PrelByteArr.lhs @@ -13,7 +13,6 @@ module PrelByteArr where import {-# SOURCE #-} PrelErr ( error ) import PrelArr import PrelFloat -import Ix import PrelList (foldl) import PrelST import PrelBase diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index e73f5b5..a51186e 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -14,6 +14,7 @@ which are supported for them. #ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */ module PrelHandle where +import PrelArr import PrelBase import PrelAddr ( Addr, nullAddr ) import PrelByteArr ( ByteArray(..), MutableByteArray(..) ) @@ -31,7 +32,6 @@ import PrelPack ( packString ) #ifndef __PARALLEL_HASKELL__ import PrelWeak ( addForeignFinalizer ) #endif -import Ix import PrelConc diff --git a/ghc/lib/std/PrelRead.lhs b/ghc/lib/std/PrelRead.lhs index c096e80..3f64865 100644 --- a/ghc/lib/std/PrelRead.lhs +++ b/ghc/lib/std/PrelRead.lhs @@ -21,7 +21,6 @@ import PrelTup import PrelMaybe import PrelShow -- isAlpha etc import PrelBase -import Monad -- needed for readIO and instance Read Buffermode import PrelIOBase ( IO, userError, BufferMode(..) ) @@ -59,6 +58,22 @@ class Read a where readList = readList__ reads \end{code} +In this module we treat [(a,String)] as a monad in MonadPlus +But MonadPlus isn't defined yet, so we simply give local +declarations for mzero and guard suitable for this particular +type. It would also be reasonably to move MonadPlus to PrelBase +along with Monad and Functor, but that seems overkill for one +example + +\begin{code} +mzero :: [a] +mzero = [] + +guard :: Bool -> [()] +guard True = [()] +guard False = [] +\end{code} + %********************************************************* %* * \subsection{Utility functions} diff --git a/ghc/lib/std/PrelST.lhs b/ghc/lib/std/PrelST.lhs index b41c079..77e337a 100644 --- a/ghc/lib/std/PrelST.lhs +++ b/ghc/lib/std/PrelST.lhs @@ -8,7 +8,6 @@ module PrelST where -import Monad import PrelShow import PrelBase import PrelGHC diff --git a/ghc/lib/std/Prelude.lhs b/ghc/lib/std/Prelude.lhs index 01e82b3..8dcb1fe 100644 --- a/ghc/lib/std/Prelude.lhs +++ b/ghc/lib/std/Prelude.lhs @@ -53,7 +53,7 @@ module Prelude ( RealFrac(..), RealFloat(..), - -- From Monad + -- Monad stuff, from PrelBase, and defined here Monad(..), Functor(..), mapM, mapM_, sequence, sequence_, (=<<), @@ -74,6 +74,8 @@ import PrelList #ifndef USE_REPORT_PRELUDE hiding ( takeUInt_append ) #endif +import PrelIOBase +import PrelException import PrelRead import PrelEnum import PrelNum @@ -83,13 +85,20 @@ import PrelTup import PrelMaybe import PrelShow import PrelConc -import Monad -import Maybe import PrelErr ( error ) -import IO +infixr 1 =<< infixr 0 $! +\end{code} + +%********************************************************* +%* * +\subsection{Miscellaneous functions} +%* * +%********************************************************* + +\begin{code} ($!) :: (a -> b) -> a -> b f $! x = x `seq` f x @@ -136,6 +145,37 @@ product l = prod l 1 %********************************************************* %* * +\subsection{Prelude monad functions} +%* * +%********************************************************* + +\begin{code} +{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-} +(=<<) :: Monad m => (a -> m b) -> m a -> m b +f =<< x = x >>= f + +sequence :: Monad m => [m a] -> m [a] +{-# INLINE sequence #-} +sequence ms = foldr k (return []) ms + where + k m m' = do { x <- m; xs <- m'; return (x:xs) } + +sequence_ :: Monad m => [m a] -> m () +{-# INLINE sequence_ #-} +sequence_ ms = foldr (>>) (return ()) ms + +mapM :: Monad m => (a -> m b) -> [a] -> m [b] +{-# INLINE mapM #-} +mapM f as = sequence (map f as) + +mapM_ :: Monad m => (a -> m b) -> [a] -> m () +{-# INLINE mapM_ #-} +mapM_ f as = sequence_ (map f as) +\end{code} + + +%********************************************************* +%* * \subsection{Coercions} %* * %********************************************************* @@ -168,3 +208,64 @@ fromIntegral = fromInteger . toInteger realToFrac :: (Real a, Fractional b) => a -> b realToFrac = fromRational . toRational \end{code} + + +%********************************************************* +%* * +\subsection{Standard IO} +%* * +%********************************************************* + +The Prelude has from Day 1 provided a collection of common +IO functions. We define these here, but let the Prelude +export them. + +\begin{code} +putChar :: Char -> IO () +putChar c = hPutChar stdout c + +putStr :: String -> IO () +putStr s = hPutStr stdout s + +putStrLn :: String -> IO () +putStrLn s = do putStr s + putChar '\n' + +print :: Show a => a -> IO () +print x = putStrLn (show x) + +getChar :: IO Char +getChar = hGetChar stdin + +getLine :: IO String +getLine = hGetLine stdin + +getContents :: IO String +getContents = hGetContents stdin + +interact :: (String -> String) -> IO () +interact f = do s <- getContents + putStr (f s) + +readFile :: FilePath -> IO String +readFile name = openFile name ReadMode >>= hGetContents + +writeFile :: FilePath -> String -> IO () +writeFile name str = do + hdl <- openFile name WriteMode + hPutStr hdl str + hClose hdl + +appendFile :: FilePath -> String -> IO () +appendFile name str = do + hdl <- openFile name AppendMode + hPutStr hdl str + hClose hdl + +readLn :: Read a => IO a +readLn = do l <- getLine + r <- readIO l + return r + + +\end{code} -- 1.7.10.4