ordClassKey,
orderingTyConKey,
otherwiseIdKey,
- packCStringIdKey,
parErrorIdKey,
parIdKey,
patErrorIdKey,
lexIdKey = mkPreludeMiscIdUnique 16
noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 17
nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 18
-packCStringIdKey = mkPreludeMiscIdUnique 19
parErrorIdKey = mkPreludeMiscIdUnique 20
parIdKey = mkPreludeMiscIdUnique 21
patErrorIdKey = mkPreludeMiscIdUnique 22
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}
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
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")
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,
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"
-- mentioned. Subset of builtinNames.
-- Here are the thin-air Ids themselves
addr2IntegerId,
- packStringForCId, unpackCStringId, unpackCString2Id,
+ unpackCStringId, unpackCString2Id,
unpackCStringAppendId, unpackCStringFoldrId,
foldrId, buildId,
-- 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)
addr2IntegerId = lookupThinAirId addr2IntegerIdKey
-packStringForCId = lookupThinAirId packCStringIdKey
unpackCStringId = lookupThinAirId unpackCStringIdKey
unpackCString2Id = lookupThinAirId unpackCString2IdKey
unpackCStringAppendId = lookupThinAirId unpackCStringAppendIdKey
NamedThing(..), OccName
)
import TyCon ( TyCon, isDataTyCon )
-import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId )
import PrelRules ( builtinRules )
import Type ( Type,
isUnLiftedType,
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__ */
\section[Ix]{Module @Ix@}
\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
-
module Ix
(
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<h, but the range
--- is nevertheless empty. Consider
--- ((1,2),(2,1))
--- Here l<h, but the second index ranges from 2..1 and
--- hence is empty
-\end{code}
-
-\begin{code}
-#else
--- This module is empty; Ix is currently defined in the prelude, but should
--- eventually be moved to this library file instead.
-#endif
-\end{code}
\section[Monad]{Module @Monad@}
\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
-
module Monad
( MonadPlus ( -- class context: Monad
mzero -- :: (MonadPlus m) => m a
, (=<<) -- :: (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}
%*********************************************************
%*********************************************************
\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 ()
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}
module PrelArr where
import {-# SOURCE #-} PrelErr ( error )
-import Ix
import PrelList (foldl)
+import PrelEnum
+import PrelNum
import PrelST
import PrelBase
import PrelAddr
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<h, but the range
+-- is nevertheless empty. Consider
+-- ((1,2),(2,1))
+-- Here l<h, but the second index ranges from 2..1 and
+-- hence is empty
\end{code}
+
%*********************************************************
%* *
\subsection{The @Array@ types}
"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
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 ->
-- 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
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
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
module PrelArrExtra where
-import Ix
import PrelArr
import PrelByteArr
import PrelST
import {-# SOURCE #-} PrelErr ( error )
import PrelArr
import PrelFloat
-import Ix
import PrelList (foldl)
import PrelST
import PrelBase
#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(..) )
#ifndef __PARALLEL_HASKELL__
import PrelWeak ( addForeignFinalizer )
#endif
-import Ix
import PrelConc
import PrelMaybe
import PrelShow -- isAlpha etc
import PrelBase
-import Monad
-- needed for readIO and instance Read Buffermode
import PrelIOBase ( IO, userError, BufferMode(..) )
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}
module PrelST where
-import Monad
import PrelShow
import PrelBase
import PrelGHC
RealFrac(..),
RealFloat(..),
- -- From Monad
+ -- Monad stuff, from PrelBase, and defined here
Monad(..),
Functor(..),
mapM, mapM_, sequence, sequence_, (=<<),
#ifndef USE_REPORT_PRELUDE
hiding ( takeUInt_append )
#endif
+import PrelIOBase
+import PrelException
import PrelRead
import PrelEnum
import PrelNum
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
%*********************************************************
%* *
+\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}
%* *
%*********************************************************
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}
projects / ghc-hetmet.git / commitdiff