packages feed

lhc 0.6.20081210 → 0.6.20081210.1

raw patch · 92 files changed

+9596/−3 lines, 92 files

Files

lhc.cabal view
@@ -1,6 +1,6 @@ cabal-version:       >= 1.2 name:                lhc-version:             0.6.20081210+version:             0.6.20081210.1 synopsis:            LHC Haskell Compiler description:   lhc is a haskell compiler which aims to produce the most efficient programs possible via whole@@ -14,10 +14,101 @@ homepage:            http://lhc.seize.it/ build-type:          Custom Extra-Source-Files:  src/arch/generic.arch, src/arch/i686.arch, src/arch/x86_64.arch+extra-source-files:  lib/base/base.cabal,+                     lib/base/Setup.hs,+                     lib/base/src/Control/Exception.hs,+                     lib/base/src/Control/Monad.hs,+                     lib/base/src/Data/Array/IO.hs,+                     lib/base/src/Data/Array/Unboxed.hs,+                     lib/base/src/Data/Array.hs,+                     lib/base/src/Data/Bits.hs,+                     lib/base/src/Data/Char.hs,+                     lib/base/src/Data/Complex.hs,+                     lib/base/src/Data/Dynamic.hs,+                     lib/base/src/Data/Int.hs,+                     lib/base/src/Data/IORef.hs,+                     lib/base/src/Data/Ix.hs,+                     lib/base/src/Data/List.hs,+                     lib/base/src/Data/Maybe.hs,+                     lib/base/src/Data/Monoid.hs,+                     lib/base/src/Data/Ratio.hs,+                     lib/base/src/Data/Typeable.hs,+                     lib/base/src/Data/Unicode.hs,+                     lib/base/src/Data/Word.hs,+                     lib/base/src/Foreign/C/Error.hs,+                     lib/base/src/Foreign/C/OldString.hs,+                     lib/base/src/Foreign/C/String.hs,+                     lib/base/src/Foreign/C/Types.hs,+                     lib/base/src/Foreign/C.hs,+                     lib/base/src/Foreign/ForeignPtr.hs,+                     lib/base/src/Foreign/Marshal/Alloc.hs,+                     lib/base/src/Foreign/Marshal/Array.hs,+                     lib/base/src/Foreign/Marshal/Error.hs,+                     lib/base/src/Foreign/Marshal/Pool.hs,+                     lib/base/src/Foreign/Marshal/Utils.hs,+                     lib/base/src/Foreign/Marshal.hs,+                     lib/base/src/Foreign/Ptr.hs,+                     lib/base/src/Foreign/StablePtr.hs,+                     lib/base/src/Foreign/Storable.hs,+                     lib/base/src/Foreign/Storable.m4,+                     lib/base/src/Foreign.hs,+                     lib/base/src/Lhc/ACIO.hs,+                     lib/base/src/Lhc/Addr.hs,+                     lib/base/src/Lhc/Array.hs,+                     lib/base/src/Lhc/Basics.hs,+                     lib/base/src/Lhc/Enum.hs,+                     lib/base/src/Lhc/Float.hs,+                     lib/base/src/Lhc/Handle.hs,+                     lib/base/src/Lhc/Hole.hs,+                     lib/base/src/Lhc/Inst/Enum.hs,+                     lib/base/src/Lhc/Inst/PrimEnum.hs,+                     lib/base/src/Lhc/Inst/Read.hs,+                     lib/base/src/Lhc/Inst/Show.hs,+                     lib/base/src/Lhc/Inst/Storable.hs,+                     lib/base/src/Lhc/Int.hs,+                     lib/base/src/Lhc/IO.hs,+                     lib/base/src/Lhc/JumpPoint.hs,+                     lib/base/src/Lhc/List.hs,+                     lib/base/src/Lhc/Maybe.hs,+                     lib/base/src/Lhc/Monad.hs,+                     lib/base/src/Lhc/Num.hs,+                     lib/base/src/Lhc/Options.hs,+                     lib/base/src/Lhc/Order.hs,+                     lib/base/src/Lhc/Order.m4,+                     lib/base/src/Lhc/Prim.hs,+                     lib/base/src/Lhc/Show.hs,+                     lib/base/src/Lhc/String.hs,+                     lib/base/src/Lhc/Text/Read.hs,+                     lib/base/src/Lhc/Tuples.hs,+                     lib/base/src/Lhc/Types.hs,+                     lib/base/src/Numeric.hs,+                     lib/base/src/Prelude/CType.hs,+                     lib/base/src/Prelude/Float.hs,+                     lib/base/src/Prelude/IO.hs,+                     lib/base/src/Prelude/IOError.hs,+                     lib/base/src/Prelude/Text.hs,+                     lib/base/src/Prelude.hs,+                     lib/base/src/System/Console/GetOpt.hs,+                     lib/base/src/System/CPUTime.hs,+                     lib/base/src/System/Directory.hs,+                     lib/base/src/System/Info.hs,+                     lib/base/src/System/IO/Binary.hs,+                     lib/base/src/System/IO/Continuation.hs,+                     lib/base/src/System/IO/Error.hs,+                     lib/base/src/System/IO/Unsafe.hs,+                     lib/base/src/System/IO.hs,+                     lib/base/src/System/Locale.hs,+                     lib/base/src/System/Random.hs,+                     lib/base/src/System/Time.hs,+                     lib/base/src/System.hs,+                     lib/base/src/Text/Printf.hs,+                     lib/base/src/Text/Show/Functions.hs,+                     lib/base/src/Typeable.hs,+                     lib/base/src/Unsafe/Coerce.hs data-dir:            data data-files:          HsFFI.h names.txt operators.txt prelude.m4 primitives.txt props.txt wsize.h ViaGhc.hs                      rts/lhc_rts.c rts/lhc_rts2.c rts/lhc_rts_alloc.c rts/lhc_rts_header.h -+                      flag base4 flag hpc   default:            False@@ -50,7 +141,6 @@  else   build-depends:      base >= 3 && < 4   Extensions:         PatternSignatures-  if flag(threaded)   ghc-options:        -threaded  if flag(with-base)
+ lib/base/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lib/base/base.cabal view
@@ -0,0 +1,70 @@+Cabal-version:   >= 1.2+Name: base+Version: 1.0+Build-Type: Simple++Library+  Extensions:      ForeignFunctionInterface+  hs-source-dirs:  src+  Exposed-Modules: Control.Exception,+                 Control.Monad,+                 Data.Array,+                 Data.Char,+                 Data.Complex,+                 Data.List,+                 Data.Word,+                 Data.Monoid,+                 Data.Bits,+                 Data.Int,+                 Data.IORef,+                 Data.Ix,+                 Data.Maybe,+                 Data.Ratio,+                 Data.Unicode,+                 Foreign,+                 Foreign.C,+                 Foreign.C.Types,+                 Foreign.C.String,+                 Foreign.C.Error,+                 Foreign.ForeignPtr,+                 Foreign.Marshal+                 Foreign.Marshal.Alloc,+                 Foreign.Marshal.Array,+                 Foreign.Marshal.Error,+                 Foreign.Marshal.Pool,+                 Foreign.Marshal.Utils,+                 Foreign.Ptr,+                 Foreign.StablePtr,+                 Foreign.Storable,+                 Lhc.Addr,+                 Lhc.Basics,+                 Lhc.Float+                 Lhc.Array,+                 Data.Array.IO,+                 Data.Array.Unboxed,+                 Lhc.Handle,+                 Lhc.IO,+                 Lhc.Tuples,+                 Numeric,+                 Prelude.Float,+                 Prelude.IO,+                 Prelude.IOError,+                 Prelude.Text,+                 Prelude,+                 System.Console.GetOpt,+                 System.CPUTime,+                 System.Directory,+                 System.Info,+                 System.IO,+                 System.IO.Error,+                 System.IO.Unsafe,+                 System.IO.Binary,+                 System.Locale,+                 System.Random,+                 System.Time,+                 System+                 Text.Show.Functions+                 Text.Printf++  if !impl(lhc)+    buildable:     False
+ lib/base/src/Control/Exception.hs view
@@ -0,0 +1,60 @@+-- | This is mostly dummy, LHC does not support inexact exceptions.++module Control.Exception where++import Prelude hiding(catch)+import qualified Prelude as P++type IOException = IOError++data Exception = IOException IOException++-- throw :: Exception -> a++throwIO :: Exception -> IO a+throwIO (IOException ioe) = ioError ioe++catch :: IO a -> (Exception -> IO a) -> IO a+catch c h = P.catch c (h . IOException)++catchJust :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a+catchJust et c h = catch c $ \e -> maybe (throwIO e) h (et e)++handle :: (Exception -> IO a) -> IO a -> IO a+handle = flip catch++handleJust :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a+handleJust et h c = catchJust et c h++try :: IO a -> IO (Either Exception a)+try c = catch (fmap Right c) (return . Left)++tryJust :: (Exception -> Maybe b) -> IO a -> IO (Either b a)+tryJust et c = catchJust et (fmap Right c) (return . Left)++-- FIXME this is wrong!+evaluate :: a -> IO a+evaluate = return++-- mapException++ioErrors (IOException _) = True++block, unblock :: IO a -> IO a+block   = id+unblock = id++bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c+bracket before after m = do+        x  <- before+        rs <- try (m x)+        after x+        case rs of+           Right r -> return r+           Left  e -> throwIO e++bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c+bracket_ before after m = bracket before after (const m)++finally :: IO a -> IO b -> IO a+finally cmd end = bracket_ (return ()) (const end) cmd
+ lib/base/src/Control/Monad.hs view
@@ -0,0 +1,136 @@+module Control.Monad(+    MonadPlus(mzero, mplus),+    join, guard, when, unless, ap, msum,+    filterM, mapAndUnzipM, zipWithM, zipWithM_, foldM,+    liftM, liftM2, liftM3, liftM4, liftM5,++    foldM_,replicateM,replicateM_,(>=>),(<=<),forever,++    -- ...and what the Prelude exports+    Monad((>>=), (>>), return, fail),+    Functor(fmap),+    mapM, mapM_, sequence, sequence_, (=<<)+)where++import Lhc.Basics++class Monad m => MonadPlus m where+    mzero :: m a+    mplus :: m a -> m a -> m a+    mzero = fail "mzero"+++instance MonadPlus Maybe where+    mzero = Nothing+    Nothing `mplus` y = y+    x `mplus` _ = x++instance MonadPlus [] where+    mzero = []+    mplus = (++)+++-- Functions+++msum  :: MonadPlus m => [m a] -> m a+msum xs  =  foldr mplus mzero xs++join             :: (Monad m) => m (m a) -> m a+join x           =  x >>= id++when             :: (Monad m) => Bool -> m () -> m ()+when p s         =  if p then s else return ()++unless           :: (Monad m) => Bool -> m () -> m ()+unless p s       =  when (not p) s++ap               :: (Monad m) => m (a -> b) -> m a -> m b+ap               =  liftM2 ($)++guard            :: MonadPlus m => Bool -> m ()+guard p          =  if p then return () else mzero++mapAndUnzipM     :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])+mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip++zipWithM         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]+zipWithM f xs ys =  sequence (zipWith f xs ys)++zipWithM_         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()+zipWithM_ f xs ys =  sequence_ (zipWith f xs ys)++foldM            :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a+foldM f a []     =  return a+foldM f a (x:xs) =  f a x >>= \ y -> foldM f y xs++filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]+filterM p []     = return []+filterM p (x:xs) = do { b  <- p x;+ys <- filterM p xs;+return (if b then (x:ys) else ys)+   }++liftM            :: (Monad m) => (a -> b) -> (m a -> m b)+liftM f          =  \a -> do { a' <- a; return (f a') }++liftM2           :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)+liftM2 f         =  \a b -> do { a' <- a; b' <- b; return (f a' b') }++liftM3           :: (Monad m) => (a -> b -> c -> d) ->+                                 (m a -> m b -> m c -> m d)+liftM3 f         =  \a b c -> do { a' <- a; b' <- b; c' <- c;+   return (f a' b' c') }++liftM4           :: (Monad m) => (a -> b -> c -> d -> e) ->+                                 (m a -> m b -> m c -> m d -> m e)+liftM4 f         =  \a b c d -> do { a' <- a; b' <- b; c' <- c; d' <- d;+     return (f a' b' c' d') }++liftM5           :: (Monad m) => (a -> b -> c -> d -> e -> f) ->+                                 (m a -> m b -> m c -> m d -> m e -> m f)+liftM5 f         =  \a b c d e -> do { a' <- a; b' <- b; c' <- c; d' <- d;+       e' <- e; return (f a' b' c' d' e') }+++-- extensions++-- | Like 'foldM', but discards the result.+foldM_            :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m ()+foldM_ f a xs     = foldM f a xs >> return ()++-- | @'replicateM' n act@ performs the action @n@ times,+-- gathering the results.+replicateM        :: (Monad m) => Int -> m a -> m [a]+replicateM n x    = sequence (replicate n x)++-- | Like 'replicateM', but discards the result.+replicateM_       :: (Monad m) => Int -> m a -> m ()+replicateM_ n x   = sequence_ (replicate n x)+++-- | 'forM' is 'mapM' with its arguments flipped+forM            :: Monad m => [a] -> (a -> m b) -> m [b]+{-# INLINE forM #-}+forM            = flip mapM++-- | 'forM_' is 'mapM_' with its arguments flipped+forM_           :: Monad m => [a] -> (a -> m b) -> m ()+{-# INLINE forM_ #-}+forM_           = flip mapM_++infixr 1 <=<, >=>++-- | Left-to-right Kleisli composition of monads.+(>=>)       :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)+f >=> g     = \x -> f x >>= g++-- | Right-to-left Kleisli composition of monads. '(>=>)', with the+-- arguments flipped+(<=<)       :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)+(<=<)       = flip (>=>)++-- | @'forever' act@ repeats the action infinitely.+forever     :: (Monad m) => m a -> m ()+forever a   = a >> forever a+
+ lib/base/src/Data/Array.hs view
@@ -0,0 +1,90 @@+{-# OPTIONS_LHC -funboxed-tuples #-}+module  Data.Array (+    module Ix,  -- export all of Ix+    Array(),+    array,+    listArray,+    (!),+    bounds,+    indices,+    elems,+    assocs,+    accumArray,+    (//),+    accum,+    ixmap+    ) where++import Data.Ix+import Lhc.Array+import Lhc.Int++infixl 9  !, //+++data Array a b = MkArray !a !a (Array__ b)++array       :: (Ix a) => (a,a) -> [(a,b)] -> Array a b+array b@(s,e) ivs = case newArray (error "array: missing element") (rangeSize b) [(index b x,y) | (x,y) <- ivs] of+        arr -> MkArray s e arr++listArray             :: (Ix a) => (a,a) -> [b] -> Array a b+listArray b vs        =  array b (zipWith (\ a b -> (a,b)) (range b) vs)++(!)                   :: (Ix a) => Array a b -> a -> b+(!) (MkArray s e arr) i =  case unboxInt (index (s,e) i) of i' -> case indexArray__ arr i' of (# r #) -> r++bounds                :: (Ix a) => Array a b -> (a,a)+bounds (MkArray s e _)  =  (s,e)++indices               :: (Ix a) => Array a b -> [a]+indices               =  range . bounds++elems                 :: (Ix a) => Array a b -> [b]+elems a               =  [a!i | i <- indices a]++assocs                :: (Ix a) => Array a b -> [(a,b)]+assocs a              =  [(i, a!i) | i <- indices a]++(//)                  :: (Ix a) => Array a b -> [(a,b)] -> Array a b+a // []               = a+a // new_ivs          = array (bounds a) (old_ivs ++ new_ivs)+                      where+                  	old_ivs = [(i,a!i) | i <- indices a,+                                             i `notElem` new_is]+                  	new_is  = [i | (i,_) <- new_ivs]++accum                 :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b+accum f               =  foldl (\a (i,v) -> a // [(i,f (a!i) v)])++accumArray            :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b+accumArray f z b      =  accum f (array b [(i,z) | i <- range b])++ixmap                 :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c+ixmap b f a           = array b [(i, a ! f i) | i <- range b]++instance  (Ix a)          => Functor (Array a) where+    fmap fn a = array (bounds a) [ (a,fn b) | (a,b) <- assocs a ]++instance  (Ix a, Eq b)  => Eq (Array a b)  where+    a == a' =  assocs a == assocs a'++instance  (Ix a, Ord b) => Ord (Array a b)  where+    a <= a' =  assocs a <= assocs a'++instance  (Ix a, Show a, Show b) => Show (Array a b)  where+    showsPrec p a = showParen (p > arrPrec) (+                    showString "array " .+                    showsPrec (arrPrec+1) (bounds a) . showChar ' ' .+                    showsPrec (arrPrec+1) (assocs a)                  )+instance  (Ix a, Read a, Read b) => Read (Array a b)  where+    readsPrec p = readParen (p > arrPrec)+           (\r -> [ (array b as, u)+                  | ("array",s) <- lex r,+                    (b,t)       <- readsPrec (arrPrec+1) s,+                    (as,u)      <- readsPrec (arrPrec+1) t ])++-- Precedence of the 'array' function is that of application itself+arrPrec :: Int+arrPrec = 10+
+ lib/base/src/Data/Array/IO.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS_LHC -N -funboxed-tuples -fffi #-}+module Data.Array.IO where++import Lhc.Basics+import Data.Ix+import Lhc.Array+import Lhc.IO+import Lhc.Int+import Data.Array++data IOArray a b = IOA !a !a (MutArray__ b)++newIOArray :: Ix a => (a,a) -> b -> IO (IOArray a b)+newIOArray rng fill = IO (newIOArray_ rng fill)++newIOArray_ :: Ix a => (a,a) -> b -> World__ -> (# World__, IOArray a b #)+newIOArray_ rng@(l,h) fill w1 =+    case unboxInt (rangeSize rng) of+      size__ -> case newMutArray__ size__ fill w1 of+                  (# w2, arr #) -> (# w2, IOA l h arr #)+                                     +boundsIOArray :: Ix a => IOArray a b -> IO (a,a)+boundsIOArray (IOA l h _) = returnIO (l,h)++readIOArray :: Ix a => IOArray a b -> a -> IO b+readIOArray (IOA l h arr) i =+    case unboxInt (index (l,h) i) of+      i' -> IO (readArray__ arr i')+    +writeIOArray :: Ix a => IOArray a b -> a -> b -> IO ()+writeIOArray (IOA l h arr) i x =+    case unboxInt (index (l,h) i) of+      i' -> IO (\w1 -> case writeArray__ arr i' x w1 of+                         w2 -> (# w2, () #))++unsafeReadIOArray :: Ix a => IOArray a b -> Int -> IO b+unsafeReadIOArray (IOA l h arr) i = case unboxInt i of i' -> IO (readArray__ arr i')++unsafeWriteIOArray :: Ix a => IOArray a b -> Int -> b -> IO ()+unsafeWriteIOArray (IOA l h arr) i x =+    case unboxInt i of i' -> IO (\w1 -> case writeArray__ arr i' x w1 of+                                          w2 -> (# w2, () #))++{-+freezeIOArray :: Ix a => IOArray a b -> IO (Array a b)+thawIOArray :: Ix a => Array a b -> IO (IOArray a b)++unsafeFreezeIOArray :: Ix a => IOArray a b -> IO (Array a b)+unsafeFreezeIOArray (IOA l h arr) = +    IO (\w1 -> unsafeFreezeArray__ )+-}
+ lib/base/src/Data/Array/Unboxed.hs view
@@ -0,0 +1,82 @@+module Data.Array.Unboxed where++import Data.Ix+import System.IO.Unsafe+import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.ForeignPtr++infixl 9  !, //++data UArray i e = MkArray !i !i (ForeignPtr e)++array       :: (Ix a,Storable b) => (a,a) -> [(a,b)] -> UArray a b+array b@(s,e) ivs = MkArray s e (unsafePerformIO arr) where+    arr = do+        let f :: [(a,b)] -> b; f _ = undefined+        fp <- mallocForeignPtrBytes (sizeOf (f ivs) *  rangeSize b)+        withForeignPtr fp $ \ptr ->+            mapM_ (\ (i,v) -> pokeElemOff ptr (index b i) v) ivs+        return fp+++listArray             :: (Ix a,Storable b) => (a,a) -> [b] -> UArray a b+listArray b vs        =  array b (zipWith (\ a b -> (a,b)) (range b) vs)++(!)                   :: (Ix a,Storable b) => UArray a b -> a -> b+(!) (MkArray s e arr) i = case (index (s,e) i) of i' -> unsafePerformIO (withForeignPtr arr (\ptr -> peekElemOff ptr i'))++bounds                :: (Ix a) => UArray a b -> (a,a)+bounds (MkArray s e _)  =  (s,e)++indices               :: (Ix a) => UArray a b -> [a]+indices               =  range . bounds++elems                 :: (Ix a,Storable b) => UArray a b -> [b]+elems a               =  [a!i | i <- indices a]++assocs                :: (Ix a,Storable b) => UArray a b -> [(a,b)]+assocs a              =  [(i, a!i) | i <- indices a]++(//)                  :: (Ix a,Storable b) => UArray a b -> [(a,b)] -> UArray a b+a // []               = a+a // new_ivs          = array (bounds a) (old_ivs ++ new_ivs)+                      where+                  	old_ivs = [(i,a!i) | i <- indices a,+                                             i `notElem` new_is]+                  	new_is  = [i | (i,_) <- new_ivs]++accum                 :: (Ix a,Storable b ) => (b -> c -> b) -> UArray a b -> [(a,c)] -> UArray a b+accum f               =  foldl (\a (i,v) -> a // [(i,f (a!i) v)])++accumArray            :: (Ix a,Storable b ) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> UArray a b+accumArray f z b      =  accum f (array b [(i,z) | i <- range b])++ixmap                 :: (Ix a, Ix b,Storable c) => (a,a) -> (a -> b) -> UArray b c -> UArray a c+ixmap b f a           = array b [(i, a ! f i) | i <- range b]++--instance  (Ix a)          => Functor (UArray a) where+--    fmap fn a = array (bounds a) [ (a,fn b) | (a,b) <- assocs a ]++instance  (Ix a, Eq b, Storable b)  => Eq (UArray a b)  where+    a == a' =  assocs a == assocs a'++instance  (Ix a, Ord b, Storable b) => Ord (UArray a b)  where+    a <= a' =  assocs a <= assocs a'++instance  (Ix a, Show a, Show b, Storable b) => Show (UArray a b)  where+    showsPrec p a = showParen (p > arrPrec) (+                    showString "array " .+                    showsPrec (arrPrec+1) (bounds a) . showChar ' ' .+                    showsPrec (arrPrec+1) (assocs a)                  )+instance  (Ix a, Read a, Read b, Storable b) => Read (UArray a b)  where+    readsPrec p = readParen (p > arrPrec)+           (\r -> [ (array b as, u)+                  | ("array",s) <- lex r,+                    (b,t)       <- readsPrec (arrPrec+1) s,+                    (as,u)      <- readsPrec (arrPrec+1) t ])++-- Precedence of the 'array' function is that of application itself+arrPrec :: Int+arrPrec = 10+
+ lib/base/src/Data/Bits.hs view
@@ -0,0 +1,142 @@+{-# OPTIONS_LHC -N #-}+module Data.Bits where+++import Lhc.Num+import Lhc.Order+import Lhc.Int+++infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`+infixl 7 .&.+infixl 6 `xor`+infixl 5 .|.+++{-|+The 'Bits' class defines bitwise operations over integral types.++* Bits are numbered from 0 with bit 0 being the least+  significant bit.+-}+class Num a => Bits a where+    -- | Bitwise \"and\"+    (.&.) :: a -> a -> a++    -- | Bitwise \"or\"+    (.|.) :: a -> a -> a++    -- | Bitwise \"xor\"+    xor :: a -> a -> a++    {-| Reverse all the bits in the argument -}+    complement        :: a -> a++    {-| Shift the argument left by the specified number of bits.+	Right shifts (signed) are specified by giving a negative value.++	An instance can define either this unified 'shift' or 'shiftL' and+	'shiftR', depending on which is more convenient for the type in+	question. -}+    shift             :: a -> Int -> a++    x `shift`   i | i<0  = x `shiftR` (-i)+                  | i==0 = x+                  | i>0  = x `shiftL` i++    {-| Rotate the argument left by the specified number of bits.+	Right rotates are specified by giving a negative value.++        For unbounded types like 'Integer', 'rotate' is equivalent to 'shift'.++	An instance can define either this unified 'rotate' or 'rotateL' and+	'rotateR', depending on which is more convenient for the type in+	question. -}+    rotate            :: a -> Int -> a++    x `rotate`  i | i<0  = x `rotateR` (-i)+                  | i==0 = x+                  | i>0  = x `rotateL` i++    {-+    -- Rotation can be implemented in terms of two shifts, but care is+    -- needed for negative values.  This suggested implementation assumes+    -- 2's-complement arithmetic.  It is commented out because it would+    -- require an extra context (Ord a) on the signature of 'rotate'.+    x `rotate`  i | i<0 && isSigned x && x<0+                         = let left = i+bitSize x in+                           ((x `shift` i) .&. complement ((-1) `shift` left))+                           .|. (x `shift` left)+                  | i<0  = (x `shift` i) .|. (x `shift` (i+bitSize x))+                  | i==0 = x+                  | i>0  = (x `shift` i) .|. (x `shift` (i-bitSize x))+    -}++    -- | @bit i@ is a value with the @i@th bit set+    bit               :: Int -> a++    -- | @x \`setBit\` i@ is the same as @x .|. bit i@+    setBit            :: a -> Int -> a++    -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@+    clearBit          :: a -> Int -> a++    -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@+    complementBit     :: a -> Int -> a++    -- | Return 'True' if the @n@th bit of the argument is 1+    testBit           :: a -> Int -> Bool++    {-| Return the number of bits in the type of the argument.  The actual+	value of the argument is ignored.  The function 'bitSize' is+	undefined for types that do not have a fixed bitsize, like 'Integer'.+	-}+    bitSize           :: a -> Int++    {-| Return 'True' if the argument is a signed type.  The actual+        value of the argument is ignored -}+    isSigned          :: a -> Bool++    bit i               = 1 `shiftL` i+    x `setBit` i        = x .|. bit i+    x `clearBit` i      = x .&. complement (bit i)+    x `complementBit` i = x `xor` bit i+    x `testBit` i       = (x .&. bit i) /= 0++    {-| Shift the argument left by the specified number of bits+	(which must be non-negative).++	An instance can define either this and 'shiftR' or the unified+	'shift', depending on which is more convenient for the type in+	question. -}+    shiftL            :: a -> Int -> a+    x `shiftL`  i = x `shift`  i++    {-| Shift the argument right (signed) by the specified number of bits+	(which must be non-negative).++	An instance can define either this and 'shiftL' or the unified+	'shift', depending on which is more convenient for the type in+	question. -}+    shiftR            :: a -> Int -> a+    x `shiftR`  i = x `shift`  (-i)++    {-| Rotate the argument left by the specified number of bits+	(which must be non-negative).++	An instance can define either this and 'rotateR' or the unified+	'rotate', depending on which is more convenient for the type in+	question. -}+    rotateL           :: a -> Int -> a+    x `rotateL` i = x `rotate` i++    {-| Rotate the argument right by the specified number of bits+	(which must be non-negative).++	An instance can define either this and 'rotateL' or the unified+	'rotate', depending on which is more convenient for the type in+	question. -}+    rotateR           :: a -> Int -> a+    x `rotateR` i = x `rotate` (-i)++
+ lib/base/src/Data/Char.hs view
@@ -0,0 +1,85 @@+module Data.Char (+    isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,+    isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,+    digitToInt, intToDigit,+    toUpper, toLower,+    ord, chr,+    readLitChar, showLitChar, lexLitChar,+    module Prelude.CType,++        -- ...and what the Prelude exports+    Char, String+    ) where++--import Array         -- Used for character name table.+import Numeric (readDec, readOct, lexDigits, readHex)+import Prelude.Text+import Lhc.Basics+import Data.Word(Word())+import Prelude.CType++++++-- Text functions+readLitChar          :: ReadS Char+readLitChar ('\\':s) =  readEsc s+readLitChar (c:s)    =  [(c,s)]++readEsc          :: ReadS Char+readEsc ('a':s)  = [('\a',s)]+readEsc ('b':s)  = [('\b',s)]+readEsc ('f':s)  = [('\f',s)]+readEsc ('n':s)  = [('\n',s)]+readEsc ('r':s)  = [('\r',s)]+readEsc ('t':s)  = [('\t',s)]+readEsc ('v':s)  = [('\v',s)]+readEsc ('\\':s) = [('\\',s)]+readEsc ('"':s)  = [('"',s)]+readEsc ('\'':s) = [('\'',s)]+readEsc ('^':(c:s)) | c >= '@' && c <= '_'+                 = [(chr (ord c - ord '@'), s)]+readEsc s@(d:_) | isDigit d+                 = [(chr n, t) | (n,t) <- readDec s]+readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]+readEsc ('x':s)  = [(chr n, t) | (n,t) <- readHex s]+readEsc s@(c:_) | isUpper c+                 = let table = ('\DEL', "DEL") : zip ['\NUL' .. ] asciiTab+                   in case [(c,s') | (c, mne) <- table,+                                     ([],s') <- [match mne s]]+                      of (pr:_) -> [pr]+                         []     -> []+readEsc _        = []++match                         :: (Eq a) => [a] -> [a] -> ([a],[a])+match (x:xs) (y:ys) | x == y  =  match xs ys+match xs     ys               =  (xs,ys)++showLitChar               :: Char -> ShowS+showLitChar c | c > '\DEL' =  showChar '\\' .+                              protectEsc isDigit (shows (ord c))+showLitChar '\DEL'         =  showString "\\DEL"+showLitChar '\\'           =  showString "\\\\"+showLitChar c | c >= ' '   =  showChar c+showLitChar '\a'           =  showString "\\a"+showLitChar '\b'           =  showString "\\b"+showLitChar '\f'           =  showString "\\f"+showLitChar '\n'           =  showString "\\n"+showLitChar '\r'           =  showString "\\r"+showLitChar '\t'           =  showString "\\t"+showLitChar '\v'           =  showString "\\v"+showLitChar '\SO'          =  protectEsc (== 'H') (showString "\\SO")+showLitChar c              =  showString ('\\' : (asciiTab!!ord c))++protectEsc p f             = f . cont+                             where cont s@(c:_) | p c = "\\&" ++ s+                                   cont s             = s++asciiTab :: [String]+asciiTab = --listArray ('\NUL', ' ')+           ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",+            "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",+            "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",+            "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",+            "SP"]
+ lib/base/src/Data/Complex.hs view
@@ -0,0 +1,104 @@+module Data.Complex(+    Complex((:+)),+    realPart,+    imagPart,+    conjugate,+    mkPolar,+    cis,+    polar,+    magnitude,+    phase+    )  where++infix  6  :+++-- the standard says this should have a RealFloat constraint, but that is silly.+data  Complex a = !a :+ !a  deriving (Eq,Read,Show)+++realPart, imagPart :: (RealFloat a) => Complex a -> a+realPart (x:+y)  =  x+imagPart (x:+y)  =  y++conjugate  :: (RealFloat a) => Complex a -> Complex a+conjugate (x:+y) =  x :+ (-y)++mkPolar  :: (RealFloat a) => a -> a -> Complex a+mkPolar r theta  =  r * cos theta :+ r * sin theta++cis  :: (RealFloat a) => a -> Complex a+cis theta  =  cos theta :+ sin theta++polar  :: (RealFloat a) => Complex a -> (a,a)+polar z  =  (magnitude z, phase z)++magnitude :: (RealFloat a) => Complex a -> a+magnitude (x:+y) =  scaleFloat k+     (sqrt ((scaleFloat mk x)^(2::Int) + (scaleFloat mk y)^(2::Int)))+    where k  = max (exponent x) (exponent y)+          mk = - k++phase :: (RealFloat a) => Complex a -> a+phase (0 :+ 0) = 0+phase (x :+ y) = atan2 y x+++instance  (RealFloat a) => Num (Complex a)  where+    (x:+y) + (x':+y') =  (x+x') :+ (y+y')+    (x:+y) - (x':+y') =  (x-x') :+ (y-y')+    (x:+y) * (x':+y') =  (x*x'-y*y') :+ (x*y'+y*x')+    negate (x:+y) =  negate x :+ negate y+    abs z =  magnitude z :+ 0+    signum (0 :+ 0) =  0+    signum z@(x:+y) =  x/r :+ y/r  where r = magnitude z+    fromInteger n =  fromInteger n :+ 0+    fromInt n =  fromInt n :+ 0++instance  (RealFloat a) => Fractional (Complex a)  where+    (x:+y) / (x':+y') =  (x*x''+y*y'') / d :+ (y*x''-x*y'') / d+       where x'' = scaleFloat k x'+             y'' = scaleFloat k y'+             k   = - max (exponent x') (exponent y')+             d   = x'*x'' + y'*y''+    fromRational a =  fromRational a :+ 0+    fromDouble a = fromDouble a :+ 0++instance  (RealFloat a) => Floating (Complex a) where+    pi             =  pi :+ 0+    exp (x:+y)     =  expx * cos y :+ expx * sin y+                      where expx = exp x+    log z          =  log (magnitude z) :+ phase z++    sqrt (0 :+ 0)  =  0+    sqrt z@(x:+y)  =  u :+ (if y < 0 then -v else v)+                      where (u,v) = if x < 0 then (v',u') else (u',v')+                            v'    = abs y / (u'*2)+                            u'    = sqrt ((magnitude z + abs x) / 2)++    sin (x:+y)     =  sin x * cosh y :+ cos x * sinh y+    cos (x:+y)     =  cos x * cosh y :+ (- sin x * sinh y)+    tan (x:+y)     =  (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))+                      where sinx  = sin x+                            cosx  = cos x+                            sinhy = sinh y+                            coshy = cosh y++    sinh (x:+y)    =  cos y * sinh x :+ sin  y * cosh x+    cosh (x:+y)    =  cos y * cosh x :+ sin y * sinh x+    tanh (x:+y)    =  (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)+                      where siny  = sin y+                            cosy  = cos y+                            sinhx = sinh x+                            coshx = cosh x++    asin z@(x:+y)  =  y':+(-x')+                      where  (x':+y') = log (((-y):+x) + sqrt (1 - z*z))+    acos z@(x:+y)  =  y'':+(-x'')+                      where (x'':+y'') = log (z + ((-y'):+x'))+                            (x':+y')   = sqrt (1 - z*z)+    atan z@(x:+y)  =  y':+(-x')+                      where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))++    asinh z        =  log (z + sqrt (1+z*z))+    acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))+    atanh z        =  log ((1+z) / sqrt (1-z*z))
+ lib/base/src/Data/Dynamic.hs view
@@ -0,0 +1,66 @@+{-# OPTIONS_LHC -fffi #-}+module Data.Dynamic(Dynamic,toDyn,fromDyn,fromDynamic,dynApply,dynApp) where+++import Data.Typeable++data Obj++data Dynamic = Dynamic TypeRep Obj++instance Show Dynamic where+    showsPrec _ x s = "<Dynamic>" ++ s++-- | Converts an arbitrary value into an object of type 'Dynamic'.+--+-- The type of the object must be an instance of 'Typeable', which+-- ensures that only monomorphically-typed objects may be converted to+-- 'Dynamic'.  To convert a polymorphic object into 'Dynamic', give it+-- a monomorphic type signature.  For example:+--+-- >    toDyn (id :: Int -> Int)+--+toDyn :: Typeable a => a -> Dynamic+toDyn v = Dynamic (typeOf v) (unsafeCoerce v)++-- | Converts a 'Dynamic' object back into an ordinary Haskell value of+-- the correct type.  See also 'fromDynamic'.+fromDyn :: Typeable a+ 	=> Dynamic 	-- ^ the dynamically-typed object+	-> a		-- ^ a default value+	-> a		-- ^ returns: the value of the first argument, if+			-- it has the correct type, otherwise the value of+			-- the second argument.+fromDyn (Dynamic t v) def+  | typeOf def == t = unsafeCoerce v+  | otherwise       = def++-- | Converts a 'Dynamic' object back into an ordinary Haskell value of+-- the correct type.  See also 'fromDyn'.+fromDynamic+	:: Typeable a+	=> Dynamic	-- ^ the dynamically-typed object+	-> Maybe a	-- ^ returns: @'Just' a@, if the dynamically-typed+			-- object has the correct type (and @a@ is its value),+			-- or 'Nothing' otherwise.+fromDynamic (Dynamic t v) =+  case unsafeCoerce v of+    r | t == typeOf r -> Just r+      | otherwise     -> Nothing++-- (f::(a->b)) `dynApply` (x::a) = (f a)::b+dynApply :: Dynamic -> Dynamic -> Maybe Dynamic+dynApply (Dynamic t1 f) (Dynamic t2 x) =+  case funResultTy t1 t2 of+    Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x))+    Nothing -> Nothing++dynApp :: Dynamic -> Dynamic -> Dynamic+dynApp f x = case dynApply f x of+             Just r -> r+             Nothing -> error ("Type error in dynamic application.\n" +++                               "Can't apply function " ++ show f +++                               " to argument " ++ show x)+++foreign import primitive "unsafeCoerce" unsafeCoerce :: a -> b
+ lib/base/src/Data/IORef.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_LHC -N -funboxed-tuples -fffi #-}+module Data.IORef(+    IORef(),	      -- abstract, instance of: Eq+    newIORef,	      -- :: a -> IO (IORef a)+    readIORef,	      -- :: IORef a -> IO a+    writeIORef,	      -- :: IORef a -> a -> IO ()+    modifyIORef,      -- :: IORef a -> (a -> a) -> IO ()+    atomicModifyIORef,-- :: IORef a -> (a -> (a,b)) -> IO b+    ) where++import Lhc.Basics+import Lhc.Order+import Lhc.IO+import Lhc.Int++data IORef a = IORef (Ref__ a)+data Ref__ a :: #+++foreign import primitive newRef__   :: a -> UIO (Ref__ a)+foreign import primitive readRef__  :: Ref__ a -> UIO a+foreign import primitive writeRef__ :: Ref__ a -> a -> UIO_++-- {-# NOINLINE newIORef #-}+newIORef :: a -> IO (IORef a)+newIORef v = IO $ \w -> case newRef__ v w of (# w', r #) -> (# w', IORef r #)+++-- {-# NOINLINE readIORef #-}+readIORef :: IORef a -> IO a+readIORef (IORef r) = IO $ \w -> readRef__ r w++-- {-# NOINLINE writeIORef #-}+writeIORef :: IORef a -> a -> IO ()+writeIORef (IORef r) v = IO $ \w -> case writeRef__ r v w of w' -> (# w', () #)++--foreign import primitive eqRef__ :: Ref__ a -> Ref__ a -> Bool++--instance Eq (IORef a) where+--    (IORef x) == (IORef y) = eqRef__ x y+++--{-# NOINLINE modifyIORef #-}+modifyIORef :: IORef a -> (a -> a) -> IO ()+modifyIORef (IORef ref) f = IO $ \w -> case readRef__ ref w of+    (# w', a #) -> case writeRef__ ref (f a) w' of+        w'' -> (# w'', () #)++--{-# NOINLINE atomicModifyIORef #-}+atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b+atomicModifyIORef (IORef r) f = IO $ \w -> case readRef__ r w of+    (# w', a #) -> case f a of+        (a',b) -> case writeRef__ r a' w' of+            w'' -> (# w'', b #)+{-+--newIORef v = IO $ \_ world -> case newRef__ v world of+--    (world',r) -> JustIO world' r+--readIORef r = IO $ \_ world -> case readRef__ r world of+--    (world',v) -> JustIO world' v+--writeIORef r v = IO $ \_ world -> case writeRef__ r v world of+--    world' -> JustIO world' ()+{-# NOINLINE newIORef #-}+newIORef :: a -> IO (IORef a)+newIORef v = do+    v' <- strictReturn v+    return (IORef v')++{-# NOINLINE readIORef #-}+readIORef :: IORef a -> IO a+readIORef r = do+    --v <- strictReturn r+    case r of+        IORef r -> strictReturn r+-}++--foreign import primitive newRef__ :: forall s . a -> s -> (s,Ref s a)+--foreign import primitive readRef__ :: forall s . Ref s a -> s -> (s,a)
+ lib/base/src/Data/Int.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_LHC -N #-}+module Data.Int(Int,Int8,Int16,Int32,Int64,IntMax,IntPtr) where++import Lhc.Prim(Int())++data Int8+data Int16+data Int32+data Int64+data IntMax+data IntPtr
+ lib/base/src/Data/Ix.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS_LHC -N #-}+module Data.Ix ( Ix(range, index, inRange, rangeSize) ) where++import Lhc.Int+import Lhc.Enum+import Lhc.Order+import Lhc.Basics+import Lhc.Num+import Lhc.IO++class  Ord a => Ix a  where+    range     :: (a,a) -> [a]+    index     :: (a,a) -> a -> Int+    inRange   :: (a,a) -> a -> Bool+    rangeSize :: (a,a) -> Int++    rangeSize b@(l,h) = case range b of+        [] -> zero+        _  -> index b h `plus` one+	-- NB: replacing "null (range b)" by  "not (l <= h)"+	-- fails if the bounds are tuples.  For example,+	-- 	(1,2) <= (2,1)+	-- but the range is nevertheless empty+	--	range ((1,2),(2,1)) = []++instance  Ix Char  where+    range (m,n)		= [m..n]+    index b@(c,c') ci+        | inRange b ci  =  fromEnum ci `minus` fromEnum c+        | otherwise     =  error "Ix.index: Index out of range."+    inRange (c,c') i    =  c <= i && i <= c'++instance  Ix Int  where+    range (m,n)		= [m..n]+    index b@(m,n) i+        | inRange b i   =  i `minus` m+        | otherwise     =  error "Ix.index: Index out of range."+    inRange (m,n) i     =  m <= i && i <= n++instance  (Ix a, Ix b)  => Ix (a,b) where+        range   ((l,l'),(u,u')) = [(i,i') | i <- range (l,u), i' <- range (l',u')]+        index   ((l,l'),(u,u')) (i,i') =  index (l,u) i * rangeSize (l',u') + index (l',u') i'+        inRange ((l,l'),(u,u')) (i,i') = inRange (l,u) i && inRange (l',u') i'++--instance  Ix Integer  where+--    range (m,n)		= [m..n]+--    index b@(m,n) i+--        | inRange b i   =  fromInteger (i - m)+--        | otherwise     =  error "Ix.index: Index out of range."+--    inRange (m,n) i     =  m <= i && i <= n++instance  Ix Bool  where+    range (m,n)		= [m..n]+    index b@(c,c') ci+        | inRange b ci  =  fromEnum ci `minus` fromEnum c+        | otherwise     =  error "Ix.index: 'Bool' Index out of range."+    inRange (c,c') i    =  c <= i && i <= c'++instance  Ix Ordering  where+    range (m,n)		= [m..n]+    index b@(c,c') ci+        | inRange b ci  =  fromEnum ci `minus` fromEnum c+        | otherwise     =  error "Ix.index: 'Ordering' Index out of range."+    inRange (c,c') i    =  c <= i && i <= c'++-- instance (Ix a,Ix b) => Ix (a, b) -- as derived, for all tuples+-- instance Ix Bool                  -- as derived+-- instance Ix Ordering              -- as derived+-- instance Ix ()                    -- as derived
+ lib/base/src/Data/List.hs view
@@ -0,0 +1,336 @@++module Data.List (+    elemIndex, elemIndices,+    find, findIndex, findIndices,+    nub, nubBy, delete, deleteBy, (\\), deleteFirstsBy,+    union, unionBy, intersect, intersectBy,+    intersperse, transpose, partition, group, groupBy,+    inits, tails, isPrefixOf, isSuffixOf,+    mapAccumL, mapAccumR,+    sort, sortBy, insert, insertBy, maximumBy, minimumBy,+    genericLength, genericTake, genericDrop,+    genericSplitAt, genericIndex, genericReplicate,+    zip4, zip5, zip6, zip7,+    zipWith4, zipWith5, zipWith6, zipWith7,+    unzip4, unzip5, unzip6, unzip7, unfoldr,++    foldl', foldl1',++    -- ...and what the Prelude exports+    -- []((:), []), -- This is built-in syntax+    map, (++), concat, filter,+    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, concatMap,+    zip, zip3, zipWith, zipWith3, unzip, unzip3+    ) where+++infix 5 \\++elemIndex               :: Eq a => a -> [a] -> Maybe Int+elemIndex x             =  findIndex (x ==)++elemIndices             :: Eq a => a -> [a] -> [Int]+elemIndices x           =  findIndices (x ==)++find    :: (a -> Bool) -> [a] -> Maybe a+find p xs =  case  filter p xs of+    (x:_) -> Just x+    [] -> Nothing++findIndex               :: (a -> Bool) -> [a] -> Maybe Int+findIndex p  xs           = case findIndices p xs of+    (x:_) -> Just x+    [] -> Nothing++findIndices             :: (a -> Bool) -> [a] -> [Int]+findIndices p xs        =  [ i | (x,i) <- zip xs [0..], p x ]++nub                     :: Eq a => [a] -> [a]+nub l                   = nub' l [] where+    nub' [] _           = []+    nub' (x:xs) ls+        | x `elem` ls   = nub' xs ls+        | otherwise     = x : nub' xs (x:ls)++--nub                     =  nubBy (==)++nubBy                   :: (a -> a -> Bool) -> [a] -> [a]+nubBy eq l              = nubBy' l []+  where+    nubBy' [] _         = []+    nubBy' (y:ys) xs+       | elem_by eq y xs = nubBy' ys xs+       | otherwise       = y : nubBy' ys (y:xs)+    elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool+    elem_by _  _ []             =  False+    elem_by eq y (x:xs) =  x `eq` y || elem_by eq y xs++--nubBy eq []             =  []+--nubBy eq (x:xs)         =  x : nubBy eq (filter (\y -> not (eq x y)) xs)++delete                  :: Eq a => a -> [a] -> [a]+delete                  =  deleteBy (==)++deleteBy                :: (a -> a -> Bool) -> a -> [a] -> [a]+deleteBy eq x []        = []+deleteBy eq x (y:ys)    = if x `eq` y then ys else y : deleteBy eq x ys++(\\)                    :: Eq a => [a] -> [a] -> [a]+(\\)                    =  foldl (flip delete)++deleteFirstsBy          :: (a -> a -> Bool) -> [a] -> [a] -> [a]+deleteFirstsBy eq       =  foldl (flip (deleteBy eq))++union                   :: Eq a => [a] -> [a] -> [a]+union                   =  unionBy (==)++unionBy                 :: (a -> a -> Bool) -> [a] -> [a] -> [a]+unionBy eq xs ys        =  xs ++ deleteFirstsBy eq (nubBy eq ys) xs++intersect               :: Eq a => [a] -> [a] -> [a]+intersect               =  intersectBy (==)++intersectBy             :: (a -> a -> Bool) -> [a] -> [a] -> [a]+intersectBy eq xs ys    =  [x | x <- xs, any (eq x) ys]++intersperse             :: a -> [a] -> [a]+intersperse sep []      =  []+intersperse sep [x]     =  [x]+intersperse sep (x:xs)  =  x : sep : intersperse sep xs++-- transpose is lazy in both rows and columns,+--       and works for non-rectangular 'matrices'+-- For example, transpose [[1,2],[3,4,5],[]]  =  [[1,3],[2,4],[5]]+-- Note that [h | (h:t) <- xss] is not the same as (map head xss)+--      because the former discards empty sublists inside xss+transpose                :: [[a]] -> [[a]]+transpose []             = []+transpose ([]     : xss) = transpose xss+transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) :+                           transpose (xs : [t | (h:t) <- xss])++partition               :: (a -> Bool) -> [a] -> ([a],[a])+partition p xs          =  (filter p xs, filter (not . p) xs)++-- group splits its list argument into a list of lists of equal, adjacent+-- elements.  e.g.,+-- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"]+group                   :: Eq a => [a] -> [[a]]+group                   =  groupBy (==)++groupBy                 :: (a -> a -> Bool) -> [a] -> [[a]]+groupBy eq []           =  []+groupBy eq (x:xs)       =  (x:ys) : groupBy eq zs+                           where (ys,zs) = span (eq x) xs++-- inits xs returns the list of initial segments of xs, shortest first.+-- e.g., inits "abc" == ["","a","ab","abc"]+inits                   :: [a] -> [[a]]+inits []                =  [[]]+inits (x:xs)            =  [[]] ++ map (x:) (inits xs)++-- tails xs returns the list of all final segments of xs, longest first.+-- e.g., tails "abc" == ["abc", "bc", "c",""]+tails                   :: [a] -> [[a]]+tails []                =  [[]]+tails xxs@(_:xs)        =  xxs : tails xs++isPrefixOf               :: Eq a => [a] -> [a] -> Bool+isPrefixOf []     _      =  True+isPrefixOf _      []     =  False+isPrefixOf (x:xs) (y:ys) =  x == y && isPrefixOf xs ys++isSuffixOf              :: Eq a => [a] -> [a] -> Bool+isSuffixOf x y          =  reverse x `isPrefixOf` reverse y++mapAccumL               :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])+mapAccumL f s []        =  (s, [])+mapAccumL f s (x:xs)    =  (s'',y:ys)+                           where (s', y ) = f s x+                                 (s'',ys) = mapAccumL f s' xs++mapAccumR               :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])+mapAccumR f s []        =  (s, [])+mapAccumR f s (x:xs)    =  (s'', y:ys)+                           where (s'',y ) = f s' x+                                 (s', ys) = mapAccumR f s xs++unfoldr                 :: (b -> Maybe (a,b)) -> b -> [a]+unfoldr f b             = case f b of+                                Nothing    -> []+                                Just (a,b) -> a : unfoldr f b++sort                    :: (Ord a) => [a] -> [a]+sort                    =  sortBy compare++sortBy                  :: (a -> a -> Ordering) -> [a] -> [a]+sortBy cmp l = mergesort cmp l where+    mergesort :: (a -> a -> Ordering) -> [a] -> [a]+    mergesort cmp = mergesort' cmp . map wrap++    mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a]+    mergesort' cmp [] = []+    mergesort' cmp [xs] = xs+    mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss)++    merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]]+    merge_pairs cmp [] = []+    merge_pairs cmp [xs] = [xs]+    merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss++    merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+    merge cmp xs [] = xs+    merge cmp [] ys = ys+    merge cmp (x:xs) (y:ys)+     = case x `cmp` y of+            GT -> y : merge cmp (x:xs)   ys+            _  -> x : merge cmp    xs (y:ys)++    wrap :: a -> [a]+    wrap x = [x]++-- sortBy cmp              =  foldr (insertBy cmp) []++insert                  :: (Ord a) => a -> [a] -> [a]+insert                  = insertBy compare++insertBy                :: (a -> a -> Ordering) -> a -> [a] -> [a]+insertBy cmp x []       =  [x]+insertBy cmp x ys@(y:ys')+                        =  case cmp x y of+                                GT -> y : insertBy cmp x ys'+                                _  -> x : ys++maximumBy               :: (a -> a -> Ordering) -> [a] -> a+maximumBy cmp []        =  error "List.maximumBy: empty list"+maximumBy cmp xs        =  foldl1 max xs+                        where+                           max x y = case cmp x y of+                                        GT -> x+                                        _  -> y++minimumBy               :: (a -> a -> Ordering) -> [a] -> a+minimumBy cmp []        =  error "List.minimumBy: empty list"+minimumBy cmp xs        =  foldl1 min xs+                        where+                           min x y = case cmp x y of+                                        GT -> y+                                        _  -> x++genericLength           :: (Integral a) => [b] -> a+genericLength []        =  0+genericLength (x:xs)    =  1 + genericLength xs++genericTake             :: (Integral a) => a -> [b] -> [b]+genericTake _ []        =  []+genericTake 0 _         =  []+genericTake n (x:xs)+   | n > 0              =  x : genericTake (n-1) xs+   | otherwise          =  error "List.genericTake: negative argument"++genericDrop             :: (Integral a) => a -> [b] -> [b]+genericDrop 0 xs        =  xs+genericDrop _ []        =  []+genericDrop n (_:xs)+   | n > 0              =  genericDrop (n-1) xs+   | otherwise          =  error "List.genericDrop: negative argument"++genericSplitAt          :: (Integral a) => a -> [b] -> ([b],[b])+genericSplitAt 0 xs     =  ([],xs)+genericSplitAt _ []     =  ([],[])+genericSplitAt n (x:xs)+   | n > 0              =  (x:xs',xs'')+   | otherwise          =  error "List.genericSplitAt: negative argument"+       where (xs',xs'') =  genericSplitAt (n-1) xs++genericIndex            :: (Integral a) => [b] -> a -> b+genericIndex (x:_)  0   =  x+genericIndex (_:xs) n+        | n > 0         =  genericIndex xs (n-1)+        | otherwise     =  error "List.genericIndex: negative argument"+genericIndex _ _        =  error "List.genericIndex: index too large"++genericReplicate        :: (Integral a) => a -> b -> [b]+genericReplicate n x    =  genericTake n (repeat x)++zip4                    :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]+zip4                    =  zipWith4 (,,,)++zip5                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]+zip5                    =  zipWith5 (,,,,)++zip6                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->+                              [(a,b,c,d,e,f)]+zip6                    =  zipWith6 (,,,,,)++zip7                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->+                              [g] -> [(a,b,c,d,e,f,g)]+zip7                    =  zipWith7 (,,,,,,)++zipWith4                :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]+zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)+                        =  z a b c d : zipWith4 z as bs cs ds+zipWith4 _ _ _ _ _      =  []++zipWith5                :: (a->b->c->d->e->f) ->+                           [a]->[b]->[c]->[d]->[e]->[f]+zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)+                        =  z a b c d e : zipWith5 z as bs cs ds es+zipWith5 _ _ _ _ _ _    =  []++zipWith6                :: (a->b->c->d->e->f->g) ->+                           [a]->[b]->[c]->[d]->[e]->[f]->[g]+zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)+                        =  z a b c d e f : zipWith6 z as bs cs ds es fs+zipWith6 _ _ _ _ _ _ _  =  []++zipWith7                :: (a->b->c->d->e->f->g->h) ->+                           [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]+zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)+                   =  z a b c d e f g : zipWith7 z as bs cs ds es fs gs+zipWith7 _ _ _ _ _ _ _ _ = []++unzip4                  :: [(a,b,c,d)] -> ([a],[b],[c],[d])+unzip4                  =  foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->+                                        (a:as,b:bs,c:cs,d:ds))+                                 ([],[],[],[])++unzip5                  :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])+unzip5                  =  foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->+                                        (a:as,b:bs,c:cs,d:ds,e:es))+                                 ([],[],[],[],[])++unzip6                  :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])+unzip6                  =  foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->+                                        (a:as,b:bs,c:cs,d:ds,e:es,f:fs))+                                 ([],[],[],[],[],[])++unzip7          :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])+unzip7          =  foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->+                                (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))+                         ([],[],[],[],[],[],[])++{-# RULES "sort/sort"  forall  xs . sort (sort xs) = sort xs #-}+{-# RULES "nub/nub"  forall  xs . nub (nub xs) = nub xs #-}+++-- | A strict version of 'foldl'.+foldl'           :: (a -> b -> a) -> a -> [b] -> a+foldl' f z xs = lgo z xs where+    lgo z []     = z+    lgo z (x:xs) = let z' = f z x in z' `seq` lgo z' xs+++-- | A strict version of 'foldl1'+foldl1'                  :: (a -> a -> a) -> [a] -> a+foldl1' f (x:xs)         =  foldl' f x xs+foldl1' _ []             =  error "foldl1': empty list"+++
+ lib/base/src/Data/Maybe.hs view
@@ -0,0 +1,44 @@+{-# OPTIONS_LHC -N #-}+module Data.Maybe(+    isJust, isNothing,+    fromJust, fromMaybe, listToMaybe, maybeToList,+    catMaybes, mapMaybe,++    -- ...and what the Prelude exports+    Maybe(Nothing, Just),+    maybe+  ) where++import Lhc.Maybe+import Lhc.Order+import Lhc.Basics+import Lhc.IO++isJust                 :: Maybe a -> Bool+isJust (Just a)        =  True+isJust Nothing         =  False++isNothing        :: Maybe a -> Bool+isNothing        =  not . isJust++fromJust               :: Maybe a -> a+fromJust (Just a)      =  a+fromJust Nothing       =  error "Maybe.fromJust: Nothing"++fromMaybe              :: a -> Maybe a -> a+fromMaybe d Nothing    =  d+fromMaybe d (Just a)   =  a++maybeToList            :: Maybe a -> [a]+maybeToList Nothing    =  []+maybeToList (Just a)   =  [a]++listToMaybe            :: [a] -> Maybe a+listToMaybe []         =  Nothing+listToMaybe (a:_)      =  Just a++catMaybes              :: [Maybe a] -> [a]+catMaybes ms           =  [ m | Just m <- ms ]++mapMaybe               :: (a -> Maybe b) -> [a] -> [b]+mapMaybe f             =  catMaybes . map f
+ lib/base/src/Data/Monoid.hs view
@@ -0,0 +1,90 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Monoid+-- Copyright   :  (c) Andy Gill 2001,+-- 		  (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (requires extended type classes)+--+-- Declaration of the Monoid class, and instances for list and functions.+--+--	  Inspired by the paper+--	  /Functional Programming with Overloading and+--	      Higher-Order Polymorphism/,+--	    Mark P Jones (<http://www.cse.ogi.edu/~mpj/>)+--		  Advanced School of Functional Programming, 1995.+-----------------------------------------------------------------------------++module Data.Monoid (+ 	Monoid(..)+  ) where++import Prelude++-- ---------------------------------------------------------------------------+-- | The monoid class.+-- A minimal complete definition must supply 'mempty' and 'mappend',+-- and these should satisfy the monoid laws.++class Monoid a where+	mempty  :: a+	-- ^ Identity of 'mappend'+	mappend :: a -> a -> a+	-- ^ An associative operation+	mconcat :: [a] -> a++	-- ^ Fold a list using the monoid.+	-- For most types, the default definition for 'mconcat' will be+	-- used, but the function is included in the class definition so+	-- that an optimized version can be provided for specific types.++	mconcat = foldr mappend mempty++-- Monoid instances.++instance Monoid [a] where+	mempty  = []+	mappend = (++)++instance Monoid (a -> a) where+	mempty  = id+	mappend = (.)++instance Monoid () where+	-- Should it be strict?+	mempty        = ()+	_ `mappend` _ = ()+	mconcat _     = ()++instance (Monoid a, Monoid b) => Monoid (a,b) where+	mempty = (mempty, mempty)+	(a1,b1) `mappend` (a2,b2) =+		(a1 `mappend` a2, b1 `mappend` b2)++instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where+	mempty = (mempty, mempty, mempty)+	(a1,b1,c1) `mappend` (a2,b2,c2) =+		(a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2)++instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where+	mempty = (mempty, mempty, mempty, mempty)+	(a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) =+		(a1 `mappend` a2, b1 `mappend` b2,+		 c1 `mappend` c2, d1 `mappend` d2)++instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>+		Monoid (a,b,c,d,e) where+	mempty = (mempty, mempty, mempty, mempty, mempty)+	(a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) =+		(a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2,+		 d1 `mappend` d2, e1 `mappend` e2)++-- lexicographical ordering+instance Monoid Ordering where+	mempty         = EQ+	LT `mappend` _ = LT+	EQ `mappend` y = y+	GT `mappend` _ = GT
+ lib/base/src/Data/Ratio.hs view
@@ -0,0 +1,115 @@+-- Standard functions on rational numbers++module  Data.Ratio (+    Ratio, Rational, (%), numerator, denominator, approxRational ) where++import Prelude.Text+import Prelude.Float(doubleToRational)+import Lhc.Num+import Lhc.Float++infixl 7  %++ratPrec = 7 :: Int++++(%)                     :: (Integral a) => a -> a -> Ratio a+approxRational          :: (RealFrac a) => a -> a -> Rational++++x % y                   =  reduce (x * signum y) (abs y)+++++-- "reduce" is a subsidiary function used only in this module.+-- It normalises a ratio by dividing both numerator+-- and denominator by their greatest common divisor.+--+-- E.g., 12 `reduce` 8    ==  3 :%   2+--       12 `reduce` (-8) ==  3 :% (-2)++reduce _ 0              =  error "Ratio.% : zero denominator"+reduce x y              =  (x `quot` d) :% (y `quot` d)+                           where d = gcd x y++instance  (Integral a)  => Eq (Ratio a)  where+    (x:%y) == (x':%y')  =  x == x' && y == y'++instance  (Integral a)  => Ord (Ratio a)  where+    (x:%y) <= (x':%y')  =  x * y' <= x' * y+    (x:%y) <  (x':%y')  =  x * y' <  x' * y++--negateRatio (x:%y)       =  (-x) :% y+--(x:%y) `plusRatio` (x':%y')   =  reduce ((x*y') + (x'*y)) (y*y')+--absRatio (x:%y)          =  abs x :% y++instance  (Integral a)  => Num (Ratio a)  where+    --(+) = plusRatio+    (x:%y) + (x':%y')   =  reduce (x*y' + x'*y) (y*y')+    (x:%y) * (x':%y')   =  reduce (x * x') (y * y')+    --negate x {-(x:%y)-}   =  negateRatio x -- (-x) :% y+    negate (x:%y)       =  (-x) :% y+    --abs (x:%y)        =  abs x :% y+    abs (x:%y)          =  abs x :% y+    signum (x:%y)       =  signum x :% 1+    fromInteger x       =  fromInteger x :% 1+    fromInt     x       =  fromInt x :% 1++instance  (Integral a)  => Real (Ratio a)  where+    toRational (x:%y)   =  toInteger x :% toInteger y++    toDouble  x         = rationalToDouble (toRational x)++instance  (Integral a)  => Fractional (Ratio a)  where+    (x:%y) / (x':%y')   =  (x*y') % (y*x')+    recip (x:%y)        =  y % x+    fromRational (x:%y) =  fromInteger x :% fromInteger y+    fromDouble   x      = fromRational (doubleToRational x)++instance  (Integral a)  => RealFrac (Ratio a)  where+    properFraction (x:%y) = (fromIntegral q, r:%y)+                            where (q,r) = quotRem x y++{-+instance  (Integral a)  => Enum (Ratio a)  where+    succ x           =  x+1+    pred x           =  x-1+    toEnum           =  fromIntegral+    fromEnum         =  fromInteger . truncate	-- May overflow+--    enumFrom         =  numericEnumFrom		-- These numericEnumXXX functions+--    enumFromThen     =  numericEnumFromThen	-- are as defined in Prelude.hs+--    enumFromTo       =  numericEnumFromTo	-- but not exported from it!+--    enumFromThenTo   =  numericEnumFromThenTo+-}++instance  (Read a, Integral a)  => Read (Ratio a)  where+    readsPrec p  =  readParen (p > ratPrec)+                              (\r -> [(reduce (x * signum y) (abs y),u) | (x,s)   <- readsPrec (ratPrec+1) r,+                                                ("%",t) <- lex s,+                                                (y,u)   <- readsPrec (ratPrec+1) t ])++instance  (Integral a)  => Show (Ratio a)  where+    showsPrec p (x:%y)  =  showParen (p > ratPrec)+                               (showsPrec (ratPrec+1) x .+			        showString " % " .+				showsPrec (ratPrec+1) y)++approxRational x eps    =  simplest (x-eps) (x+eps)+        where simplest x y | y < x      =  simplest y x+                           | x == y     =  xr+                           | x > 0      =  simplest' n d n' d'+                           | y < 0      =  - simplest' (-n') d' (-n) d+                           | otherwise  =  0 :% 1+                                        where xr@(n:%d) = toRational x+                                              (n':%d')  = toRational y++              simplest' n d n' d'       -- assumes 0 < n%d < n'%d'+                        | r == 0     =  q :% 1+                        | q /= q'    =  (q+1) :% 1+                        | otherwise  =  (q*n''+d'') :% n''+                                     where (q,r)      =  quotRem n d+                                           (q',r')    =  quotRem n' d'+                                           (n'':%d'') =  simplest' d' r' d r
+ lib/base/src/Data/Typeable.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS_LHC -fffi #-}+module Data.Typeable(TypeRep,typeOf) where+++data TypeRep++instance Eq TypeRep where+    (==) = primTypeRepEq++foreign import primitive typeOf :: a -> TypeRep+foreign import primitive typeOf1 :: t a -> TypeRep+foreign import primitive typeOf2 :: t a b -> TypeRep+foreign import primitive typeOf3 :: t a b c -> TypeRep+foreign import primitive typeOf4 :: t a b c d -> TypeRep+foreign import primitive typeOf5 :: t a b c d e -> TypeRep+foreign import primitive typeOf6 :: t a b c d e f -> TypeRep+foreign import primitive typeOf7 :: t a b c d e f g -> TypeRep+foreign import primitive typeRepEq :: TypeRep -> TypeRep -> Bool+++-------------------------------------------------------------+--+--		Type-safe cast+--+-------------------------------------------------------------++-- | The type-safe cast operation+cast ::  a -> Maybe b+cast x = r+       where+	 r = if typeOf x == typeOf (fromJust r)+               then Just $ unsafeCoerce x+	       else Nothing++-- | A flexible variation parameterised in a type constructor+gcast :: c a -> Maybe (c b)+gcast x = r+ where+  r = if typeOf (getArg x) == typeOf (getArg (fromJust r))+        then Just $ unsafeCoerce x+        else Nothing+  getArg :: c x -> x+  getArg = undefined++-- | Cast for * -> *+gcast1 ::  c (t a) -> Maybe (c (t' a))+gcast1 x = r+ where+  r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r))+       then Just $ unsafeCoerce x+       else Nothing+  getArg :: c x -> x+  getArg = undefined++-- | Cast for * -> * -> *+gcast2 ::  c (t a b) -> Maybe (c (t' a b))+gcast2 x = r+ where+  r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r))+       then Just $ unsafeCoerce x+       else Nothing+  getArg :: c x -> x+  getArg = undefined
+ lib/base/src/Data/Unicode.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS_LHC -fffi #-}+module Data.Unicode(+    CType(),+    ctype,+    isCType,+    t_alnum,+    t_alpha,+    t_blank,+    t_cntrl,+    t_digit,+    t_graph,+    t_lower,+    t_print,+    t_punct,+    t_space,+    t_upper,+    t_xdigit,+    t_none+    )where++import Foreign.C.String+import Foreign.C.Types+import System.IO.Unsafe++newtype CType = CType CInt++-- | Get a ctype other than one of the defaults.++ctype :: String -> IO CType+ctype s = withCString s c_wctype++isCType :: Char -> CType -> Bool+isCType ch ct = unsafePerformIO (c_iswctype ch ct) /= 0+++t_alnum, t_alpha, t_blank, t_cntrl,+ t_digit, t_graph, t_lower, t_print,+ t_punct, t_space, t_upper, t_xdigit, t_none :: CType++t_alnum = unsafePerformIO (ctype "alnum")+t_alpha = unsafePerformIO (ctype "alpha")+t_blank = unsafePerformIO (ctype "blank")+t_cntrl = unsafePerformIO (ctype "cntrl")+t_digit = unsafePerformIO (ctype "digit")+t_graph = unsafePerformIO (ctype "graph")+t_lower = unsafePerformIO (ctype "lower")+t_print = unsafePerformIO (ctype "print")+t_punct = unsafePerformIO (ctype "punct")+t_space = unsafePerformIO (ctype "space")+t_upper = unsafePerformIO (ctype "upper")+t_xdigit = unsafePerformIO (ctype "xdigit")+t_none = CType 0++{-# NOINLINE+ t_alnum, t_alpha, t_blank, t_cntrl,+ t_digit, t_graph, t_lower, t_print,+ t_punct, t_space, t_upper, t_xdigit+ #-}+++foreign import ccall "wctype.h iswctype" c_iswctype :: Char -> CType -> IO Int+foreign import ccall "wctype.h wctype" c_wctype :: CString -> IO CType+
+ lib/base/src/Data/Word.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS -N #-}+module Data.Word(Word,Word8,Word16,Word32,Word64,WordMax,WordPtr) where++++data Word+data Word8+data Word16+data Word32+data Word64+data WordMax+data WordPtr
+ lib/base/src/Foreign.hs view
@@ -0,0 +1,41 @@+{-# OPTIONS_LHC -N #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A collection of data types, classes, and functions for interfacing+-- with another programming language.+--+-----------------------------------------------------------------------------++module Foreign+        ( module Data.Bits+        , module Data.Int+        , module Data.Word+	, module Foreign.Ptr+        , module Foreign.ForeignPtr+        , module Foreign.StablePtr+        , module Foreign.Storable+        , module Foreign.Marshal++        -- | For compatibility with the FFI addendum only.  The recommended+        -- place to get this from is "System.IO.Unsafe".+        , unsafePerformIO+        ) where++import Data.Bits+import Data.Int+import Data.Word+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.StablePtr+import Foreign.Storable+import Foreign.Marshal++import System.IO.Unsafe (unsafePerformIO)
+ lib/base/src/Foreign/C.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.C+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Bundles the C specific FFI library functionality+--+-----------------------------------------------------------------------------++module Foreign.C+        ( module Foreign.C.Types+        , module Foreign.C.String+        , module Foreign.C.Error+        ) where++import Foreign.C.Types+import Foreign.C.String+import Foreign.C.Error
+ lib/base/src/Foreign/C/Error.hs view
@@ -0,0 +1,539 @@+{-# OPTIONS_LHC -fffi #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.C.Error+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- C-specific Marshalling support: Handling of C \"errno\" error codes.+--+-----------------------------------------------------------------------------++++module Foreign.C.Error (++  -- * Haskell representations of @errno@ values++  Errno(..),		-- instance: Eq++  -- ** Common @errno@ symbols+  -- | Different operating systems and\/or C libraries often support+  -- different values of @errno@.  This module defines the common values,+  -- but due to the open definition of 'Errno' users may add definitions+  -- which are not predefined.+  eOK,{- e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,+  eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED,+  eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT,+  eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ,+  eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK,+  eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH,+  eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK,+  eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS,+  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO,+  eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL,+  ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE,+  eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN,+  eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT,+  eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV, -}++  -- ** 'Errno' functions+                        -- :: Errno+  isValidErrno,		-- :: Errno -> Bool++  -- access to the current thread's "errno" value+  --+  getErrno,             -- :: IO Errno+  resetErrno,           -- :: IO ()++  -- conversion of an "errno" value into IO error+  --+  errnoToIOError,       -- :: String       -- location+                        -- -> Errno        -- errno+                        -- -> Maybe Handle -- handle+                        -- -> Maybe String -- filename+                        -- -> IOError++  -- throw current "errno" value+  --+  throwErrno,           -- ::                String               -> IO a++  -- ** Guards for IO operations that may fail++  throwErrnoIf,         -- :: (a -> Bool) -> String -> IO a       -> IO a+  throwErrnoIf_,        -- :: (a -> Bool) -> String -> IO a       -> IO ()+  throwErrnoIfRetry,    -- :: (a -> Bool) -> String -> IO a       -> IO a+  throwErrnoIfRetry_,   -- :: (a -> Bool) -> String -> IO a       -> IO ()+  throwErrnoIfMinus1,   -- :: Num a+			-- =>                String -> IO a       -> IO a+  throwErrnoIfMinus1_,  -- :: Num a+			-- =>                String -> IO a       -> IO ()+  throwErrnoIfMinus1Retry,+			-- :: Num a+			-- =>                String -> IO a       -> IO a+  throwErrnoIfMinus1Retry_,+			-- :: Num a+			-- =>                String -> IO a       -> IO ()+  throwErrnoIfNull,	-- ::                String -> IO (Ptr a) -> IO (Ptr a)+  throwErrnoIfNullRetry,-- ::                String -> IO (Ptr a) -> IO (Ptr a)++  throwErrnoIfRetryMayBlock,+  throwErrnoIfRetryMayBlock_,+  throwErrnoIfMinus1RetryMayBlock,+  throwErrnoIfMinus1RetryMayBlock_,+  throwErrnoIfNullRetryMayBlock+) where+++import Foreign.Storable+import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String++import System.IO.Unsafe		( unsafePerformIO )++++-- "errno" type+-- ------------++-- | Haskell representation for @errno@ values.+-- The implementation is deliberately exposed, to allow users to add+-- their own definitions of 'Errno' values.++newtype Errno = Errno CInt++instance Eq Errno where+  errno1@(Errno no1) == errno2@(Errno no2)+    | isValidErrno errno1 && isValidErrno errno2 = no1 == no2+    | otherwise					 = False++-- common "errno" symbols+--+{-+eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,+  eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED,+  eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT,+  eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ,+  eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK,+  eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH,+  eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK,+  eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS,+  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO,+  eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL,+  ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE,+  eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN,+  eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT,+  eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV		       :: Errno+-- -}+-- the cCONST_XXX identifiers are cpp symbols whose value is computed by+-- configure+--+eOK             = Errno 0+{-+#ifdef __NHC__+#include "Errno.hs"+#else+e2BIG           = Errno (CONST_E2BIG)+eACCES		= Errno (CONST_EACCES)+eADDRINUSE	= Errno (CONST_EADDRINUSE)+eADDRNOTAVAIL	= Errno (CONST_EADDRNOTAVAIL)+eADV		= Errno (CONST_EADV)+eAFNOSUPPORT	= Errno (CONST_EAFNOSUPPORT)+eAGAIN		= Errno (CONST_EAGAIN)+eALREADY	= Errno (CONST_EALREADY)+eBADF		= Errno (CONST_EBADF)+eBADMSG		= Errno (CONST_EBADMSG)+eBADRPC		= Errno (CONST_EBADRPC)+eBUSY		= Errno (CONST_EBUSY)+eCHILD		= Errno (CONST_ECHILD)+eCOMM		= Errno (CONST_ECOMM)+eCONNABORTED	= Errno (CONST_ECONNABORTED)+eCONNREFUSED	= Errno (CONST_ECONNREFUSED)+eCONNRESET	= Errno (CONST_ECONNRESET)+eDEADLK		= Errno (CONST_EDEADLK)+eDESTADDRREQ	= Errno (CONST_EDESTADDRREQ)+eDIRTY		= Errno (CONST_EDIRTY)+eDOM		= Errno (CONST_EDOM)+eDQUOT		= Errno (CONST_EDQUOT)+eEXIST		= Errno (CONST_EEXIST)+eFAULT		= Errno (CONST_EFAULT)+eFBIG		= Errno (CONST_EFBIG)+eFTYPE		= Errno (CONST_EFTYPE)+eHOSTDOWN	= Errno (CONST_EHOSTDOWN)+eHOSTUNREACH	= Errno (CONST_EHOSTUNREACH)+eIDRM		= Errno (CONST_EIDRM)+eILSEQ		= Errno (CONST_EILSEQ)+eINPROGRESS	= Errno (CONST_EINPROGRESS)+eINTR		= Errno (CONST_EINTR)+eINVAL		= Errno (CONST_EINVAL)+eIO		= Errno (CONST_EIO)+eISCONN		= Errno (CONST_EISCONN)+eISDIR		= Errno (CONST_EISDIR)+eLOOP		= Errno (CONST_ELOOP)+eMFILE		= Errno (CONST_EMFILE)+eMLINK		= Errno (CONST_EMLINK)+eMSGSIZE	= Errno (CONST_EMSGSIZE)+eMULTIHOP	= Errno (CONST_EMULTIHOP)+eNAMETOOLONG	= Errno (CONST_ENAMETOOLONG)+eNETDOWN	= Errno (CONST_ENETDOWN)+eNETRESET	= Errno (CONST_ENETRESET)+eNETUNREACH	= Errno (CONST_ENETUNREACH)+eNFILE		= Errno (CONST_ENFILE)+eNOBUFS		= Errno (CONST_ENOBUFS)+eNODATA		= Errno (CONST_ENODATA)+eNODEV		= Errno (CONST_ENODEV)+eNOENT		= Errno (CONST_ENOENT)+eNOEXEC		= Errno (CONST_ENOEXEC)+eNOLCK		= Errno (CONST_ENOLCK)+eNOLINK		= Errno (CONST_ENOLINK)+eNOMEM		= Errno (CONST_ENOMEM)+eNOMSG		= Errno (CONST_ENOMSG)+eNONET		= Errno (CONST_ENONET)+eNOPROTOOPT	= Errno (CONST_ENOPROTOOPT)+eNOSPC		= Errno (CONST_ENOSPC)+eNOSR		= Errno (CONST_ENOSR)+eNOSTR		= Errno (CONST_ENOSTR)+eNOSYS		= Errno (CONST_ENOSYS)+eNOTBLK		= Errno (CONST_ENOTBLK)+eNOTCONN	= Errno (CONST_ENOTCONN)+eNOTDIR		= Errno (CONST_ENOTDIR)+eNOTEMPTY	= Errno (CONST_ENOTEMPTY)+eNOTSOCK	= Errno (CONST_ENOTSOCK)+eNOTTY		= Errno (CONST_ENOTTY)+eNXIO		= Errno (CONST_ENXIO)+eOPNOTSUPP	= Errno (CONST_EOPNOTSUPP)+ePERM		= Errno (CONST_EPERM)+ePFNOSUPPORT	= Errno (CONST_EPFNOSUPPORT)+ePIPE		= Errno (CONST_EPIPE)+ePROCLIM	= Errno (CONST_EPROCLIM)+ePROCUNAVAIL	= Errno (CONST_EPROCUNAVAIL)+ePROGMISMATCH	= Errno (CONST_EPROGMISMATCH)+ePROGUNAVAIL	= Errno (CONST_EPROGUNAVAIL)+ePROTO		= Errno (CONST_EPROTO)+ePROTONOSUPPORT = Errno (CONST_EPROTONOSUPPORT)+ePROTOTYPE	= Errno (CONST_EPROTOTYPE)+eRANGE		= Errno (CONST_ERANGE)+eREMCHG		= Errno (CONST_EREMCHG)+eREMOTE		= Errno (CONST_EREMOTE)+eROFS		= Errno (CONST_EROFS)+eRPCMISMATCH	= Errno (CONST_ERPCMISMATCH)+eRREMOTE	= Errno (CONST_ERREMOTE)+eSHUTDOWN	= Errno (CONST_ESHUTDOWN)+eSOCKTNOSUPPORT = Errno (CONST_ESOCKTNOSUPPORT)+eSPIPE		= Errno (CONST_ESPIPE)+eSRCH		= Errno (CONST_ESRCH)+eSRMNT		= Errno (CONST_ESRMNT)+eSTALE		= Errno (CONST_ESTALE)+eTIME		= Errno (CONST_ETIME)+eTIMEDOUT	= Errno (CONST_ETIMEDOUT)+eTOOMANYREFS	= Errno (CONST_ETOOMANYREFS)+eTXTBSY		= Errno (CONST_ETXTBSY)+eUSERS		= Errno (CONST_EUSERS)+eWOULDBLOCK	= Errno (CONST_EWOULDBLOCK)+eXDEV		= Errno (CONST_EXDEV)+#endif+-}+-- | Yield 'True' if the given 'Errno' value is valid on the system.+-- This implies that the 'Eq' instance of 'Errno' is also system dependent+-- as it is only defined for valid values of 'Errno'.+--+isValidErrno               :: Errno -> Bool+--+-- the configure script sets all invalid "errno"s to -1+--+isValidErrno (Errno errno)  = errno /= -1+++-- access to the current thread's "errno" value+-- --------------------------------------------++-- | Get the current value of @errno@ in the current thread.+--+getErrno :: IO Errno++-- We must call a C function to get the value of errno in general.  On+-- threaded systems, errno is hidden behind a C macro so that each OS+-- thread gets its own copy.+getErrno = do e <- peek _errno; return (Errno e)+foreign import ccall "errno.h &errno" _errno :: Ptr CInt++-- | Reset the current thread\'s @errno@ value to 'eOK'.+--+resetErrno :: IO ()++-- Again, setting errno has to be done via a C function.+resetErrno = poke _errno 0++-- throw current "errno" value+-- ---------------------------++-- | Throw an 'IOError' corresponding to the current value of 'getErrno'.+--+throwErrno     :: String	-- ^ textual description of the error location+	       -> IO a+throwErrno loc  =+  do+    errno <- getErrno+    ioError (errnoToIOError loc errno Nothing Nothing)+++-- guards for IO operations that may fail+-- --------------------------------------++-- | Throw an 'IOError' corresponding to the current value of 'getErrno'+-- if the result value of the 'IO' action meets the given predicate.+--+throwErrnoIf    :: (a -> Bool)	-- ^ predicate to apply to the result value+				-- of the 'IO' operation+		-> String	-- ^ textual description of the location+		-> IO a		-- ^ the 'IO' operation to be executed+		-> IO a+throwErrnoIf pred loc f  =+  do+    res <- f+    if pred res then throwErrno loc else return res++-- | as 'throwErrnoIf', but discards the result of the 'IO' action after+-- error handling.+--+throwErrnoIf_   :: (a -> Bool) -> String -> IO a -> IO ()+throwErrnoIf_ pred loc f  = throwErrnoIf pred loc f >> return ()++-- | as 'throwErrnoIf', but retry the 'IO' action when it yields the+-- error code 'eINTR' - this amounts to the standard retry loop for+-- interrupted POSIX system calls.+--+throwErrnoIfRetry            :: (a -> Bool) -> String -> IO a -> IO a+throwErrnoIfRetry pred loc f  =+  do+    res <- f+    if pred res+      then do+	err <- getErrno+	if err == eINTR+	  then throwErrnoIfRetry pred loc f+	  else throwErrno loc+      else return res++-- | as 'throwErrnoIfRetry', but checks for operations that would block and+-- executes an alternative action before retrying in that case.+--+throwErrnoIfRetryMayBlock+		:: (a -> Bool)	-- ^ predicate to apply to the result value+				-- of the 'IO' operation+		-> String	-- ^ textual description of the location+		-> IO a		-- ^ the 'IO' operation to be executed+		-> IO b		-- ^ action to execute before retrying if+				-- an immediate retry would block+		-> IO a+throwErrnoIfRetryMayBlock pred loc f on_block  =+  do+    res <- f+    if pred res+      then do+	err <- getErrno+	if err == eINTR+	  then throwErrnoIfRetryMayBlock pred loc f on_block+          else if err == eWOULDBLOCK || err == eAGAIN+	         then do on_block; throwErrnoIfRetryMayBlock pred loc f on_block+                 else throwErrno loc+      else return res++-- | as 'throwErrnoIfRetry', but discards the result.+--+throwErrnoIfRetry_            :: (a -> Bool) -> String -> IO a -> IO ()+throwErrnoIfRetry_ pred loc f  = throwErrnoIfRetry pred loc f >> return ()++-- | as 'throwErrnoIfRetryMayBlock', but discards the result.+--+throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO ()+throwErrnoIfRetryMayBlock_ pred loc f on_block+  = throwErrnoIfRetryMayBlock pred loc f on_block >> return ()++-- | Throw an 'IOError' corresponding to the current value of 'getErrno'+-- if the 'IO' action returns a result of @-1@.+--+throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a+throwErrnoIfMinus1  = throwErrnoIf (== -1)++-- | as 'throwErrnoIfMinus1', but discards the result.+--+throwErrnoIfMinus1_ :: Num a => String -> IO a -> IO ()+throwErrnoIfMinus1_  = throwErrnoIf_ (== -1)++-- | Throw an 'IOError' corresponding to the current value of 'getErrno'+-- if the 'IO' action returns a result of @-1@, but retries in case of+-- an interrupted operation.+--+throwErrnoIfMinus1Retry :: Num a => String -> IO a -> IO a+throwErrnoIfMinus1Retry  = throwErrnoIfRetry (== -1)++-- | as 'throwErrnoIfMinus1', but discards the result.+--+throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO ()+throwErrnoIfMinus1Retry_  = throwErrnoIfRetry_ (== -1)++-- | as 'throwErrnoIfMinus1Retry', but checks for operations that would block.+--+throwErrnoIfMinus1RetryMayBlock :: Num a => String -> IO a -> IO b -> IO a+throwErrnoIfMinus1RetryMayBlock  = throwErrnoIfRetryMayBlock (== -1)++-- | as 'throwErrnoIfMinus1RetryMayBlock', but discards the result.+--+throwErrnoIfMinus1RetryMayBlock_ :: Num a => String -> IO a -> IO b -> IO ()+throwErrnoIfMinus1RetryMayBlock_  = throwErrnoIfRetryMayBlock_ (== -1)++-- | Throw an 'IOError' corresponding to the current value of 'getErrno'+-- if the 'IO' action returns 'nullPtr'.+--+throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a)+throwErrnoIfNull  = throwErrnoIf (== nullPtr)++-- | Throw an 'IOError' corresponding to the current value of 'getErrno'+-- if the 'IO' action returns 'nullPtr',+-- but retry in case of an interrupted operation.+--+throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a)+throwErrnoIfNullRetry  = throwErrnoIfRetry (== nullPtr)++-- | as 'throwErrnoIfNullRetry', but checks for operations that would block.+--+throwErrnoIfNullRetryMayBlock :: String -> IO (Ptr a) -> IO b -> IO (Ptr a)+throwErrnoIfNullRetryMayBlock  = throwErrnoIfRetryMayBlock (== nullPtr)++-- conversion of an "errno" value into IO error+-- --------------------------------------------++-- | Construct a Haskell 98 I\/O error based on the given 'Errno' value.+-- The optional information can be used to improve the accuracy of+-- error messages.+--+errnoToIOError	:: String	-- ^ the location where the error occurred+		-> Errno	-- ^ the error number+		-> Maybe a	-- ^ optional handle associated with the error+		-> Maybe String	-- ^ optional filename associated with the error+		-> IOError+errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do+    str <- strerror errno >>= peekCString++{-+#if __GLASGOW_HASKELL__+    return (IOError maybeHdl errType loc str maybeName)+    where+    errType+        | errno == eOK             = OtherError+        | errno == e2BIG           = ResourceExhausted+        | errno == eACCES          = PermissionDenied+        | errno == eADDRINUSE      = ResourceBusy+        | errno == eADDRNOTAVAIL   = UnsupportedOperation+        | errno == eADV            = OtherError+        | errno == eAFNOSUPPORT    = UnsupportedOperation+        | errno == eAGAIN          = ResourceExhausted+        | errno == eALREADY        = AlreadyExists+        | errno == eBADF           = OtherError+        | errno == eBADMSG         = InappropriateType+        | errno == eBADRPC         = OtherError+        | errno == eBUSY           = ResourceBusy+        | errno == eCHILD          = NoSuchThing+        | errno == eCOMM           = ResourceVanished+        | errno == eCONNABORTED    = OtherError+        | errno == eCONNREFUSED    = NoSuchThing+        | errno == eCONNRESET      = ResourceVanished+        | errno == eDEADLK         = ResourceBusy+        | errno == eDESTADDRREQ    = InvalidArgument+        | errno == eDIRTY          = UnsatisfiedConstraints+        | errno == eDOM            = InvalidArgument+        | errno == eDQUOT          = PermissionDenied+        | errno == eEXIST          = AlreadyExists+        | errno == eFAULT          = OtherError+        | errno == eFBIG           = PermissionDenied+        | errno == eFTYPE          = InappropriateType+        | errno == eHOSTDOWN       = NoSuchThing+        | errno == eHOSTUNREACH    = NoSuchThing+        | errno == eIDRM           = ResourceVanished+        | errno == eILSEQ          = InvalidArgument+        | errno == eINPROGRESS     = AlreadyExists+        | errno == eINTR           = Interrupted+        | errno == eINVAL          = InvalidArgument+        | errno == eIO             = HardwareFault+        | errno == eISCONN         = AlreadyExists+        | errno == eISDIR          = InappropriateType+        | errno == eLOOP           = InvalidArgument+        | errno == eMFILE          = ResourceExhausted+        | errno == eMLINK          = ResourceExhausted+        | errno == eMSGSIZE        = ResourceExhausted+        | errno == eMULTIHOP       = UnsupportedOperation+        | errno == eNAMETOOLONG    = InvalidArgument+        | errno == eNETDOWN        = ResourceVanished+        | errno == eNETRESET       = ResourceVanished+        | errno == eNETUNREACH     = NoSuchThing+        | errno == eNFILE          = ResourceExhausted+        | errno == eNOBUFS         = ResourceExhausted+        | errno == eNODATA         = NoSuchThing+        | errno == eNODEV          = UnsupportedOperation+        | errno == eNOENT          = NoSuchThing+        | errno == eNOEXEC         = InvalidArgument+        | errno == eNOLCK          = ResourceExhausted+        | errno == eNOLINK         = ResourceVanished+        | errno == eNOMEM          = ResourceExhausted+        | errno == eNOMSG          = NoSuchThing+        | errno == eNONET          = NoSuchThing+        | errno == eNOPROTOOPT     = UnsupportedOperation+        | errno == eNOSPC          = ResourceExhausted+        | errno == eNOSR           = ResourceExhausted+        | errno == eNOSTR          = InvalidArgument+        | errno == eNOSYS          = UnsupportedOperation+        | errno == eNOTBLK         = InvalidArgument+        | errno == eNOTCONN        = InvalidArgument+        | errno == eNOTDIR         = InappropriateType+        | errno == eNOTEMPTY       = UnsatisfiedConstraints+        | errno == eNOTSOCK        = InvalidArgument+        | errno == eNOTTY          = IllegalOperation+        | errno == eNXIO           = NoSuchThing+        | errno == eOPNOTSUPP      = UnsupportedOperation+        | errno == ePERM           = PermissionDenied+        | errno == ePFNOSUPPORT    = UnsupportedOperation+        | errno == ePIPE           = ResourceVanished+        | errno == ePROCLIM        = PermissionDenied+        | errno == ePROCUNAVAIL    = UnsupportedOperation+        | errno == ePROGMISMATCH   = ProtocolError+        | errno == ePROGUNAVAIL    = UnsupportedOperation+        | errno == ePROTO          = ProtocolError+        | errno == ePROTONOSUPPORT = ProtocolError+        | errno == ePROTOTYPE      = ProtocolError+        | errno == eRANGE          = UnsupportedOperation+        | errno == eREMCHG         = ResourceVanished+        | errno == eREMOTE         = IllegalOperation+        | errno == eROFS           = PermissionDenied+        | errno == eRPCMISMATCH    = ProtocolError+        | errno == eRREMOTE        = IllegalOperation+        | errno == eSHUTDOWN       = IllegalOperation+        | errno == eSOCKTNOSUPPORT = UnsupportedOperation+        | errno == eSPIPE          = UnsupportedOperation+        | errno == eSRCH           = NoSuchThing+        | errno == eSRMNT          = UnsatisfiedConstraints+        | errno == eSTALE          = ResourceVanished+        | errno == eTIME           = TimeExpired+        | errno == eTIMEDOUT       = TimeExpired+        | errno == eTOOMANYREFS    = ResourceExhausted+        | errno == eTXTBSY         = ResourceBusy+        | errno == eUSERS          = ResourceExhausted+        | errno == eWOULDBLOCK     = OtherError+        | errno == eXDEV           = UnsupportedOperation+        | otherwise                = OtherError+#else+#endif+-}+    return (userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName))+-- #endif++foreign import ccall  "string.h strerror" strerror :: Errno -> IO (Ptr CChar)+foreign import primitive "const.EINTR" eINTR :: Errno+foreign import primitive "const.EWOULDBLOCK" eWOULDBLOCK :: Errno+foreign import primitive "const.EAGAIN" eAGAIN :: Errno+
+ lib/base/src/Foreign/C/OldString.hs view
@@ -0,0 +1,36 @@+module Foreign.C.String where++import Char+import Foreign.C.Types+import Foreign.Marshal.Array+import Foreign.Ptr+import Data.Word++type CString = Ptr CChar+type CStringLen = (Ptr CChar, Int)++nUL :: CChar+nUL = 0++peekCString :: CString -> IO String+peekCString cp = do+    cs <- peekArray0 nUL cp+    return (cCharsToChars cs)++-- TODO UTF8+-- cast [CChar] to [Char]+--+cCharsToChars :: [CChar] -> [Char]+cCharsToChars xs  = map castCCharToChar xs++-- cast [Char] to [CChar]+--+charsToCChars :: [Char] -> [CChar]+charsToCChars xs  = map castCharToCChar xs++castCCharToChar :: CChar -> Char+castCCharToChar ch = chr (fromIntegral (fromIntegral ch :: Word8))++castCharToCChar :: Char -> CChar+castCharToCChar ch = fromIntegral (ord ch)+
+ lib/base/src/Foreign/C/String.hs view
@@ -0,0 +1,460 @@+{-# OPTIONS_LHC -N -fffi #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.C.String+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Utilities for primitive marshalling of C strings.+--+-- The marshalling converts each Haskell character, representing a Unicode+-- code point, to one or more bytes in a manner that, by default, is+-- determined by the current locale.  As a consequence, no guarantees+-- can be made about the relative length of a Haskell string and its+-- corresponding C string, and therefore all the marshalling routines+-- include memory allocation.  The translation between Unicode and the+-- encoding of the current locale may be lossy.+--+-----------------------------------------------------------------------------++module Foreign.C.String (   -- representation of strings in C++  -- * C strings++  CString,           -- = Ptr CChar+  CStringLen,        -- = (Ptr CChar, Int)++  -- ** Using a locale-dependent encoding++  -- | Currently these functions are identical to their @CAString@ counterparts;+  -- eventually they will use an encoding determined by the current locale.++  -- conversion of C strings into Haskell strings+  --+  peekCString,       -- :: CString    -> IO String+  peekCStringLen,    -- :: CStringLen -> IO String++  -- conversion of Haskell strings into C strings+  --+  newCString,        -- :: String -> IO CString+  newCStringLen,     -- :: String -> IO CStringLen++  -- conversion of Haskell strings into C strings using temporary storage+  --+  withCString,       -- :: String -> (CString    -> IO a) -> IO a+  withCStringLen,    -- :: String -> (CStringLen -> IO a) -> IO a++  charIsRepresentable, -- :: Char -> IO Bool++  -- ** Using 8-bit characters++  -- | These variants of the above functions are for use with C libraries+  -- that are ignorant of Unicode.  These functions should be used with+  -- care, as a loss of information can occur.++  castCharToCChar,   -- :: Char -> CChar+  castCCharToChar,   -- :: CChar -> Char++  peekCAString,      -- :: CString    -> IO String+  peekCAStringLen,   -- :: CStringLen -> IO String+  newCAString,       -- :: String -> IO CString+  newCAStringLen,    -- :: String -> IO CStringLen+  withCAString,      -- :: String -> (CString    -> IO a) -> IO a+  withCAStringLen,   -- :: String -> (CStringLen -> IO a) -> IO a++  -- * C wide strings++  -- | These variants of the above functions are for use with C libraries+  -- that encode Unicode using the C @wchar_t@ type in a system-dependent+  -- way.  The only encodings supported are+  --+  -- * UTF-32 (the C compiler defines @__STDC_ISO_10646__@), or+  --+  -- * UTF-16 (as used on Windows systems).++  CWString,          -- = Ptr CWchar+  CWStringLen,       -- = (Ptr CWchar, Int)++  peekCWString,      -- :: CWString    -> IO String+  peekCWStringLen,   -- :: CWStringLen -> IO String+  newCWString,       -- :: String -> IO CWString+  newCWStringLen,    -- :: String -> IO CWStringLen+  withCWString,      -- :: String -> (CWString    -> IO a) -> IO a+  withCWStringLen,   -- :: String -> (CWStringLen -> IO a) -> IO a++  ) where++import Lhc.Basics+import Lhc.Monad+import Lhc.Order+import Lhc.List+import Lhc.Num+import Foreign.Marshal.Array+import Foreign.C.Types+import Foreign.Ptr+import Foreign.Storable++import Data.Word+++-----------------------------------------------------------------------------+-- Strings++-- representation of strings in C+-- ------------------------------++-- | A C string is a reference to an array of C characters terminated by NUL.+type CString    = Ptr CChar++-- | A string with explicit length information in bytes instead of a+-- terminating NUL (allowing NUL characters in the middle of the string).+type CStringLen = (Ptr CChar, Int)++-- exported functions+-- ------------------+--+-- * the following routines apply the default conversion when converting the+--   C-land character encoding into the Haskell-land character encoding++-- | Marshal a NUL terminated C string into a Haskell string.+--+peekCString    :: CString -> IO String+peekCString = peekCAString++-- | Marshal a C string with explicit length into a Haskell string.+--+peekCStringLen           :: CStringLen -> IO String+peekCStringLen = peekCAStringLen++-- | Marshal a Haskell string into a NUL terminated C string.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * new storage is allocated for the C string and must be+--   explicitly freed using 'Foreign.Marshal.Alloc.free' or+--   'Foreign.Marshal.Alloc.finalizerFree'.+--+newCString :: String -> IO CString+newCString = newCAString++-- | Marshal a Haskell string into a C string (ie, character array) with+-- explicit length information.+--+-- * new storage is allocated for the C string and must be+--   explicitly freed using 'Foreign.Marshal.Alloc.free' or+--   'Foreign.Marshal.Alloc.finalizerFree'.+--+newCStringLen     :: String -> IO CStringLen+newCStringLen = newCAStringLen++-- | Marshal a Haskell string into a NUL terminated C string using temporary+-- storage.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * the memory is freed when the subcomputation terminates (either+--   normally or via an exception), so the pointer to the temporary+--   storage must /not/ be used after this.+--+withCString :: String -> (CString -> IO a) -> IO a+withCString = withCAString++-- | Marshal a Haskell string into a NUL terminated C string using temporary+-- storage.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * the memory is freed when the subcomputation terminates (either+--   normally or via an exception), so the pointer to the temporary+--   storage must /not/ be used after this.+--+withCStringLen         :: String -> (CStringLen -> IO a) -> IO a+withCStringLen = withCAStringLen++-- | Determines whether a character can be accurately encoded in a 'CString'.+-- Unrepresentable characters are converted to @\'?\'@.+--+-- Currently only Latin-1 characters are representable.+charIsRepresentable :: Char -> IO Bool+charIsRepresentable c = return (ord c < 256)++-- single byte characters+-- ----------------------+--+--   ** NOTE: These routines don't handle conversions! **++-- | Convert a C byte, representing a Latin-1 character, to the corresponding+-- Haskell character.+--castCCharToChar :: CChar -> Char+--castCCharToChar ch = chr (fromIntegral (fromIntegral ch :: Word8))++-- | Convert a Haskell character to a C character.+-- This function is only safe on the first 256 characters.+--castCharToCChar :: Char -> CChar+--castCharToCChar ch = fromIntegral (ord ch)++foreign import primitive "U2U" castCCharToChar :: CChar -> Char+foreign import primitive "U2U" castCharToCChar :: Char -> CChar++-- | Marshal a NUL terminated C string into a Haskell string.+--+peekCAString    :: CString -> IO String+--  #ifndef __GLASGOW_HASKELL__+--peekCAString cp  = do+--  cs <- peekArray0 nUL cp+--  return (cCharsToChars cs)+--  #else+peekCAString cp = do+  l <- lengthArray0 nUL cp+  if l <= 0 then return "" else loop "" (l-1) where+    loop s i = do+        xval <- peekElemOff cp i+	let val = castCCharToChar xval+	val `seq` if i <= 0 then return (val:s) else loop (val:s) (i-1)+--  #endif++-- | Marshal a C string with explicit length into a Haskell string.+--+peekCAStringLen           :: CStringLen -> IO String+--  #ifndef __GLASGOW_HASKELL__+-- peekCAStringLen (cp, len)  = do+--   cs <- peekArray len cp+--  return (cCharsToChars cs)+--  #else+peekCAStringLen (cp, len)+  | len <= 0  = return "" -- being (too?) nice.+  | otherwise = loop [] (len-1)+  where+    loop acc i = do+         xval <- peekElemOff cp i+	 let val = castCCharToChar xval+	   -- blow away the coercion ASAP.+	 if (val `seq` (i == 0))+	  then return (val:acc)+	  else loop (val:acc) (i-1)+--  #endif++-- | Marshal a Haskell string into a NUL terminated C string.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * new storage is allocated for the C string and must be+--   explicitly freed using 'Foreign.Marshal.Alloc.free' or+--   'Foreign.Marshal.Alloc.finalizerFree'.+--+newCAString :: String -> IO CString+--  #ifndef __GLASGOW_HASKELL__+-- newCAString  = newArray0 nUL . charsToCChars+--  #else+newCAString str = do+  ptr <- mallocArray0 (length str)+  let+	go [] n     = pokeElemOff ptr n nUL+    	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)+  go str 0+  return ptr+--  #endif++-- | Marshal a Haskell string into a C string (ie, character array) with+-- explicit length information.+--+-- * new storage is allocated for the C string and must be+--   explicitly freed using 'Foreign.Marshal.Alloc.free' or+--   'Foreign.Marshal.Alloc.finalizerFree'.+--+newCAStringLen     :: String -> IO CStringLen+--  #ifndef __GLASGOW_HASKELL__+-- newCAStringLen str  = do+--   a <- newArray (charsToCChars str)+--  return (pairLength str a)+--  #else+newCAStringLen str = do+  ptr <- mallocArray0 len+  let+	go [] n     = n `seq` return ()	-- make it strict in n+    	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)+  go str 0+  return (ptr, len) where+    len = length str+--  #endif++-- | Marshal a Haskell string into a NUL terminated C string using temporary+-- storage.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * the memory is freed when the subcomputation terminates (either+--   normally or via an exception), so the pointer to the temporary+--   storage must /not/ be used after this.+--+withCAString :: String -> (CString -> IO a) -> IO a+--  #ifndef __GLASGOW_HASKELL__+-- withCAString  = withArray0 nUL . charsToCChars+--  #else+withCAString str f =+  allocaArray0 (length str) $ \ptr ->+      let+	go [] n     = pokeElemOff ptr n nUL+    	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)+      in do+      go str 0+      f ptr+-- #endif++-- | Marshal a Haskell string into a NUL terminated C string using temporary+-- storage.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * the memory is freed when the subcomputation terminates (either+--   normally or via an exception), so the pointer to the temporary+--   storage must /not/ be used after this.+--+-- withCAStringLen         :: String -> (CStringLen -> IO a) -> IO a+--  #ifndef __GLASGOW_HASKELL__+-- withCAStringLen str act  = withArray (charsToCChars str) $ act . pairLength str+--  #else+withCAStringLen str f =+  allocaArray len $ \ptr ->+      let+	go [] n     = n `seq` return ()	-- make it strict in n+    	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)+      in do+      go str 0+      f (ptr,len)+  where+    len = length str+--  #endif++-- auxiliary definitions+-- ----------------------++-- C's end of string character+--+nUL :: CChar+nUL  = 0++-- pair a C string with the length of the given Haskell string+--+pairLength :: String -> a -> (a, Int)+pairLength  = flip (,) . length++--  #ifndef __GLASGOW_HASKELL__+-- cast [CChar] to [Char]+--+cCharsToChars :: [CChar] -> [Char]+cCharsToChars xs  = map castCCharToChar xs++-- cast [Char] to [CChar]+--+charsToCChars :: [Char] -> [CChar]+charsToCChars xs  = map castCharToCChar xs+--   #endif++-----------------------------------------------------------------------------+-- Wide strings++-- representation of wide strings in C+-- -----------------------------------++-- | A C wide string is a reference to an array of C wide characters+-- terminated by NUL.+type CWString    = Ptr CWchar++-- | A wide character string with explicit length information in bytes+-- instead of a terminating NUL (allowing NUL characters in the middle+-- of the string).+type CWStringLen = (Ptr CWchar, Int)++-- | Marshal a NUL terminated C wide string into a Haskell string.+--+peekCWString    :: CWString -> IO String+peekCWString cp  = do+  cs <- peekArray0 wNUL cp+  return (cWcharsToChars cs)++-- | Marshal a C wide string with explicit length into a Haskell string.+--+peekCWStringLen           :: CWStringLen -> IO String+peekCWStringLen (cp, len)  = do+  cs <- peekArray len cp+  return (cWcharsToChars cs)++-- | Marshal a Haskell string into a NUL terminated C wide string.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * new storage is allocated for the C wide string and must+--   be explicitly freed using 'Foreign.Marshal.Alloc.free' or+--   'Foreign.Marshal.Alloc.finalizerFree'.+--+newCWString :: String -> IO CWString+newCWString  = newArray0 wNUL . charsToCWchars++-- | Marshal a Haskell string into a C wide string (ie, wide character array)+-- with explicit length information.+--+-- * new storage is allocated for the C wide string and must+--   be explicitly freed using 'Foreign.Marshal.Alloc.free' or+--   'Foreign.Marshal.Alloc.finalizerFree'.+--+newCWStringLen     :: String -> IO CWStringLen+newCWStringLen str  = do+  a <- newArray (charsToCWchars str)+  return (pairLength str a)++-- | Marshal a Haskell string into a NUL terminated C wide string using+-- temporary storage.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * the memory is freed when the subcomputation terminates (either+--   normally or via an exception), so the pointer to the temporary+--   storage must /not/ be used after this.+--+withCWString :: String -> (CWString -> IO a) -> IO a+withCWString  = withArray0 wNUL . charsToCWchars++-- | Marshal a Haskell string into a NUL terminated C wide string using+-- temporary storage.+--+-- * the Haskell string may /not/ contain any NUL characters+--+-- * the memory is freed when the subcomputation terminates (either+--   normally or via an exception), so the pointer to the temporary+--   storage must /not/ be used after this.+--+withCWStringLen         :: String -> (CWStringLen -> IO a) -> IO a+withCWStringLen str act  = withArray (charsToCWchars str) $ act . pairLength str++-- auxiliary definitions+-- ----------------------++wNUL :: CWchar+wNUL = 0++cWcharsToChars :: [CWchar] -> [Char]+charsToCWchars :: [Char] -> [CWchar]+++cWcharsToChars xs  = map castCWcharToChar xs+charsToCWchars xs  = map castCharToCWchar xs++-- These conversions only make sense if __STDC_ISO_10646__ is defined+-- (meaning that wchar_t is ISO 10646, aka Unicode)++--castCWcharToChar :: CWchar -> Char+--castCWcharToChar ch = chr (fromIntegral ch )++--castCharToCWchar :: Char -> CWchar+--castCharToCWchar ch = fromIntegral (ord ch)++foreign import primitive "U2U" castCWcharToChar :: CWchar -> Char+foreign import primitive "U2U" castCharToCWchar :: Char -> CWchar+++
+ lib/base/src/Foreign/C/Types.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS --noprelude #-}+module Foreign.C.Types where++data CChar+data CSChar+data CUChar+data CShort+data CUShort+data CInt+data CUInt+data CLong+data CULong+data CPtrdiff+data CSize+data CWchar+data CSigAtomic+data CLLong+data CULLong+data CClock+data CTime+data CFloat+data CDouble+data CLDouble+data CFile+data CJmpBuf+data CFpos+data CWint
+ lib/base/src/Foreign/ForeignPtr.hs view
@@ -0,0 +1,55 @@+-- | Just a dummy skeleton, fixme.+module Foreign.ForeignPtr+    (ForeignPtr, newForeignPtr_, newForeignPtr,+     addForeignPtrFinalizer, mallocForeignPtr, mallocForeignPtrBytes,+     withForeignPtr, unsafeForeignPtrToPtr, touchForeignPtr, castForeignPtr+    ) where++import Control.Monad+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable++newtype ForeignPtr a = FP (Ptr a)+type FinalizerPtr  a = Ptr a++newForeignPtr_ :: Ptr a -> IO (ForeignPtr a)+newForeignPtr_ = return . FP++newForeignPtr :: FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)+newForeignPtr finalizer ptr = do+    fp <- newForeignPtr_ ptr+    addForeignPtrFinalizer finalizer fp+    return fp+++-- newForeignPtrEnv :: FinalizerEnvPtr env a -> Ptr env -> Ptr a -> IO (ForeignPtr a)+addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO ()+addForeignPtrFinalizer _ _ = return ()++-- addForeignPtrFinalizerEnv :: FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO ()++mallocForeignPtr :: Storable a => IO (ForeignPtr a)+mallocForeignPtr = liftM FP malloc++mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)+mallocForeignPtrBytes = liftM FP . mallocBytes++mallocForeignPtrArray  :: Storable a => Int -> IO (ForeignPtr a)+mallocForeignPtrArray = liftM FP . mallocArray++-- mallocForeignPtrArray0 :: Storable a => Int -> IO (ForeignPtr a)+-- mallocForeignPtrArray0 = liftM FP . mallocArray0++withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b+withForeignPtr (FP p) act = act p++unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a+unsafeForeignPtrToPtr (FP x) = x++touchForeignPtr :: ForeignPtr a -> IO ()+touchForeignPtr _ = return ()++castForeignPtr :: ForeignPtr a -> ForeignPtr b+castForeignPtr (FP x) = FP $ castPtr x
+ lib/base/src/Foreign/Marshal.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -fno-implicit-prelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.Marshal+-- Copyright   :  (c) The FFI task force 2003+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Marshalling support+--+-----------------------------------------------------------------------------++module Foreign.Marshal+        ( module Foreign.Marshal.Alloc+        , module Foreign.Marshal.Array+        , module Foreign.Marshal.Error+        , module Foreign.Marshal.Pool+        , module Foreign.Marshal.Utils+        ) where++import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Marshal.Error+import Foreign.Marshal.Pool+import Foreign.Marshal.Utils
+ lib/base/src/Foreign/Marshal/Alloc.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS_LHC -N -fffi #-}+module Foreign.Marshal.Alloc (+  -- * Memory allocation+  -- ** Local allocation+  alloca,       -- :: Storable a =>        (Ptr a -> IO b) -> IO b+  allocaBytes,  -- ::               Int -> (Ptr a -> IO b) -> IO b++  -- ** Dynamic allocation+  malloc,       -- :: Storable a =>        IO (Ptr a)+  mallocBytes,  -- ::               Int -> IO (Ptr a)++  realloc,      -- :: Storable b => Ptr a        -> IO (Ptr b)+  reallocBytes, -- ::		    Ptr a -> Int -> IO (Ptr a)++  free,         -- :: Ptr a -> IO ()+  finalizerFree -- :: FinalizerPtr a+) where++import Foreign.Ptr+import Foreign.Storable+import Prelude.IO+import Foreign.C.Types+import Foreign.Marshal.Utils+import Prelude.IOError+import Lhc.Prim+import Lhc.Basics+import Lhc.Monad+import Lhc.Order+import Lhc.IO+import Lhc.Int(unboxInt)+import Lhc.Addr+import Lhc.Num+import qualified Lhc.Options as JO++++-- TODO handle exceptions+allocaBytes' :: Int -> (Ptr a -> IO b) -> IO b+allocaBytes' b f = do+    p <- mallocBytes b+    r <- f p+    free p+    return r++allocaBytes :: Int -> (Ptr a -> IO b) -> IO b+allocaBytes num fn = etaIO $ case JO.target of+    JO.GhcHs -> case unboxInt num of n -> alloca__ n (\addr -> fn (boxAddr addr))+    _ -> allocaBytes' num fn++foreign import primitive alloca__ :: Int__ -> (Addr__ -> IO b) -> IO b+foreign import primitive "box" boxAddr :: Addr__ -> Ptr a++-- exported functions+-- ------------------++-- |Allocate a block of memory that is sufficient to hold values of type+-- @a@.  The size of the area allocated is determined by the 'sizeOf'+-- method from the instance of 'Storable' for the appropriate type.+--+-- The memory may be deallocated using 'free' or 'finalizerFree' when+-- no longer required.+--+malloc :: Storable a => IO (Ptr a)+malloc  = doMalloc undefined+doMalloc       :: Storable b => b -> IO (Ptr b)+doMalloc dummy  = mallocBytes (sizeOf dummy)+++-- |@'alloca' f@ executes the computation @f@, passing as argument+-- a pointer to a temporarily allocated block of memory sufficient to+-- hold values of type @a@.+--+-- The memory is freed when @f@ terminates (either normally or via an+-- exception), so the pointer passed to @f@ must /not/ be used after this.+--+alloca :: Storable a => (Ptr a -> IO b) -> IO b+alloca fn  = etaIO $ doAlloca undefined fn where+    doAlloca       :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b'+    doAlloca dummy fn = allocaBytes (sizeOf dummy) fn++failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)+failWhenNULL name f = do+   addr <- f+   if addr == nullPtr+      then ioError (userError (name++": out of memory"))+      else return addr++-- |Allocate a block of memory of the given number of bytes.+-- The block of memory is sufficiently aligned for any of the basic+-- foreign types that fits into a memory block of the allocated size.+--+-- The memory may be deallocated using 'free' or 'finalizerFree' when+-- no longer required.+--+mallocBytes      :: Int -> IO (Ptr a)+mallocBytes size  = failWhenNULL "malloc" (_malloc (fromIntegral size))+++-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'+-- to the size needed to store values of type @b@.  The returned pointer+-- may refer to an entirely different memory area, but will be suitably+-- aligned to hold values of type @b@.  The contents of the referenced+-- memory area will be the same as of the original pointer up to the+-- minimum of the original size and the size of values of type @b@.+--+-- If the argument to 'realloc' is 'nullPtr', 'realloc' behaves like+-- 'malloc'.+--+realloc :: Storable b => Ptr a -> IO (Ptr b)+realloc  = doRealloc undefined+doRealloc           :: Storable b' => b' -> Ptr a' -> IO (Ptr b')+doRealloc dummy ptr  = let+                         size = fromIntegral (sizeOf dummy)+                       in+                       failWhenNULL "realloc" (_realloc ptr size)++-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'+-- to the given size.  The returned pointer may refer to an entirely+-- different memory area, but will be sufficiently aligned for any of the+-- basic foreign types that fits into a memory block of the given size.+-- The contents of the referenced memory area will be the same as of+-- the original pointer up to the minimum of the original size and the+-- given size.+--+-- If the pointer argument to 'reallocBytes' is 'nullPtr', 'reallocBytes'+-- behaves like 'malloc'.  If the requested size is 0, 'reallocBytes'+-- behaves like 'free'.+--+reallocBytes          :: Ptr a -> Int -> IO (Ptr a)+reallocBytes ptr i | ptr `seq` i `seq` False = undefined+reallocBytes ptr 0     = do free ptr; return nullPtr+reallocBytes ptr size  =+  failWhenNULL "realloc" (_realloc ptr (fromIntegral size))++foreign import ccall "stdlib.h malloc" _malloc :: CSize -> IO (Ptr a)+foreign import ccall "stdlib.h free" free :: Ptr a -> IO ()+foreign import ccall "stdlib.h realloc" _realloc :: Ptr a -> CSize -> IO (Ptr b)
+ lib/base/src/Foreign/Marshal/Array.hs view
@@ -0,0 +1,256 @@+{-# OPTIONS_LHC -N  #-}+module Foreign.Marshal.Array (+  -- * Marshalling arrays++  -- ** Allocation+  --+  mallocArray,    -- :: Storable a => Int -> IO (Ptr a)+  mallocArray0,   -- :: Storable a => Int -> IO (Ptr a)++  allocaArray,    -- :: Storable a => Int -> (Ptr a -> IO b) -> IO b+  allocaArray0,   -- :: Storable a => Int -> (Ptr a -> IO b) -> IO b++  reallocArray,   -- :: Storable a => Ptr a -> Int -> IO (Ptr a)+  reallocArray0,  -- :: Storable a => Ptr a -> Int -> IO (Ptr a)++  -- ** Marshalling+  --+  peekArray,      -- :: Storable a =>         Int -> Ptr a -> IO [a]+  peekArray0,     -- :: (Storable a, Eq a) => a   -> Ptr a -> IO [a]++  pokeArray,      -- :: Storable a =>      Ptr a -> [a] -> IO ()+  pokeArray0,     -- :: Storable a => a -> Ptr a -> [a] -> IO ()++  -- ** Combined allocation and marshalling+  --+  newArray,       -- :: Storable a =>      [a] -> IO (Ptr a)+  newArray0,      -- :: Storable a => a -> [a] -> IO (Ptr a)++  withArray,      -- :: Storable a =>      [a] -> (Ptr a -> IO b) -> IO b+  withArray0,     -- :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b++  withArrayLen,   -- :: Storable a =>      [a] -> (Int -> Ptr a -> IO b) -> IO b+  withArrayLen0,  -- :: Storable a => a -> [a] -> (Int -> Ptr a -> IO b) -> IO b++  -- ** Copying++  -- | (argument order: destination, source)+  copyArray,      -- :: Storable a => Ptr a -> Ptr a -> Int -> IO ()+  moveArray,      -- :: Storable a => Ptr a -> Ptr a -> Int -> IO ()++  -- ** Finding the length+  --+  lengthArray0,   -- :: (Storable a, Eq a) => a -> Ptr a -> IO Int++  -- ** Indexing+  --+  advancePtr,     -- :: Storable a => Ptr a -> Int -> Ptr a+) where+++import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable+import Lhc.Basics+import Lhc.IO+import Lhc.List+import Lhc.Monad+import Lhc.Num+import Lhc.Order+import Prelude.IOError++-- allocation+-- ----------++-- |Allocate storage for the given number of elements of a storable type+-- (like 'Foreign.Marshal.Alloc.malloc', but for multiple elements).+--+mallocArray :: Storable a => Int -> IO (Ptr a)+mallocArray  = doMalloc undefined+doMalloc            :: Storable a' => a' -> Int -> IO (Ptr a')+doMalloc dummy size  = mallocBytes (size * sizeOf dummy)++-- |Like 'mallocArray', but add an extra position to hold a special+-- termination element.+--+mallocArray0      :: Storable a => Int -> IO (Ptr a)+mallocArray0 size  = mallocArray (size + 1)++-- |Temporarily allocate space for the given number of elements+-- (like 'Foreign.Marshal.Alloc.alloca', but for multiple elements).+--+allocaArray :: Storable a => Int -> (Ptr a -> IO b) -> IO b+allocaArray  size fn = etaIO $ doAlloca undefined fn where+    doAlloca            :: Storable a' => a' ->  (Ptr a' -> IO b') -> IO b'+    doAlloca dummy fn = allocaBytes (size * sizeOf dummy) fn++-- |Like 'allocaArray', but add an extra position to hold a special+-- termination element.+--+allocaArray0      :: Storable a => Int -> (Ptr a -> IO b) -> IO b+allocaArray0 size  = allocaArray (size + 1)++-- |Adjust the size of an array+--+reallocArray :: Storable a => Ptr a -> Int -> IO (Ptr a)+reallocArray  = doRealloc undefined+  where+    doRealloc                :: Storable a' => a' -> Ptr a' -> Int -> IO (Ptr a')+    doRealloc dummy ptr size  = reallocBytes ptr (size * sizeOf dummy)++-- |Adjust the size of an array including an extra position for the end marker.+--+reallocArray0          :: Storable a => Ptr a -> Int -> IO (Ptr a)+reallocArray0 ptr size  = reallocArray ptr (size + 1)+++-- |Convert an array of given length into a Haskell list.  This version+-- traverses the array backwards using an accumulating parameter,+-- which uses constant stack space.  The previous version using mapM+-- needed linear stack space.+--+peekArray          :: Storable a => Int -> Ptr a -> IO [a]+peekArray size ptr | ptr `seq` (size <= 0) = return []+                   | otherwise = f (size-1) []+  where+    f 0 acc = do e <- peekElemOff ptr 0; return (e:acc)+    f n acc = do e <- peekElemOff ptr n; f (n-1) (e:acc)++-- |Convert an array terminated by the given end marker into a Haskell list+--+peekArray0            :: (Storable a, Eq a) => a -> Ptr a -> IO [a]+peekArray0 marker ptr  = do+  size <- lengthArray0 marker ptr+  peekArray size ptr++-- finding the length+-- ------------------+++-- |Write the list elements consecutive into memory+--+--pokeArray :: Storable a => Ptr a -> [a] -> IO ()+--pokeArray ptr vals =  zipWithM_ (pokeElemOff ptr) [0..] vals where+--    zipWithM_         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()+--    zipWithM_ f xs ys =  sequence_ (zipWith f xs ys)++pokeArray :: Storable a => Ptr a -> [a] -> IO ()+pokeArray ptr vals = pokeArray' ptr vals >> return ()++pokeArray' :: Storable a => Ptr a -> [a] -> IO Int+pokeArray' ptr vals =  etaIO $ f 0 vals where+    f n [] | n `seq` True = return n+    f n (x:xs) = pokeElemOff ptr n x >> f (n + 1) xs+++-- |Write the list elements consecutive into memory and terminate them with the+-- given marker element+--+pokeArray0 :: Storable a => a -> Ptr a -> [a] -> IO ()+pokeArray0 marker ptr vals  = do+  lv <- pokeArray' ptr vals+  pokeElemOff ptr lv marker++-- combined allocation and marshalling+-- -----------------------------------++-- |Write a list of storable elements into a newly allocated, consecutive+-- sequence of storable values+-- (like 'Foreign.Marshal.Utils.new', but for multiple elements).+--+newArray      :: Storable a => [a] -> IO (Ptr a)+newArray vals  = do+  ptr <- mallocArray (length vals)+  pokeArray ptr vals+  return ptr++-- |Write a list of storable elements into a newly allocated, consecutive+-- sequence of storable values, where the end is fixed by the given end marker+--+newArray0             :: Storable a => a -> [a] -> IO (Ptr a)+newArray0 marker vals  = do+  ptr <- mallocArray0 (length vals)+  pokeArray0 marker ptr vals+  return ptr++-- |Temporarily store a list of storable values in memory+-- (like 'Foreign.Marshal.Utils.with', but for multiple elements).+--+withArray :: Storable a => [a] -> (Ptr a -> IO b) -> IO b+withArray vals = withArrayLen vals . const++-- |Like 'withArray', but the action gets the number of values+-- as an additional parameter+--+withArrayLen :: Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b+withArrayLen vals f  = etaIO $+  len `seq` allocaArray len $ \ptr -> do+      pokeArray ptr vals+      res <- f len ptr+      return res+  where+    len = length vals++-- |Like 'withArray', but a terminator indicates where the array ends+--+withArray0 :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b+withArray0 marker vals = withArrayLen0 marker vals . const++-- |Like 'withArrayLen', but a terminator indicates where the array ends+--+withArrayLen0 :: Storable a => a -> [a] -> (Int -> Ptr a -> IO b) -> IO b+withArrayLen0 marker vals f  = etaIO $+  len `seq` allocaArray0 len $ \ptr -> do+      pokeArray0 marker ptr vals+      res <- f len ptr+      return res+  where+    len = length vals+++-- copying (argument order: destination, source)+-- -------++-- |Copy the given number of elements from the second array (source) into the+-- first array (destination); the copied areas may /not/ overlap+--+copyArray :: Storable a => Ptr a -> Ptr a -> Int -> IO ()+copyArray  = doCopy undefined+  where+    doCopy                     :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO ()+    doCopy dummy dest src size  = copyBytes dest src (size * sizeOf dummy)++-- |Copy the given number of elements from the second array (source) into the+-- first array (destination); the copied areas /may/ overlap+--+moveArray :: Storable a => Ptr a -> Ptr a -> Int -> IO ()+moveArray  = doMove undefined+  where+    doMove                     :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO ()+    doMove dummy dest src size  = moveBytes dest src (size * sizeOf dummy)+++-- finding the length+-- ------------------++-- |Return the number of elements in an array, excluding the terminator+--+lengthArray0            :: (Storable a, Eq a) => a -> Ptr a -> IO Int+lengthArray0 marker ptr | ptr `seq` True  = etaIO $ loop 0+  where+    loop i | i `seq` True = do+        val <- peekElemOff ptr i+        if val == marker then return i else loop (i+1)+++-- indexing+-- --------++-- |Advance a pointer into an array by the given number of elements+--+advancePtr :: Storable a => Ptr a -> Int -> Ptr a+advancePtr  = doAdvance undefined+  where+    doAdvance             :: Storable a' => a' -> Ptr a' -> Int -> Ptr a'+    doAdvance dummy ptr i  = ptr `plusPtr` (i * sizeOf dummy)
+ lib/base/src/Foreign/Marshal/Error.hs view
@@ -0,0 +1,74 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.Marshal.Error+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Routines for testing return values and raising a 'userError' exception+-- in case of values indicating an error state.+--+-----------------------------------------------------------------------------++module Foreign.Marshal.Error (+  throwIf,       -- :: (a -> Bool) -> (a -> String) -> IO a       -> IO a+  throwIf_,      -- :: (a -> Bool) -> (a -> String) -> IO a       -> IO ()+  throwIfNeg,    -- :: (Ord a, Num a)+	         -- =>                (a -> String) -> IO a       -> IO a+  throwIfNeg_,   -- :: (Ord a, Num a)+	         -- =>                (a -> String) -> IO a       -> IO ()+  throwIfNull,   -- ::                String        -> IO (Ptr a) -> IO (Ptr a)++  -- Discard return value+  --+  void           -- IO a -> IO ()+) where++import Foreign.Ptr+import Prelude.IO+import Prelude.IOError+++-- exported functions+-- ------------------++-- |Execute an 'IO' action, throwing a 'userError' if the predicate yields+-- 'True' when applied to the result returned by the 'IO' action.+-- If no exception is raised, return the result of the computation.+--+throwIf :: (a -> Bool)	-- ^ error condition on the result of the 'IO' action+	-> (a -> String) -- ^ computes an error message from erroneous results+			-- of the 'IO' action+	-> IO a		-- ^ the 'IO' action to be executed+	-> IO a+throwIf pred msgfct act  = do+    res <- act+    (if pred res then ioError . userError . msgfct else return) res++-- |Like 'throwIf', but discarding the result+--+throwIf_                 :: (a -> Bool) -> (a -> String) -> IO a -> IO ()+throwIf_ pred msgfct act  = void $ throwIf pred msgfct act++-- |Guards against negative result values+--+throwIfNeg :: (Ord a, Num a) => (a -> String) -> IO a -> IO a+throwIfNeg  = throwIf (< 0)++-- |Like 'throwIfNeg', but discarding the result+--+throwIfNeg_ :: (Ord a, Num a) => (a -> String) -> IO a -> IO ()+throwIfNeg_  = throwIf_ (< 0)++-- |Guards against null pointers+--+throwIfNull :: String -> IO (Ptr a) -> IO (Ptr a)+throwIfNull  = throwIf (== nullPtr) . const++-- |Discard the return value of an 'IO' action+--+void     :: IO a -> IO ()+void act  = act >> return ()
+ lib/base/src/Foreign/Marshal/Pool.hs view
@@ -0,0 +1,190 @@+{-# OPTIONS_GHC -fno-implicit-prelude #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Foreign.Marshal.Pool+-- Copyright   :  (c) Sven Panne 2002-2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  sven.panne@aedion.de+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains support for pooled memory management. Under this scheme,+-- (re-)allocations belong to a given pool, and everything in a pool is+-- deallocated when the pool itself is deallocated. This is useful when+-- 'Foreign.Marshal.Alloc.alloca' with its implicit allocation and deallocation+-- is not flexible enough, but explicit uses of 'Foreign.Marshal.Alloc.malloc'+-- and 'free' are too awkward.+--+-- modified by John Meacham to use unboxed linked lists directly+--+--------------------------------------------------------------------------------++module Foreign.Marshal.Pool(+   -- * Pool management+   Pool(),+   newPool,             -- :: IO Pool+   freePool,            -- :: Pool -> IO ()+   withPool,            -- :: (Pool -> IO b) -> IO b++   -- * (Re-)Allocation within a pool+   pooledMalloc,        -- :: Storable a => Pool                 -> IO (Ptr a)+   pooledMallocBytes,   -- ::               Pool          -> Int -> IO (Ptr a)++   pooledRealloc,       -- :: Storable a => Pool -> Ptr a        -> IO (Ptr a)+   pooledReallocBytes,  -- ::               Pool -> Ptr a -> Int -> IO (Ptr a)++   pooledMallocArray,   -- :: Storable a => Pool ->          Int -> IO (Ptr a)+   pooledMallocArray0,  -- :: Storable a => Pool ->          Int -> IO (Ptr a)++   pooledReallocArray,  -- :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)+   pooledReallocArray0, -- :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)++   -- * Combined allocation and marshalling+   pooledNew,           -- :: Storable a => Pool -> a            -> IO (Ptr a)+   pooledNewArray,      -- :: Storable a => Pool ->      [a]     -> IO (Ptr a)+   pooledNewArray0      -- :: Storable a => Pool -> a -> [a]     -> IO (Ptr a)+) where++import Control.Exception     ( bracket )+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array ( pokeArray, pokeArray0 )+import Foreign.Ptr+import Foreign.Storable++--------------------------------------------------------------------------------++-- To avoid non-H98 stuff like existentially quantified data constructors, we+-- simply use pointers to () below. Not very nice, but...++-- | A memory pool.++++newtype Pool = Pool (Ptr (Ptr ())) -- (IORef [Ptr ()])++-- | Allocate a fresh memory pool.++newPool :: IO Pool+newPool = do+    pool <- malloc+    poke pool nullPtr+    return $ Pool pool++-- | Deallocate a memory pool and everything which has been allocated in the+-- pool itself.++freePool :: Pool -> IO ()+freePool (Pool pool) = f pool where+    f p = do+        v <- peek p+        free p+        if v == nullPtr then return () else f (castPtr v :: Ptr (Ptr ()))++-- | Execute an action with a fresh memory pool, which gets automatically+-- deallocated (including its contents) after the action has finished.++withPool :: (Pool -> IO b) -> IO b+withPool = bracket newPool freePool++--------------------------------------------------------------------------------++-- | Allocate space for storable type in the given pool. The size of the area+-- allocated is determined by the 'sizeOf' method from the instance of+-- 'Storable' for the appropriate type.++pooledMalloc :: Storable a => Pool -> IO (Ptr a)+pooledMalloc = pm undefined+  where+    pm           :: Storable a' => a' -> Pool -> IO (Ptr a')+    pm dummy pool = pooledMallocBytes pool (sizeOf dummy)++-- | Allocate the given number of bytes of storage in the pool.++pooledMallocBytes :: Pool -> Int -> IO (Ptr a)+pooledMallocBytes (Pool pool) size = do+    ptr <- mallocBytes (size + sizeOf pool)+    v <- peek pool+    poke ptr (v :: Ptr ())+    return ((ptr :: Ptr (Ptr ())) `plusPtr` sizeOf pool)++-- | Adjust the storage area for an element in the pool to the given size of+-- the required type.++pooledRealloc :: Storable a => Pool -> Ptr a -> IO (Ptr a)+pooledRealloc = pr undefined+  where+    pr               :: Storable a' => a' -> Pool -> Ptr a' -> IO (Ptr a')+    pr dummy pool ptr = pooledReallocBytes pool ptr (sizeOf dummy)++-- | Adjust the storage area for an element in the pool to the given size.++pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a)+pooledReallocBytes = error "pools don't support reallocing the size" --(Pool pool) ptr size = do+--   let cPtr = castPtr ptr+--   throwIf (not . (cPtr `elem`)) (\_ -> "pointer not in pool") (readIORef pool)+--   newPtr <- reallocBytes cPtr size+--   ptrs <- readIORef pool+--   writeIORef pool (newPtr : delete cPtr ptrs)+--   return (castPtr newPtr)++-- | Allocate storage for the given number of elements of a storable type in the+-- pool.++pooledMallocArray :: Storable a => Pool -> Int -> IO (Ptr a)+pooledMallocArray = pma undefined+  where+    pma                :: Storable a' => a' -> Pool -> Int -> IO (Ptr a')+    pma dummy pool size = pooledMallocBytes pool (size * sizeOf dummy)++-- | Allocate storage for the given number of elements of a storable type in the+-- pool, but leave room for an extra element to signal the end of the array.++pooledMallocArray0 :: Storable a => Pool -> Int -> IO (Ptr a)+pooledMallocArray0 pool size =+   pooledMallocArray pool (size + 1)++-- | Adjust the size of an array in the given pool.++pooledReallocArray :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)+pooledReallocArray = pra undefined+  where+    pra                ::  Storable a' => a' -> Pool -> Ptr a' -> Int -> IO (Ptr a')+    pra dummy pool ptr size  = pooledReallocBytes pool ptr (size * sizeOf dummy)++-- | Adjust the size of an array with an end marker in the given pool.++pooledReallocArray0 :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)+pooledReallocArray0 pool ptr size =+   pooledReallocArray pool ptr (size + 1)++--------------------------------------------------------------------------------++-- | Allocate storage for a value in the given pool and marshal the value into+-- this storage.++pooledNew :: Storable a => Pool -> a -> IO (Ptr a)+pooledNew pool val = do+   ptr <- pooledMalloc pool+   poke ptr val+   return ptr++-- | Allocate consecutive storage for a list of values in the given pool and+-- marshal these values into it.++pooledNewArray :: Storable a => Pool -> [a] -> IO (Ptr a)+pooledNewArray pool vals = do+   ptr <- pooledMallocArray pool (length vals)+   pokeArray ptr vals+   return ptr++-- | Allocate consecutive storage for a list of values in the given pool and+-- marshal these values into it, terminating the end with the given marker.++pooledNewArray0 :: Storable a => Pool -> a -> [a] -> IO (Ptr a)+pooledNewArray0 pool marker vals = do+   ptr <- pooledMallocArray0 pool (length vals)+   pokeArray0 marker ptr vals+   return ptr++
+ lib/base/src/Foreign/Marshal/Utils.hs view
@@ -0,0 +1,175 @@+{-# OPTIONS_LHC -N -fffi #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.Marshal.Utils+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Utilities for primitive marshaling+--+-----------------------------------------------------------------------------++module Foreign.Marshal.Utils (+  -- * General marshalling utilities++  -- ** Combined allocation and marshalling+  --+  with,          -- :: Storable a => a -> (Ptr a -> IO b) -> IO b+  new,           -- :: Storable a => a -> IO (Ptr a)++  -- ** Marshalling of Boolean values (non-zero corresponds to 'True')+  --+  fromBool,      -- :: Num a => Bool -> a+  toBool,	 -- :: Num a => a -> Bool++  -- ** Marshalling of Maybe values+  --+  maybeNew,      -- :: (      a -> IO (Ptr a))+		 -- -> (Maybe a -> IO (Ptr a))+  maybeWith,     -- :: (      a -> (Ptr b -> IO c) -> IO c)+		 -- -> (Maybe a -> (Ptr b -> IO c) -> IO c)+  maybePeek,     -- :: (Ptr a -> IO        b )+		 -- -> (Ptr a -> IO (Maybe b))++  -- ** Marshalling lists of storable objects+  --+  withMany,      -- :: (a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res++  -- ** Haskellish interface to memcpy and memmove+  -- | (argument order: destination, source)+  --+  copyBytes,     -- :: Ptr a -> Ptr a -> Int -> IO ()+  moveBytes     -- :: Ptr a -> Ptr a -> Int -> IO ()++) where++import Foreign.Ptr	        ( Ptr, nullPtr )+import Foreign.Storable		( Storable(poke) )+import Foreign.C.Types    	( CSize )+import Foreign.Marshal.Alloc 	( malloc, alloca )+import Lhc.Basics+import Lhc.IO+import Lhc.List+import Lhc.Monad+import Lhc.Num+import Lhc.Order+import Lhc.Maybe+++-- combined allocation and marshalling+-- -----------------------------------++-- |Allocate a block of memory and marshal a value into it+-- (the combination of 'malloc' and 'poke').+-- The size of the area allocated is determined by the 'Foreign.Storable.sizeOf'+-- method from the instance of 'Storable' for the appropriate type.+--+-- The memory may be deallocated using 'Foreign.Marshal.Alloc.free' or+-- 'Foreign.Marshal.Alloc.finalizerFree' when no longer required.+--+new     :: Storable a => a -> IO (Ptr a)+new val  =+  do+    ptr <- malloc+    poke ptr val+    return ptr++-- |@'with' val f@ executes the computation @f@, passing as argument+-- a pointer to a temporarily allocated block of memory into which+-- 'val' has been marshalled (the combination of 'alloca' and 'poke').+--+-- The memory is freed when @f@ terminates (either normally or via an+-- exception), so the pointer passed to @f@ must /not/ be used after this.+--+with       :: Storable a => a -> (Ptr a -> IO b) -> IO b+with val f  =+  alloca $ \ptr -> do+    poke ptr val+    res <- f ptr+    return res++++-- marshalling of Boolean values (non-zero corresponds to 'True')+-- -----------------------------++-- |Convert a Haskell 'Bool' to its numeric representation+--+fromBool       :: Num a => Bool -> a+fromBool False  = 0+fromBool True   = 1++-- |Convert a Boolean in numeric representation to a Haskell value+--+toBool :: Num a => a -> Bool+toBool  = (/= 0)+++-- marshalling of Maybe values+-- ---------------------------++-- |Allocate storage and marshall a storable value wrapped into a 'Maybe'+--+-- * the 'nullPtr' is used to represent 'Nothing'+--+maybeNew :: (      a -> IO (Ptr a))+	 -> (Maybe a -> IO (Ptr a))+maybeNew  = maybe (return nullPtr)++-- |Converts a @withXXX@ combinator into one marshalling a value wrapped+-- into a 'Maybe', using 'nullPtr' to represent 'Nothing'.+--+maybeWith :: (      a -> (Ptr b -> IO c) -> IO c)+	  -> (Maybe a -> (Ptr b -> IO c) -> IO c)+maybeWith  = maybe ($ nullPtr)++-- |Convert a peek combinator into a one returning 'Nothing' if applied to a+-- 'nullPtr'+--+maybePeek                           :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)+maybePeek peek ptr | ptr == nullPtr  = return Nothing+		   | otherwise       = do a <- peek ptr; return (Just a)+++-- marshalling lists of storable objects+-- -------------------------------------++-- |Replicates a @withXXX@ combinator over a list of objects, yielding a list of+-- marshalled objects+--+withMany :: (a -> (b -> res) -> res)  -- withXXX combinator for one object+	 -> [a]			      -- storable objects+	 -> ([b] -> res)	      -- action on list of marshalled obj.s+	 -> res+withMany _       []     f = f []+withMany withFoo (x:xs) f = withFoo x $ \x' ->+			      withMany withFoo xs (\xs' -> f (x':xs'))+++-- Haskellish interface to memcpy and memmove+-- ------------------------------------------++-- |Copies the given number of bytes from the second area (source) into the+-- first (destination); the copied areas may /not/ overlap+--+copyBytes               :: Ptr a -> Ptr a -> Int -> IO ()+copyBytes dest src size  = memcpy dest src (fromIntegral size)++-- |Copies the given number of elements from the second area (source) into the+-- first (destination); the copied areas /may/ overlap+--+moveBytes               :: Ptr a -> Ptr a -> Int -> IO ()+moveBytes dest src size  = memmove dest src (fromIntegral size)+++-- auxilliary routines+-- -------------------++-- |Basic C routines needed for memory copying+--+foreign import ccall  "string.h memcpy" memcpy  :: Ptr a -> Ptr a -> CSize -> IO ()+foreign import ccall  "string.h memmove" memmove :: Ptr a -> Ptr a -> CSize -> IO ()
+ lib/base/src/Foreign/Ptr.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS_LHC -N -fffi -funboxed-tuples #-}++module Foreign.Ptr(+    Ptr(),+    nullPtr,+    castPtr,+    plusPtr,+    alignPtr,+    minusPtr,+    FunPtr(),+    nullFunPtr,+    castFunPtr,+    castFunPtrToPtr,+    castPtrToFunPtr,+    freeHaskellFunPtr+    ) where+++import Lhc.Show+import Lhc.Inst.Show+import Lhc.Monad+import Lhc.Order+import Lhc.IO+import Lhc.Basics+import Lhc.Num+import Lhc.Addr+import Foreign.Storable+++instance Show (Ptr a) where+    showsPrec n (Ptr x) = showsPrec n (toInteger (addrToWordPtr  x))++nullPtr :: Ptr a+nullPtr = Ptr nullAddr++plusPtr :: Ptr a -> Int -> Ptr b+plusPtr (Ptr addr) off = Ptr (plusAddr addr off)++minusPtr :: Ptr a -> Int -> Ptr b+minusPtr (Ptr addr) off = Ptr (plusAddr addr (negate off))+++alignPtr :: Ptr a -> Int -> Ptr a+alignPtr = error "alignPtr"+--alignPtr addr@(Ptr a) (I# i)+--  = case remAddr# a i of {+--      0# -> addr;+--      n -> Ptr (plusAddr# a (i -# n)) }++++nullFunPtr = FunPtr nullFunAddr+castFunPtr (FunPtr addr) = FunPtr addr++--castFunPtrToPtr :: FunPtr a -> Ptr b+--castFunPtrToPtr = unsafeCoerce++--castPtrToFunPtr :: Ptr a -> FunPtr b+--castPtrToFunPtr = unsafeCoerce+++foreign import primitive "U2U" castFunPtrToPtr :: FunPtr a -> Ptr b+foreign import primitive "U2U" castPtrToFunPtr :: Ptr a -> FunPtr b++
+ lib/base/src/Foreign/StablePtr.hs view
@@ -0,0 +1,49 @@+{-# OPTIONS_LHC -N -fffi #-}+module Foreign.StablePtr(+    StablePtr(),+    castStablePtrToPtr,+    castPtrToStablePtr,+    newStablePtr,+    deRefStablePtr,+    freeStablePtr+    ) where++import Lhc.Addr+import Lhc.Basics+import Lhc.IO+import Lhc.Monad++newtype StablePtr a = StablePtr (Ptr ())+data PlaceHolder++castPtrToStablePtr :: Ptr () -> StablePtr a+castPtrToStablePtr p = StablePtr p++castStablePtrToPtr :: StablePtr a -> Ptr ()+castStablePtrToPtr (StablePtr p) = p+++freeStablePtr :: StablePtr a -> IO ()+freeStablePtr _ = return ()++newStablePtr :: a -> IO (StablePtr a)+newStablePtr x = do+    ptr <- ref_ptr (unsafeCoerce x)+    return (StablePtr ptr)++deRefStablePtr :: StablePtr a -> IO a+deRefStablePtr (StablePtr x) = do+    v <- deref_ptr x+    return (unsafeCoerce v)++deref_ptr = undefined+ref_ptr = undefined+unsafeCoerce = undefined++{-++foreign import primitive deref_ptr :: Ptr () -> IO PlaceHolder+foreign import primitive ref_ptr   :: PlaceHolder -> IO (Ptr ())++foreign import primitive unsafeCoerce :: a -> b+-}
+ lib/base/src/Foreign/Storable.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_LHC -N #-}+module Foreign.Storable(Storable(..)) where++import Lhc.Basics+import Lhc.Addr+import Lhc.Int+import Lhc.IO++plusPtr :: Ptr a -> Int -> Ptr b+plusPtr (Ptr addr) off = Ptr (plusAddr addr off)++class Storable a where+    sizeOf :: a -> Int+    alignment :: a -> Int+    peekElemOff :: Ptr a -> Int -> IO a+    pokeElemOff :: Ptr a -> Int -> a -> IO ()+    peekByteOff :: Ptr b -> Int -> IO a+    pokeByteOff :: Ptr b -> Int -> a -> IO ()+    peek :: Ptr a -> IO a+    poke :: Ptr a -> a -> IO ()++    alignment x = sizeOf x+    peekElemOff addr idx = IO $ \w -> unIO (peek $! (addr `plusPtr` (idx `times` sizeOf (_f addr)))) w+    pokeElemOff addr idx x = IO $ \w -> unIO (let adr = (addr `plusPtr` (idx `times` sizeOf x)) in adr `seq` poke adr x) w+    peekByteOff addr off = IO $ \w -> unIO (peek $! (addr `plusPtr` off)) w+    pokeByteOff addr off x = IO $ \w -> unIO (let adr = (addr `plusPtr` off) in adr `seq` poke adr x) w++_f :: Ptr a -> a+_f _ = undefined++
+ lib/base/src/Foreign/Storable.m4 view
@@ -0,0 +1,21 @@+++m4_define(INST_STORABLE,{{++instance Storable $1 where+    peek (Ptr (Addr addr)) = IO $ \w -> case peek$2 addr w of+        (# w', r #) -> (# w', $1 r #)+    poke (Ptr (Addr addr)) ($1 v) = IO $ \w -> case poke$2 addr v w of+        w' -> (# w', () #)+    sizeOf _ = boxInt (sizeOf$2 0#)+    alignment _ = boxInt (alignmentOf$2 0#)++ONCE({{+foreign import primitive "peek.$3" peek$2 :: Addr__ -> UIO $2+foreign import primitive "poke.$3" poke$2 :: Addr__ -> $2 -> UIO_+foreign import primitive "sizeOf.$3" sizeOf$2 :: $2 -> Int__+foreign import primitive "alignmentOf.$3" alignmentOf$2 :: $2 -> Int__+}})++}})+
+ lib/base/src/Lhc/ACIO.hs view
@@ -0,0 +1,86 @@+{-# OPTIONS_LHC -N  #-}+module Lhc.ACIO where++import Lhc.IORef+import Lhc.IO+import Lhc.Monad+++newtype ACIO a = ACIO (IO a)+    deriving(Monad,Functor)++unsafeIOToACIO :: IO a -> ACIO a+unsafeIOToACIO x = ACIO x++acioToIO :: ACIO a -> IO a+acioToIO (ACIO x) = x++newIORefAC :: a -> ACIO (IORef a)+newIORefAC a = unsafeIOToACIO (newIORef a)+++runOnce :: IO a -> ACIO (IO a)+runOnce action = do+    ref <- newIORefAC Nothing+    return $ do+        v <- readIORef ref+        case v of+            Just v -> return v+            Nothing -> do+                v <- action+                writeIORef ref v+                return v++{-@Extensions++# Top Level Actions++Lhc supports monadic actions declared at the top level of your module. These+can be used to do things such as initialize IORefs or allocate static data. An example+of a top level action is the following.++    import Lhc.ACIO+    import Data.IORef++    ref <- newIORefAC 0++    count = do+        modifyIORef ref (1 +)+        readIORef ref >>= print++    main = do+        count+        count+        count++Which will print 1, 2, and 3. A special monad ACIO (which stands for Affine+Central IO) is provided to restrict what may take place in top level actions.+Basically, top level actions can only consist of IO that can be omitted or+reordered without changing the meaning of a program. In practice, this means+that it does not matter whether such actions are all performed at the beginning+or are only computed once on demand.++If you need to use arbitrary IO, a utility function 'runOnce' is provided.+using it you can ensure arbitrary IO actions are run only once and the return+values shared, however you must access the value inside the IO monad, thus+ensuring program integrity. An example using a hypothetical GUI library is below.+++    import Lhc.ACIO++    getWindow <- runOnce $ do+        connection <- newGUIConnection+        window <- createWindow (640,480)+        setTitle window "My Global Window"+        return window++    main = do+        w <- getWindow+        draw w "Hello!"++Note, top level global variables can be indicative of design issues. In+general, they should only be used when necessary to interface with an external+library, opaque uses inside a library where the shared state can not be+externally observed, or inside your Main program as design dictates.++-}
+ lib/base/src/Lhc/Addr.hs view
@@ -0,0 +1,83 @@+{-# OPTIONS_LHC -N -fffi -funboxed-values -fm4 #-}++m4_include(Lhc/Order.m4)+m4_include(Foreign/Storable.m4)++module Lhc.Addr(+    Addr(..),+    FunAddr(..),+    Ptr(..),+    FunPtr(..),+    ptrFromAddr__,+    nullAddr,+    castPtr,+    nullFunAddr,+    plusAddr,+    addrToWordPtr,+    wordPtrToAddr,+    wordPtrToFunAddr,+    funAddrToWordPtr+    ) where++import Lhc.Int+import Data.Word+import Lhc.Prim+import Lhc.Types+import Lhc.Order+import Lhc.Basics+import Lhc.IO+import Foreign.Storable++data Addr = Addr BitsPtr_+data FunAddr = FunAddr BitsPtr_++newtype Ptr a = Ptr Addr+newtype FunPtr a = FunPtr FunAddr++nullAddr = Addr 0#+nullFunAddr = FunAddr 0#++INST_EQORDER(Addr,BitsPtr_)+INST_EQORDER(FunAddr,BitsPtr_)++INST_STORABLE(Addr,BitsPtr_,bits<ptr>)+INST_STORABLE(FunAddr,BitsPtr_,bits<ptr>)++{-# INLINE plusAddr #-}+plusAddr :: Addr -> Int -> Addr+plusAddr (Addr addr) off = case unboxInt off of+    off_ -> Addr (addr `plusWordPtr` intToPtr__ off_)++foreign import primitive "U2U" addrToWordPtr :: Addr -> WordPtr+foreign import primitive "U2U" wordPtrToAddr :: WordPtr -> Addr+foreign import primitive "U2U" wordPtrToFunAddr :: WordPtr -> FunAddr+foreign import primitive "U2U" funAddrToWordPtr :: FunAddr -> WordPtr++foreign import primitive "Sx" intToPtr__ :: Int__ -> BitsPtr_++foreign import primitive "Add" plusWordPtr :: BitsPtr_ -> BitsPtr_ -> BitsPtr_++ptrFromAddr__ :: Addr__ -> Ptr a+ptrFromAddr__ addr = Ptr (Addr addr)++instance Storable (Ptr a) where+    sizeOf (Ptr a) = sizeOf a+    alignment (Ptr a) = alignment a+    peek p = peek (castPtr p) `thenIO` (returnIO . Ptr)+    poke p (Ptr x) = poke (castPtr p) x++instance Eq (Ptr a) where+    Ptr a == Ptr b = a == b+    Ptr a /= Ptr b = a /= b++instance Ord (Ptr a) where+    compare (Ptr a) (Ptr b) = compare a b+    Ptr a <= Ptr b = a <= b+    Ptr a < Ptr b = a < b+    Ptr a > Ptr b = a > b+    Ptr a >= Ptr b = a >= b++castPtr :: Ptr a -> Ptr b+castPtr (Ptr addr) = Ptr addr++
+ lib/base/src/Lhc/Array.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_LHC -N -funboxed-tuples -fffi #-}+module Lhc.Array where++import Lhc.Basics+import Lhc.IO+import Lhc.Int++++data MutArray__ :: * -> #+data Array__ :: * -> #++foreign import primitive newMutArray__      :: Int__ -> a -> UIO (MutArray__ a)+foreign import primitive newBlankMutArray__ :: Int__ -> UIO (MutArray__ a)+foreign import primitive copyArray__        :: Int__ -> Int__ -> Int__ -> Array__ a -> MutArray__ a -> UIO_+foreign import primitive copyMutArray__     :: Int__ -> Int__ -> Int__ -> MutArray__ a -> MutArray__ a -> UIO_+foreign import primitive readArray__        :: MutArray__ a -> Int__ -> UIO a+foreign import primitive writeArray__       :: MutArray__ a -> Int__ -> a -> UIO_+foreign import primitive indexArray__       :: Array__ a -> Int__ -> (# a #)++-- these basically cast from a mutable to an immutable array and back again+foreign import primitive unsafeFreezeArray__ :: MutArray__ a -> UIO (Array__ a)+foreign import primitive unsafeThawArray__ :: Array__ a -> UIO (MutArray__ a)++foreign import primitive newWorld__ :: a -> World__++newArray :: a -> Int -> [(Int,a)] -> Array__ a+newArray init n xs = case unboxInt n of+    n' -> case newWorld__ (init,n,xs) of+     w -> case newMutArray__ n' init w of+      (# w, arr #) -> let+        f :: MutArray__ a -> World__ -> [(Int,a)] -> World__+        f arr w [] = w+        f arr w ((i,v):xs) = case unboxInt i of i' -> case writeArray__ arr i' v w of w -> f arr w xs+            in case f arr w xs of w -> case unsafeFreezeArray__ arr w  of (# _, r #) -> r+
+ lib/base/src/Lhc/Basics.hs view
@@ -0,0 +1,180 @@+{-# OPTIONS_LHC -N -fffi #-}+module Lhc.Basics(module Lhc.Basics, module Lhc.Prim) where++import Lhc.Prim+import Lhc.Int++data (->) :: ?? -> ? -> *+data Integer++type String = [Char]++data () = ()+data (,) a b = (,) a b+data (,,) a b c = (,,) a b c+data (,,,) a b c d = (,,,) a b c d+data (,,,,) a b c d e = (,,,,) a b c d e+data (,,,,,) a b c d e f = (,,,,,) a b c d e f+data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g+data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h+data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i++++------------------------+-- the basic combinators+------------------------++{-# SUPERINLINE id, const, (.), ($), ($!), flip #-}++infixr 9  .+infixr 0  $, $!, `seq`++id x = x+const x _ = x+f . g = \x -> f (g x)+f $ x = f x+f $! x = x `seq` f x+flip f x y = f y x++-- asTypeOf is a type-restricted version of const.  It is usually used+-- as an infix operator, and its typing forces its first argument+-- (which is usually overloaded) to have the same type as the second.++{-# SUPERINLINE asTypeOf #-}+asTypeOf         :: a -> a -> a+asTypeOf         =  const+++{-# INLINE seq #-}+foreign import primitive seq :: a -> b -> b+++--------------------+-- some tuple things+--------------------++{-# INLINE fst, snd #-}+fst (a,b) = a+snd (a,b) = b++uncurry f (x,y) = f x y+curry f x y = f (x,y)++++----------------------+-- Basic list routines+----------------------+++-- iterate f x returns an infinite list of repeated applications of f to x:+-- iterate f x == [x, f x, f (f x), ...]++iterate          :: (a -> a) -> a -> [a]+iterate f x      =  x : iterate f (f x)++-- repeat x is an infinite list, with x the value of every element.++repeat           :: a -> [a]+repeat x         =  xs where xs = x:xs++++-- Map and append++map :: (a -> b) -> [a] -> [b]+map f xs = go xs where+    go [] = []+    go (x:xs) = f x : go xs++++infixr 5  ++++(++) :: [a] -> [a] -> [a]+[]     ++ ys = ys+(x:xs) ++ ys = x : (xs ++ ys)+++foldl            :: (a -> b -> a) -> a -> [b] -> a+foldl f z []     =  z+foldl f z (x:xs) =  foldl f (f z x) xs+++scanl            :: (a -> b -> a) -> a -> [b] -> [a]+scanl f q xs     =  q : (case xs of+                            []   -> []+                            x:xs -> scanl f (f q x) xs)++++reverse          :: [a] -> [a]+--reverse          =  foldl (flip (:)) []+reverse l =  rev l [] where+    rev []     a = a+    rev (x:xs) a = rev xs (x:a)+++-- zip takes two lists and returns a list of corresponding pairs.  If one+-- input list is short, excess elements of the longer list are discarded.+-- zip3 takes three lists and returns a list of triples.  Zips for larger+-- tuples are in the List library+++zip :: [a] -> [b] -> [(a,b)]+zip (a:as) (b:bs) = (a,b) : zip as bs+zip _      _      = []++-- The zipWith family generalises the zip family by zipping with the+-- function given as the first argument, instead of a tupling function.+-- For example, zipWith (+) is applied to two lists to produce the list+-- of corresponding sums.++zipWith          :: (a->b->c) -> [a]->[b]->[c]+zipWith z (a:as) (b:bs) =  z a b : zipWith z as bs+zipWith _ _ _    =  []+++concat :: [[a]] -> [a]+concat [] = []+concat (x:xs) = case x of+    [] -> concat xs+    (y:ys) -> y:concat (ys:xs)+++concatMap :: (a -> [b]) -> [a] -> [b]+concatMap f xs = g xs where+    g [] = []+    g (x:xs) = f x ++ g xs+++foldr :: (a -> b -> b) -> b -> [a] -> b+foldr k z [] = z+foldr k z (x:xs) = k x (foldr k z xs)++foreign import primitive "error.Prelude.undefined" undefined :: a++ord :: Char -> Int+ord (Char c) = boxInt c++chr :: Int -> Char+chr i = Char (unboxInt i)++unsafeChr :: Int -> Char+unsafeChr = chr++{-+foreign import primitive "ULte" bits32ULte  :: Bits32_ -> Bits32_ -> Bool__+foreign import primitive "error.Prelude.chr: value out of range" chr_error :: a++chr :: Int -> Char+chr i = case unboxInt i of+    i' -> case i' `bits32ULTE` 0x10FFFF# of+        1# -> Char i'+        0# -> chr_error++unsafeChr :: Int -> Char+unsafeChr i = Char (unboxInt i)+-}+
+ lib/base/src/Lhc/Enum.hs view
@@ -0,0 +1,95 @@+{-# OPTIONS_LHC -N -fffi -funboxed-values #-}+module Lhc.Enum(Enum(..),Bounded(..)) where+-- Enumeration and Bounded classes++import Lhc.Inst.PrimEnum()+import Data.Int+import Lhc.Types+import Lhc.Basics+import Lhc.Order+import Lhc.Int++class  Enum a  where+    succ, pred       :: a -> a+    toEnum           :: Int -> a+    fromEnum         :: a -> Int+    enumFrom         :: a -> [a]             -- [n..]+    enumFromThen     :: a -> a -> [a]        -- [n,n'..]+    enumFromTo       :: a -> a -> [a]        -- [n..m]+    enumFromThenTo   :: a -> a -> a -> [a]   -- [n,n'..m]++        -- Minimal complete definition:+        --      toEnum, fromEnum+--+-- NOTE: these default methods only make sense for types+--   that map injectively into Int using fromEnum+--  and toEnum.+    succ             =  toEnum . increment . fromEnum+    pred             =  toEnum . decrement . fromEnum+    enumFrom x       =  map toEnum [fromEnum x ..]+    enumFromTo x y   =  map toEnum [fromEnum x .. fromEnum y]+    enumFromThen x y =  map toEnum [fromEnum x, fromEnum y ..]+    enumFromThenTo x y z =+                        map toEnum [fromEnum x, fromEnum y .. fromEnum z]+++class Bounded a  where+    minBound         :: a+    maxBound         :: a++instance Enum Int where+    succ = increment+    pred = decrement+    toEnum x = x+    fromEnum x = x++    enumFrom x  | x `seq` True  =  enumFromTo x maxBound+    enumFromThen c c' = [c, c' .. lastInt]+                      where lastInt | c' < c    = minBound+                                    | otherwise = maxBound+    enumFromTo x y = f x where+        f x | x > y = []+            | otherwise = x:f (increment x)+    enumFromThenTo x y z | y >= x = f x where+        inc = y `minus` x+        f x | x <= z = x:f (x `plus` inc)+            | otherwise = []+    enumFromThenTo x y z  = f x where+        inc = y `minus` x+        f x | x >= z = x:f (x `plus` inc)+            | otherwise = []+++instance Enum Char where+    toEnum = chr+    fromEnum = ord+    enumFrom c        = [c .. maxBound::Char]+    enumFromThen c c' = [c, c' .. lastChar]+                      where lastChar :: Char+                            lastChar | c' < c    = minBound+                                     | otherwise = maxBound+--    enumFromTo (Char x) (Char y) = f x where+--        f x = case x `bits32UGt` y of+--            0# -> []+--            1# -> Char x:f (bits32Increment x)+--    enumFromThenTo (Char x) (Char y) (Char z) =+--        case y `bits32Sub` x of+--            inc -> let f x = case x `bits32UGte` z of+--                            1# -> Char x:f (x `bits32Add` inc)+--                            0# -> []+--             in f x+++instance Bounded Char where+    minBound = Char 0#+    maxBound = Char 0x10ffff#++foreign import primitive "UGt"       bits32UGt       :: Bits32_ -> Bits32_ -> Bool__+foreign import primitive "UGte"      bits32UGte      :: Bits32_ -> Bits32_ -> Bool__+foreign import primitive "increment" bits32Increment :: Bits32_ -> Bits32_++foreign import primitive "Add"       bits32Add       :: Bits32_ -> Bits32_ -> Bits32_+foreign import primitive "Sub"       bits32Sub       :: Bits32_ -> Bits32_ -> Bits32_+++
+ lib/base/src/Lhc/Float.hs view
@@ -0,0 +1,228 @@+{-# OPTIONS_LHC -N -fffi -fm4 #-}++module Lhc.Float(+    Float(..),+    Double(..),+    floatToDouble,+    doubleToFloat,+    Floating(..),+    RealFrac(..),+    RealFloat(..),+    rationalToDouble+    )+    where++import Lhc.Basics+import Lhc.Int+import Lhc.IO(error)+import Lhc.Num+import Lhc.Order+import Lhc.Types+import Lhc.Enum++infixr 8  **++data Float = Float Float32_+data Double = Double Float64_+++foreign import primitive "F2F" floatToDouble :: Float -> Double+foreign import primitive "F2F" doubleToFloat :: Double -> Float++ -- floating point stuff++class  (Fractional a) => Floating a  where+    pi                  :: a+    exp, log, sqrt      :: a -> a+    (**), logBase       :: a -> a -> a+    sin, cos, tan       :: a -> a+    asin, acos, atan    :: a -> a+    sinh, cosh, tanh    :: a -> a+    asinh, acosh, atanh :: a -> a++        -- Minimal complete definition:+        --      pi, exp, log, sin, cos, sinh, cosh+        --      asin, acos, atan+        --      asinh, acosh, atanh+    x ** y           =  exp (log x * y)+    logBase x y      =  log y / log x+    sqrt x           =  x ** (1 / 2) -- 0.5        -- TODO Doubles+    tan  x           =  sin  x / cos  x+    tanh x           =  sinh x / cosh x++++-- TODO Doubles+class  (Real a, Fractional a) => RealFrac a  where+    properFraction   :: (Integral b) => a -> (b,a)+    truncate, round  :: (Integral b) => a -> b+    ceiling, floor   :: (Integral b) => a -> b++++        -- Minimal complete definition:+        --      properFraction+    truncate x       =  m  where (m,_) = properFraction x++    round x          =  let (n,r) = properFraction x+                            m     = if r < 0 then n - 1 else n + 1+                          in case signum (abs r - (1 / 2)) of+                                -1 -> n+                                0  -> if n `rem` 2 == 0 then n else m+                                1  -> m++    ceiling x        =  if r > 0 then n + 1 else n+                        where (n,r) = properFraction x++    floor x          =  if r < 0 then n - 1 else n+                        where (n,r) = properFraction x++        -- Minimal complete definition:+        --      properFraction++    properFractionf   :: a -> (a,a)+    truncatef, roundf :: a -> a+    ceilingf, floorf  :: a -> a++    truncatef x       =  m  where (m,_) = properFractionf x+    roundf x          =  fromInteger (round x)+    ceilingf x        =  if r > 0 then n + 1 else n+                        where (n,r) = properFractionf x+    floorf x          =  if r < 0 then n - 1 else n+                        where (n,r) = properFractionf x+++-- TODO Doubles+class  (RealFrac a, Floating a) => RealFloat a  where+    floatRadix       :: a -> Integer+    floatDigits      :: a -> Int+    floatRange       :: a -> (Int,Int)+    decodeFloat      :: a -> (Integer,Int)+    encodeFloat      :: Integer -> Int -> a+    exponent         :: a -> Int+    significand      :: a -> a+    scaleFloat       :: Int -> a -> a+    isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE+                     :: a -> Bool+    atan2            :: a -> a -> a++        -- Minimal complete definition:+        --      All except exponent, significand,+        --                 scaleFloat, atan2+    exponent x       =  if m == 0 then 0 else n + floatDigits x+                        where (m,n) = decodeFloat x++    significand x    =  encodeFloat m (- floatDigits x)+                        where (m,_) = decodeFloat x++    scaleFloat k x   =  encodeFloat m (n+k)+                        where (m,n) = decodeFloat x++    atan2 y x+      | x>0           =  atan (y/x)+      | x==0 && y>0   =  pi/2+      | x<0  && y>0   =  pi + atan (y/x)+      |(x<=0 && y<0)  ||+       (x<0 && isNegativeZero y) ||+       (isNegativeZero x && isNegativeZero y)+                      = -atan2 (-y) x+      | y==0 && (x<0 || isNegativeZero x)+                      =  pi    -- must be after the previous test on zero y+      | x==0 && y==0  =  y     -- must be after the other double zero tests+      | otherwise     =  x + y -- x or y is a NaN, return a NaN (via +)++    decodeFloatf     :: a -> (a,Int)+    decodeFloatf x    = case decodeFloat x of+        (v,exp) -> (fromInteger v,exp)++    encodeFloatf     :: a -> Int -> a+    encodeFloatf a i = scaleFloat i a++++rationalToDouble :: Rational -> Double+rationalToDouble (x:%y) = fromInteger x `divideDouble` fromInteger y++foreign import primitive "FDiv" divideDouble ::  Double -> Double -> Double+foreign import primitive "box" boxBool :: Bool__ -> Bool+++m4_define(NUMINSTANCE,+instance Num $1 where+    $1 x * $1 y = $1 (times$1 x y)+    $1 x + $1 y = $1 (plus$1 x y)+    $1 x - $1 y = $1 (minus$1 x y)+    abs ($1 x) = $1 (abs$1 x)+    negate ($1 x) = $1 (neg$1 x)+    fromInt x = fromInt$1 x+    fromInteger x = fromInteger$1 x+    signum x = case compare x 0 of+        EQ -> 0+        GT -> 1+        LT -> -1++foreign import primitive "FMul" times$1 :: $2 -> $2 -> $2+foreign import primitive "FAdd" plus$1  :: $2 -> $2 -> $2+foreign import primitive "FSub" minus$1 :: $2 -> $2 -> $2++foreign import primitive "FAbs" abs$1 :: $2 -> $2+foreign import primitive "FNeg" neg$1 :: $2 -> $2++foreign import primitive "I2F"  fromInt$1 :: Int -> $1+foreign import primitive "I2F"  fromInteger$1 :: Integer -> $1++foreign import primitive "F2I"  toInt$1 :: $1 -> Int++instance Enum $1 where+    succ = increment$1+    pred = decrement$1+    toEnum x = fromInt$1 x+    fromEnum x = toInt$1 x++    enumFrom x  | x `seq` True     =  x:enumFrom (increment$1 x)+    enumFromTo x y = f x where+        f x | x > y = []+            | otherwise = x:f (increment$1 x)+    enumFromThen x y | x `seq` y `seq` True = f x where+        z = y `fminus$1` x+        f x = x:f (x `fplus$1` z)+    enumFromThenTo x y z | y >= x = f x where+        inc = y `fminus$1` x+        f x | x <= z = x:f (x `fplus$1` inc)+            | otherwise = []+    enumFromThenTo x y z  = f x where+        inc = y `fminus$1` x+        f x | x >= z = x:f (x `fplus$1` inc)+            | otherwise = []++foreign import primitive "fincrement" increment$1 :: $1 -> $1+foreign import primitive "fdecrement" decrement$1 :: $1 -> $1+foreign import primitive "FAdd" fplus$1  :: $1 -> $1 -> $1+foreign import primitive "FSub" fminus$1 :: $1 -> $1 -> $1++instance Eq $1 where+    $1 x == $1 y = boxBool (x `eq$2` y)+    $1 x /= $1 y = boxBool (x `neq$2` y)++instance Ord $1 where+    $1 x < $1 y = boxBool (flt$2 x y)+    $1 x > $1 y = boxBool (fgt$2 x y)+    $1 x <= $1 y = boxBool (flte$2 x y)+    $1 x >= $1 y = boxBool (fgte$2 x y)++++foreign import primitive "FEq" eq$2   :: $2 -> $2 -> Bool__+foreign import primitive "FNEq" neq$2 :: $2 -> $2 -> Bool__+foreign import primitive "FLt" flt$2  :: $2 -> $2 -> Bool__+foreign import primitive "FLte" flte$2 :: $2 -> $2 -> Bool__+foreign import primitive "FGt" fgt$2 :: $2 -> $2 -> Bool__+foreign import primitive "FGte" fgte$2 :: $2 -> $2 -> Bool__++)++++NUMINSTANCE(Float,Float32_)+NUMINSTANCE(Double,Float64_)+
+ lib/base/src/Lhc/Handle.hs view
@@ -0,0 +1,91 @@+{-# OPTIONS_LHC -fffi -funboxed-values #-}+module Lhc.Handle(+    Handle(..),+    IOMode(..),+    stdin,+    stdout,+    stderr,+    withHandle,+    hClose,+    hIsOpen,+    openFile+    ) where++import Foreign.Ptr+import Foreign.Storable+import Foreign.C.Types+import Lhc.IO+import Lhc.Addr+import Foreign.C.String+import Foreign.Marshal.Utils+import Foreign.C.Error++data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode+    deriving(Eq, Ord, Bounded, Enum, Read, Show)++data Handle = Handle {+    handleName :: String,+    handleFile :: Ptr (Ptr Handle),+    handleIOMode :: IOMode+    }++instance Show Handle where+    showsPrec _ h s = handleName h ++ s++stdin, stdout, stderr :: Handle++make_builtin mode name std = Handle { handleName = "(" ++ name ++ ")", handleFile = std, handleIOMode = mode }++stdin = make_builtin ReadMode "stdin" c_stdin+stdout = make_builtin WriteMode "stdout" c_stdout+stderr = make_builtin WriteMode "stderr" c_stderr++{-+stdin  = Handle (unsafePerformIO (peek c_stdin))+stdout = Handle (unsafePerformIO (peek c_stdout))+stderr = Handle (unsafePerformIO (peek c_stderr))+-}++foreign import ccall "stdio.h &stdin" c_stdin :: Ptr (Ptr Handle)+foreign import ccall "stdio.h &stdout" c_stdout :: Ptr (Ptr Handle)+foreign import ccall "stdio.h &stderr" c_stderr :: Ptr (Ptr Handle)++withHandle h action = do+    ptr <- peek (handleFile h)+    case ptr == nullPtr of+        True -> fail $ handleName h ++ ": handle  is closed"+        False -> action ptr++hClose h = do+    ptr <- peek (handleFile h)+    case ptr == nullPtr of+        True -> return ()+        False -> c_fclose ptr >> poke (handleFile h) nullPtr++hIsOpen h = do+    ptr <- peek (handleFile h)+    return (ptr /= nullPtr)++throwErrnoFN     :: String	-- ^ textual description of the error location+               -> String+	       -> IO a+throwErrnoFN loc fn  = do+    errno <- getErrno+    ioError (errnoToIOError loc errno Nothing (Just fn))++openFile :: FilePath -> IOMode -> IO Handle+openFile fp m = do+    ptr <- withCString fp $ \cfp -> c_fopen cfp (toStr m)+    if ptr == nullPtr then throwErrnoFN "openFile" fp  else do+        pptr <- new ptr+        return Handle { handleName = fp, handleIOMode = m, handleFile = pptr }++toStr ReadMode = ptrFromAddr__ "r"#+toStr WriteMode = ptrFromAddr__ "w"#+toStr AppendMode = ptrFromAddr__ "a"#+toStr ReadWriteMode = ptrFromAddr__ "r+"#++foreign import ccall "stdio.h fclose" c_fclose :: Ptr Handle -> IO CInt+foreign import ccall "stdio.h fopen" c_fopen :: Ptr CChar -> Ptr CChar ->  IO (Ptr Handle)++
+ lib/base/src/Lhc/Hole.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_LHC -fffi #-}+-- | this module provides a once-updatable value that may be used in pure code.+-- it is an _unchecked_ error to read a hole before it has been filled in.+-- filling in a hole has the effect of 'seq'ing its value immediatly so lift it in+-- a datatype if this is an issue.+--+-- this module should not be used unless you really know what you are doing.+-- incorrect usage may result in memory corruption.++module Lhc.Hole(Hole(),newHole,fillHole,readHole,errorHole) where++import Lhc.IO++newtype Hole a = Hole a++-- | unchecked error if readHole is evaled before fillHole has filled it in.+readHole :: Hole a -> IO a+readHole (Hole x) = strictReturn x++-- | create a new hole containing a garbage value. must not be read until it has been filled.+newHole :: IO (Hole a)+newHole = IO $ \world -> newHole__ world++-- | hole that can be written to and results discarded. never read this.+errorHole :: Hole a+errorHole = Hole undefined+++-- | it is an unchecked error to fill in the same hole more than once.+fillHole :: Hole a -> a -> IO ()+fillHole r v = IO $ \world -> case fillHole__ r v world of+    world' -> (# world', () #)++foreign import primitive newHole__  :: World__ -> (# World__, Hole a #)+foreign import primitive fillHole__ :: Hole a -> a -> World__ -> World__+
+ lib/base/src/Lhc/IO.hs view
@@ -0,0 +1,178 @@+{-# OPTIONS_LHC -N -funboxed-tuples -fffi #-}++module Lhc.IO(+    IO(..),+    thenIO,+    thenIO_,+    returnIO,++    UIO(),+    UIO_(),++    World__(),+    catch,+    unIO,+    etaIO,+    dependingOn,+    fixIO,+    ioError,+    runExpr,+    runMain,+    runNoWrapper,+    exitFailure,+    strictReturn,+    unsafeInterleaveIO,+    error,+    IOError(),+    showIOError,+    userError,+    unsafePerformIO,+    unsafePerformIO'+    ) where++import Lhc.Prim+import Lhc.Basics+import Lhc.Order+import Foreign.C.Types+import qualified Lhc.Options+++-- basic types+++unIO :: IO a -> World__ -> (# World__, a #)+unIO (IO x) = x++type UIO a = World__ -> (# World__, a #)+type UIO_ = World__ -> World__++-- | this ensures the world parameter is eta expanded out+{-# INLINE etaIO #-}+etaIO :: IO a -> IO a+etaIO x = IO $ \w -> unIO x w++-- unsafe operations++unsafePerformIO :: IO a -> a+unsafePerformIO x = case newWorld__ x of+    world -> case errorContinuation x of+        IO y -> case y world of+            (# _, a #) -> a++-- | same as unsafePerformIO, but doesn't set up error handler+unsafePerformIO' :: IO a -> a+unsafePerformIO' x = case newWorld__ x of+    world -> case (unIO x) world of+            (# _, a #) -> a++-- we have to replace the error handler because the context might have quit by the time the value is evaluated.+unsafeInterleaveIO :: IO a -> IO a+unsafeInterleaveIO action = IO $ \w -> (# w , case action' w of (# _,  a #) -> a #)+    where IO action' = errorContinuation action+++-- 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 Lhc.Options.target of+    Lhc.Options.GhcHs -> IO $ \w -> raiseIO__ e w+    _ -> showError e+++catch :: IO a -> (IOError -> IO a) -> IO a+catch (IO m) k =  case Lhc.Options.target of+    Lhc.Options.GhcHs -> IO $ \s -> catch__ m (\ex -> unIO (k ex)) s+    _ -> IO m  -- no catching on other targets just yet+++-- IO fixpoint operation++data FixIO a = FixIO World__ a++fixIO :: (a -> IO a) -> IO a+fixIO k = IO $ \w -> let+            r = case k ans of+                    IO z -> case z w of+                        (# w, r #) -> FixIO w r+            ans = case r of+                FixIO _ z -> z+               in case r of+                FixIO w z -> (# w, z #)+++-- some primitives+++-- | this creates a new world object that artificially depends on its argument to avoid CSE.+foreign import primitive newWorld__ :: a -> World__+foreign import primitive "dependingOn" worldDep__ :: forall b. b -> World__ -> b++-- | this will return a value making it artificially depend on the state of the world. any uses of this value are guarenteed not to float before this point in the IO monad.+strictReturn :: a -> IO a+strictReturn a = IO $ \w -> (# w, worldDep__ a w #)++{-# INLINE runMain #-}+-- | this is wrapped around 'main' when compiling programs. it catches any exceptions and prints them to the screen and dies appropriatly.+runMain :: IO a -> World__ -> World__+runMain main w = case run w of+        (# w,  _ #) -> w+    where+    IO run = catch main $ \e ->+            putErrLn "\nUncaught Exception:" `thenIO_`+            putErrLn (showIOError e)         `thenIO_`+            exitFailure+++++exitFailure :: IO a+exitFailure = IO $ \w -> exitFailure__ w++foreign import primitive exitFailure__ :: World__ -> (# World__, a #)+++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'++returnIO :: a -> IO a+returnIO x = IO $ \w -> (# w, x #)++{-# 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 (charToInt c)++foreign import primitive "U2U" charToInt :: Char -> Int+foreign import ccall "stdio.h lhc_utf8_putchar" c_putwchar :: Int -> IO ()+
+ lib/base/src/Lhc/Inst/Enum.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS_LHC -N -fffi -funboxed-values -fm4 #-}++module Lhc.Inst.Enum() where++import Data.Word+import Data.Int+import Lhc.Enum+import Lhc.Num+import Lhc.Order+import Lhc.IO(error)+import Lhc.Basics++m4_define(ENUMINST,{{+instance Enum $1 where+    toEnum = fromInt+    fromEnum = toInt+    succ = increment$1+    pred = decrement$1+    enumFrom c        = [c .. maxBound]+    enumFromThen c c' = last `seq` [c, c' .. last]+                      where last | c' < c    = minBound+                                 | otherwise = maxBound+    enumFromTo x y = f x where+        f x | x > y = []+            | otherwise = x:f (x + 1)+    enumFromThenTo x y z | y >= x = inc `seq` z `seq` f x where+        inc = y - x+        f x | x <= z = x:f (x + inc)+            | otherwise = []+    enumFromThenTo x y z  = dec `seq` z `seq` f x where+        dec = x - y+        f x | x >= z = x:f (x - dec)+            | otherwise = []++foreign import primitive "increment" increment$1 :: $1 -> $1+foreign import primitive "decrement" decrement$1 :: $1 -> $1++}})++ENUMINST(Word)+ENUMINST(Word8)+ENUMINST(Word16)+ENUMINST(Word32)+ENUMINST(Word64)+ENUMINST(WordPtr)+ENUMINST(WordMax)++ENUMINST(Int8)+ENUMINST(Int16)+ENUMINST(Int32)+ENUMINST(Int64)+ENUMINST(IntPtr)+ENUMINST(IntMax)+ENUMINST(Integer)+++instance Enum () where+    succ _      = error "Prelude.Enum.().succ: bad argument"+    pred _      = error "Prelude.Enum.().pred: bad argument"++    toEnum x | x == 0 = ()+             | otherwise    = error "Prelude.Enum.().toEnum: bad argument"++    fromEnum () = 0+    enumFrom () 	= [()]+    enumFromThen () () 	= let many = ():many in many+    enumFromTo () () 	= [()]+    enumFromThenTo () () () = let many = ():many in many++
+ lib/base/src/Lhc/Inst/PrimEnum.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS_LHC -N -fffi -funboxed-values #-}++-- | helper routines for deriving(Enum) instances+-- these routines help out the compiler when+-- deriving enums.++module Lhc.Inst.PrimEnum(enum_succ,enum_pred,enum_fromTo,enum_fromThen,enum_fromThenTo,enum_toEnum,enum_from) where+++import Lhc.Prim+import Lhc.Int+import Lhc.Types+++{-# INLINE enum_toEnum, enum_succ, enum_pred, enum_fromTo, enum_fromThen, enum_fromThenTo, enum_from #-}++enum_toEnum :: (Enum__ -> a) -> Int__ -> Int -> a+enum_toEnum box max int = case unboxInt int of+    int_ -> case int_ `bits32UGt` max of+        1# -> toEnumError+        0# -> box (intToEnum int_)++foreign import primitive "error.toEnum: out of range" toEnumError :: a+foreign import primitive "error.succ: out of range" succError :: a+foreign import primitive "error.pred: out of range" predError :: a+foreign import primitive "UGt"       bits32UGt       :: Bits32_ -> Bits32_ -> Bool__++enum_succ :: (Enum__ -> a) -> (a -> Enum__) -> Enum__ -> a -> a+enum_succ box debox max e = case debox e of+    e_ -> case e_ `enumEq` max of+        0# -> box (enumInc e_)+        1# -> succError++enum_pred :: (Enum__ -> a) -> (a -> Enum__) -> a -> a+enum_pred box debox e = case debox e of+    e_ -> case e_ `enumEq` 0# of+        0# -> box (enumDec e_)+        1# -> predError++enum_from :: (Enum__ -> a) -> (a -> Enum__) -> Enum__ -> a -> [a]+enum_from box debox max x = case debox x of+    x_ -> f x_ where+        f x = case x `enumGt` max of+            0# -> box x:f (enumInc x)+            1# -> []++enum_fromTo :: (Enum__ -> a) -> (a -> Enum__) -> a -> a -> [a]+enum_fromTo box debox x y = case debox y of+    y_ -> enum_from box debox y_ x++enum_fromThen :: (Enum__ -> a) -> (a -> Enum__) -> Enum__ -> a -> a -> [a]+enum_fromThen box debox max x y = case debox x of+    x_ -> case debox y of+        y_ -> case x_ `enumGt` y_ of+            0# -> enum_fromThenToUp' box x_ y_ max+            1# -> enum_fromThenToDown' box x_ y_ 0#++enum_fromThenTo :: (Enum__ -> a) -> (a -> Enum__) -> a -> a -> a -> [a]+enum_fromThenTo box debox x y z = case debox x of+    x_ -> case debox y of+        y_ -> case debox z of+            z_ -> case x_ `enumGt` y_ of+                0# -> enum_fromThenToUp' box x_ y_ z_+                1# -> enum_fromThenToDown' box x_ y_ z_++enum_fromThenToUp' :: (Enum__ -> a) -> Enum__ -> Enum__ -> Enum__ -> [a]+enum_fromThenToUp' box x y z = case y `enumSub` x of+            inc -> let f x = case x `enumGt` z of+                            0# -> box x:f (x `enumAdd` inc)+                            1# -> []+             in f x++enum_fromThenToDown' :: (Enum__ -> a) -> Enum__ -> Enum__ -> Enum__ -> [a]+enum_fromThenToDown' box x y z = case y `enumSub` x of+            inc -> let f x = case x `enumLt` z of+                            0# -> box x:f (x `enumAdd` inc)+                            1# -> []+             in f x++foreign import primitive "Eq"         enumEq  :: Enum__ -> Enum__ -> Bool__+foreign import primitive "Gt"         enumGt  :: Enum__ -> Enum__ -> Bool__+foreign import primitive "Lt"         enumLt  :: Enum__ -> Enum__ -> Bool__+foreign import primitive "Gte"        enumGte :: Enum__ -> Enum__ -> Bool__+foreign import primitive "Add"        enumAdd :: Enum__ -> Enum__ -> Enum__+foreign import primitive "Sub"        enumSub :: Enum__ -> Enum__ -> Enum__+foreign import primitive "increment"  enumInc :: Enum__ -> Enum__+foreign import primitive "decrement"  enumDec :: Enum__ -> Enum__+foreign import primitive "U2U"        intToEnum :: Int__ -> Enum__
+ lib/base/src/Lhc/Inst/Read.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS_LHC -N -fm4 #-}++module Lhc.Inst.Read() where++import Prelude.Text+import Data.Int+import Lhc.Basics+import Data.Word+import Lhc.Order+import Lhc.Float+import Prelude.Float+import Lhc.Num+import Numeric(showSigned, showInt, readSigned, readDec, showFloat,+               readFloat, lexDigits)++-- Reading at the Integer type avoids+-- possible difficulty with minInt++m4_define(READINST,{{+instance  Read $1  where+  readsPrec p r = [(fromInteger i, t) | (i,t) <- readsPrec p r]+}})+++READINST(Int8)+READINST(Int16)+READINST(Int32)+READINST(Int64)+READINST(IntMax)+READINST(IntPtr)++m4_define(READWORD,{{+instance  Read $1  where+  readsPrec _ r = readDec r+}})++READWORD(Word)+READWORD(Word8)+READWORD(Word16)+READWORD(Word32)+READWORD(Word64)+READWORD(WordMax)+READWORD(WordPtr)+++instance Read () where+    readsPrec p    = readParen False+                            (\r -> [((),t) | ("(",s) <- lex r,+                                             (")",t) <- lex s ] )++instance  Read Double  where+    readsPrec p         = readSigned readDouble++instance  Read Float  where+    readsPrec p s        = [ (doubleToFloat x,y) | (x,y) <- readSigned readDouble s]
+ lib/base/src/Lhc/Inst/Show.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS_LHC -N #-}++module Lhc.Inst.Show() where++import Data.Int+import Data.Word+import Lhc.Basics+import Lhc.Num+import Lhc.Order+import Lhc.Show++-- we convert them to Word or WordMax so the showIntAtBase specialization can occur.++instance Show Word where+    showsPrec _ x = showWord x++instance Show Word8 where+    showsPrec _ x = showWord (fromIntegral x :: Word)++instance Show Word16 where+    showsPrec _ x = showWord (fromIntegral x :: Word)++instance Show Word32 where+    showsPrec _ x = showWord (fromIntegral x :: Word)++instance Show Word64 where+    showsPrec _ x = showWordMax (fromIntegral x :: WordMax)++instance Show WordPtr where+    showsPrec _ x = showWordMax (fromIntegral x :: WordMax)++instance Show WordMax where+    showsPrec _ x = showWordMax x++instance Show Int where+    showsPrec p x+        | x < 0 = showParen (p > 6) (showChar '-' . showWord (fromIntegral $ negate x :: Word))+        | otherwise = showWord (fromIntegral x :: Word)++instance Show Integer where+    showsPrec p x+        | x < 0 = showParen (p > 6) (showChar '-' . showWordMax (fromIntegral $ negate x :: WordMax))+        | otherwise = showWordMax (fromIntegral x :: WordMax)++instance Show Int8 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)+instance Show Int16 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)+instance Show Int32 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)+instance Show Int64 where+    showsPrec p x = showsPrec p (fromIntegral x :: Integer)+instance Show IntPtr where+    showsPrec p x = showsPrec p (fromIntegral x :: Integer)+++-- specialized base 10 only versions of show+showWord :: Word -> String -> String+showWord w rest = w `seq` case quotRem w 10 of+    (n',d) -> n' `seq` d `seq` rest' `seq` if n' == 0 then rest' else showWord n' rest'+        where rest' = chr (fromIntegral d + ord '0') : rest++showWordMax :: WordMax -> String -> String+showWordMax w rest = w `seq` case quotRem w 10 of+    (n',d) -> n' `seq` d `seq` rest' `seq` if n' == 0 then rest' else showWordMax n' rest'+        where rest' = chr (fromIntegral d + ord '0') : rest+
+ lib/base/src/Lhc/Inst/Storable.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_LHC -fm4 -N -fffi -funboxed-tuples -funboxed-values #-}+module Lhc.Inst.Storable where++m4_include(Foreign/Storable.m4)++import Lhc.Types+import Lhc.Float+import Foreign.Storable+import Lhc.Prim+import Lhc.Basics+import Lhc.Addr+import Lhc.Int+import Lhc.IO+++INST_STORABLE(Float,Float32_,fbits32)+INST_STORABLE(Double,Float64_,fbits64)++
+ lib/base/src/Lhc/Int.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_LHC -N -fffi #-}++-- just a few basic operations on integers to jumpstart things+module Lhc.Int(Int(),Int__(),increment,decrement,plus,minus,times,divide,modulus,zero,one,boxInt,unboxInt) where++import Lhc.Prim(Int(),Int__())++foreign import primitive increment :: Int -> Int+foreign import primitive decrement :: Int -> Int+foreign import primitive "Add" plus      :: Int -> Int -> Int+foreign import primitive "Sub" minus     :: Int -> Int -> Int+foreign import primitive "Mul" times     :: Int -> Int -> Int+foreign import primitive "Div" divide    :: Int -> Int -> Int+foreign import primitive "Mod" modulus   :: Int -> Int -> Int+foreign import primitive zero      :: Int+foreign import primitive one       :: Int++foreign import primitive "box" boxInt :: Int__ -> Int+foreign import primitive "unbox" unboxInt :: Int -> Int__
+ lib/base/src/Lhc/JumpPoint.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_LHC -fffi #-}+module Lhc.JumpPoint(JumpPoint(), withJumpPoint__, jumpJumpPoint__, errorJumpPoint) where++import Lhc.IO+import Lhc.Addr++newtype JumpPoint = JumpPoint Addr+++-- | in order to be safe, the JumpPoint must not escape the handling function+withJumpPoint__ :: (JumpPoint -> Bool -> IO a) -> IO a+withJumpPoint__ action = do+    p <- _malloc jmp_buf_size+    let jp = (JumpPoint p)+    r <- lhc_setjmp jp+    r <- action jp (r /= 0)+    _free p+    return r++jumpJumpPoint__ :: JumpPoint -> IO a+jumpJumpPoint__ jp = lhc_longjmp  jp >> return (error "jumpJumpPoint__")++-- | jumping to this jumppoint will always abort the program.+foreign import ccall "&lhc_uncaught" errorJumpPoint :: JumpPoint++foreign import ccall lhc_setjmp :: JumpPoint -> IO Int+foreign import ccall lhc_longjmp :: JumpPoint -> IO ()+foreign import primitive "const.sizeof(jmp_buf)" jmp_buf_size  :: Int+foreign import ccall "malloc.h malloc" _malloc :: Int -> IO Addr+foreign import ccall "malloc.h free" _free :: Addr -> IO ()+++
+ lib/base/src/Lhc/List.hs view
@@ -0,0 +1,319 @@+{-# OPTIONS_LHC -N #-}+module Lhc.List where++import Lhc.Basics+import Lhc.IO(error)+import Lhc.Int+import Lhc.Order++import Lhc.String+++-- | our fusion routines++build :: (forall b . (a -> b -> b) -> b -> b) -> [a]+build g = g (:) []+++augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]+augment g xs = g (:) xs++{-# RULES "foldr/nil" forall k z.   foldr k z []  = z  #-}+{-# RULES "foldr/single"  forall k z x . foldr k z [x] = k x z #-}+{-# RULES "foldr/double"  forall k z x y . foldr k z [x,y] = k x (k y z) #-}+{-# RULES "foldr/triple"  forall k z a b c . foldr k z [a,b,c] = k a (k b (k c z)) #-}+{-# RULES "foldr/id"      foldr (:) [] = \x -> x  #-}+{- "foldr/app"    	[1] forall ys. foldr (:) ys = \xs -> xs ++ ys -}++{-# RULES "foldr/build" forall k z (g :: forall b . (a -> b -> b) -> b -> b) . foldr k z (build g) = g k z #-}+{-# RULES "foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) .  foldr k z (augment g xs) = g k (foldr k z xs) #-}+{-# RULES "foldr/single" forall k z x. foldr k z [x] = k x z #-}+{-# RULES "augment/build" forall (g::forall b. (a->b->b) -> b -> b)+		       (h::forall b. (a->b->b) -> b -> b) .+		       augment g (build h) = build (\c n -> g c (h c n)) #-}+{-# RULES "augment/nil"   forall (g::forall b. (a->b->b) -> b -> b) .  augment g [] = build g #-}++{-# RULES "foldr/unpackString"  forall k z (addr::Addr__) . foldr k z (unpackString addr) = unpackStringFoldr addr k z  #-}++-- a few pre-fusioned routines++filterIterate :: (a -> Bool) -> (a -> a) -> a -> [a]+filterIterate p f x = fi x where+    fi x | p x = x : fi (f x)+    fi x = fi (f x)++mapIterate :: (a -> b) -> (a -> a) -> a -> [b]+mapIterate f g x = fi x where+    fi x = f x : fi (g x)++filterMap :: (b -> Bool) -> (a -> b) -> [a] -> [b]+filterMap p f xs = fm xs where+    fm (x:xs) = let nx = f x in if p nx then nx:fm xs else fm xs+    fm [] = []++mapFilter :: (a -> b) -> (a -> Bool) -> [a] -> [b]+mapFilter f p xs = fm xs where+    fm (x:xs) = if p x then f x:fm xs else fm xs+    fm [] = []++{-# RULES "tail/map"      forall f xs . tail (map f xs) = map f (tail xs) #-}+{-# RULES "head/map"      forall f xs . head (map f xs) = f (head xs) #-}+{-# RULES "head/:"        forall x xs . head (x:xs) = x #-}+{-# RULES "tail/:"        forall x xs . tail (x:xs) = xs #-}++{-# RULES "filter/iterate" forall p f x . filter p (iterate f x) = filterIterate p f x  #-}+{-# RULES "map/iterate" forall f g x . map f (iterate g x) = mapIterate f g x  #-}+{-# RULES "map/filter" forall f p xs . map f (filter p xs) = mapFilter f p xs  #-}+{-# RULES "filter/map" forall f p xs . filter p (map f xs) = filterMap p f xs  #-}++-- efficient implementations of prelude routines++{-# CATALYST "and/foldr" forall . and = foldr (&&) True #-}+{-# CATALYST "or/foldr"  forall . or = foldr (||) False #-}++and, or          :: [Bool] -> Bool+and [] = True+and (False:_) = False+and (True:xs) = and xs++or [] = False+or (True:_) = True+or (False:xs) = or xs++{-# RULES "any/build"     forall p (g::forall b.(a->b->b)->b->b) .  any p (build g) = g ((||) . p) False #-}+++{-# RULES "all/build"     forall p (g::forall b.(a->b->b)->b->b) .  all p (build g) = g ((&&) . p) True #-}+++any, all         :: (a -> Bool) -> [a] -> Bool+any p xs = f xs where+    f [] = False+    f (x:xs) | p x = True+             | otherwise = f xs++all p xs = f xs where+    f [] = True+    f (x:xs) | not (p x) = False+             | otherwise = f xs++filter :: (a -> Bool) -> [a] -> [a]+filter p []                 = []+filter p (x:xs) | p x       = x : filter p xs+                | otherwise = filter p xs++-- elem is the list membership predicate, usually written in infix form,+-- e.g., x `elem` xs.  notElem is the negation.++infix  4  `elem`, `notElem`+++-- the implementation looks a little funny, but the reason for the+-- inner loop is so that both the == function and the unboxing of the+-- argument may occur right away outside the inner loop when the list isn't+-- empty.+++elem, notElem    :: (Eq a) => a -> [a] -> Bool+elem _ []	= False+elem x (y:ys)+    | x == y = True+    | otherwise = f y ys where+        f y _ | x == y = True+        f _ (y:ys) = f y ys+        f _ [] = False++{-# SPECIALIZE elem :: Char -> String -> Bool #-}+{-# SPECIALIZE elem :: Int -> [Int] -> Bool #-}+{-# RULES "elem/[]" forall c . elem c [] = False #-}+{-# RULES "elem/[_]" forall c v . elem c [v] = c == v #-}++notElem	_ []	=  True+notElem x (y:ys)+    | x == y = False+    | otherwise = f y ys where+        f y ys | x == y = False+        f _ (y:ys) = f y ys+        f _ [] = True++{-# SPECIALIZE notElem :: Char -> String -> Bool #-}+{-# SPECIALIZE notElem :: Int -> [Int] -> Bool #-}+{-# RULES "notElem/[]" forall c . notElem c [] = True #-}+{-# RULES "notElem/[_]" forall c v . notElem c [v] = c /= v #-}++infixl 9  !!++(!!)                :: [a] -> Int -> a+xs !! n | n < zero  =  error "Prelude.(!!): negative index"+	| otherwise =  sub xs n where+                sub :: [a] -> Int -> a+                sub _ n | n `seq` False = undefined+                sub []     _ = error "Prelude.(!!): index too large"+                sub (y:ys) n = if n == zero+                               then y+                               else sub ys $! (n `minus` one)++null             :: [a] -> Bool+null []          =  True+null (_:_)       =  False++-- length returns the length of a finite list as an Int.++length           :: [a] -> Int+length xs = f xs zero where+    f [] n = n+    f (_:xs) n = f xs $! n `plus` one++head             :: [a] -> a+head (x:_)       =  x+head []          =  error "Prelude.head: empty list"+++tail             :: [a] -> [a]+tail (_:xs)      =  xs+tail []          =  error "Prelude.tail: empty list"+++last             :: [a] -> a+last []          =  error "Prelude.last: empty list"+last (x:xs)      = last' x xs where+    last' x []     = x+    last' _ (y:ys) = last' y xs+++init             :: [a] -> [a]+init []          =  error "Prelude.init: empty list"+init (x:xs)      =  init' x xs where+    init' _ [] = []+    init' y (z:zs) = y:init' z zs+++{-# RULES "head/iterate"  forall f x . head (iterate f x) = x #-}+{-# RULES "head/repeat"   forall x . head (repeat x) = x #-}+{-# RULES "tail/repeat"   forall x . tail (repeat x) = repeat x #-}+{-# RULES "tail/iterate"  forall f x . tail (iterate f x) = iterate f (f x) #-}+{-# RULES "iterate/id" forall . iterate id = repeat #-}++{-+concatMap f = foldr ((++) . f) []+--concat xss = foldr (++) [] xss+concat xss = foldr (++) [] xss+concatMap f = foldr ((++) . f) []++and xs  = foldr (&&) True xs+sum xs = foldr (+) (0::Int) xs+(++) xs ys = augment (\c n -> foldr c n xs) ys+concat xs = foldr (++) [] xs+foldl f z xs = foldr (\b g a -> g (f a b)) id xs z++filter p xs = build (\c n -> foldr (filterFB c p) n xs)+{- RULES "filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x) #-}++{- NOINLINE filterFB #-}+filterFB c p x r | p x       = x `c` r+		 | otherwise = r+++{- NOINLINE iterateFB #-}+iterate f x = build (\c _n -> iterateFB c f x)+iterateFB c f x = x `c` iterateFB c f (f x)++head (x:xs) = x+head [] = badHead+++map f xs =  build (\c n -> foldr (mapFB c f) n xs)+{- NOINLINE mapFB #-}+mapFB ::  (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst+mapFB c f x ys = c (f x) ys+++badHead = error "Prelude.head: empty list"++{-# RULES "head/build"   forall (g::forall b.(a->b->b)->b->b) . head (build g) = g (\x _ -> x) badHead #-}++{-# RULES "head/augment"   forall xs (g::forall b. (a->b->b) -> b -> b) .  head (augment g xs) = g (\x _ -> x) (head xs) #-}++--repeat x = build (\c _n -> repeatFB c x)+--repeatFB c x = xs where xs = x `c` xs+++{-++++{-# RULES forall xs n (g :: forall b . (a -> b -> b) -> b -> b) . build g !! n  = bangBang g n  #-}++bangBang :: (forall b . (a -> b -> b) -> b -> b) -> Int -> a+g `bangBang` n+    | n < 0 = error "Prelude.(!!): negative index\n"+    | otherwise = g c k  where+            sub _ n | n `seq` False = undefined+            sub []     _ = error "Prelude.(!!): index too large\n"+            sub (y:ys) n = if n == 0+                           then y+                           else sub ys $! (n - 1)++-}++(!!) :: [a] -> Int -> a+xs !! n = foldr bangFB bangCon xs n++bangCon _ = error "!! out of range"++bangFB :: a -> (Int -> a) -> Int -> a+bangFB x _xs m | m == 0 = x+bangFB _x xs m = xs $! (m - 1)++{-# INLINE bangFB #-}+{-# INLINE iterateFB #-}+{-# INLINE (!!) #-}++++{-# RULES+"take"	   [~1] forall n xs . take n xs = case n of I# n# -> build (\c nil -> foldr (takeFB c nil) (takeConst nil) xs n#)+"takeList"  [1] forall n xs . foldr (takeFB (:) []) (takeConst []) xs n = takeUInt n xs+ #-}++{-# NOINLINE [0] takeConst #-}+-- just a version of const that doesn't get inlined too early, so we+-- can spot it in rules.  Also we need a type sig due to the unboxed Int#.+takeConst :: a -> Int# -> a+takeConst x _ = x++{-# NOINLINE [0] takeFB #-}+takeFB :: (a -> b -> c) -> c -> a -> (Int# -> b) -> Int# -> c+takeFB c n x xs m | m <=# 0#  = n+		  | otherwise = x `c` xs (m -# 1#)+  -}++-- takeWhile, applied to a predicate p and a list xs, returns the longest+-- prefix (possibly empty) of xs of elements that satisfy p.  dropWhile p xs+-- returns the remaining suffix.  span p xs is equivalent to+-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p.+++takeWhile               :: (a -> Bool) -> [a] -> [a]+takeWhile p []          =  []+takeWhile p (x:xs)+            | p x       =  x : takeWhile p xs+            | otherwise =  []+++dropWhile               :: (a -> Bool) -> [a] -> [a]+dropWhile p []          =  []+dropWhile p xs@(x:xs')+            | p x       =  dropWhile p xs'+            | otherwise =  xs++span, break             :: (a -> Bool) -> [a] -> ([a],[a])+span p []            = ([],[])+span p xs@(x:xs')+            | p x       =  (x:ys,zs)+            | otherwise =  ([],xs)+                           where (ys,zs) = span p xs'++{-# INLINE break #-}+break p                 =  span (not . p)+
+ lib/base/src/Lhc/Maybe.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_LHC -N -fffi #-}+module Lhc.Maybe where++import Lhc.Monad+import Lhc.Order+import Lhc.Show+import Lhc.List+import Lhc.Basics+import Lhc.Num++instance Monad Maybe where+    return x = Just x+    Nothing >>= _ = Nothing+    Just x >>= y = y x+    fail _ = Nothing++++instance Functor Maybe where+    fmap _ Nothing = Nothing+    fmap f (Just x) = Just (f x)++++-- Maybe+-- need to add Read instance++data Maybe a  =  Nothing | Just a+    deriving (Eq, Ord, Show)++maybe :: b -> (a -> b) -> Maybe a -> b+maybe n f m = case m of+    Just x -> f x+    Nothing -> n++
+ lib/base/src/Lhc/Monad.hs view
@@ -0,0 +1,89 @@+{-# OPTIONS_LHC -N -funboxed-tuples #-}++module Lhc.Monad where++import Lhc.Basics+import Lhc.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++{- SPECIALIZE sequence :: forall a . [IO a] -> IO [a] #-}+{- SPECIALIZE sequence_ :: forall a . [IO a] -> IO () #-}+{- SPECIALIZE mapM :: forall a b . (a -> IO b) -> [a]-> IO [b] #-}+{- SPECIALIZE mapM_ :: forall a b . (a -> IO b) -> [a]-> IO () #-}++{-# RULES "sequence/[]"   sequence [] = return [] #-}+{-# RULES "sequence_/[]"  sequence_ [] = return () #-}+{-# RULES "mapM/[]"       forall f . mapM f [] = return [] #-}+{-# RULES "mapM_/[]"      forall f . mapM_ f [] = return () #-}+{-# RULES "sequence_/++"  forall xs ys . sequence_ (xs ++ ys) = sequence_ xs >> sequence_ ys #-}+{-# RULES "mapM_/++"      forall xs ys f . mapM_ f (xs ++ ys) = mapM_ f xs >> mapM_ f ys #-}++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++sequence       :: Monad m => [m a] -> m [a]+sequence xs = f xs where+    f [] = return []+    f (x:xs) = x >>= \r -> f xs >>= \rs -> return (r:rs)++sequence_      :: Monad m => [m a] -> m ()+sequence_ xs  =  f xs where+    f [] = return ()+    f (x:xs) = x >> f xs++(=<<)            :: 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)++
+ lib/base/src/Lhc/Num.hs view
@@ -0,0 +1,108 @@+{-# OPTIONS_LHC -N #-}+module Lhc.Num where++import Lhc.Basics+import Lhc.Order+import Lhc.Show+import Lhc.IO(error)+import Lhc.Enum+import Lhc.Float++infixl 7 :%+infixl 7  *  , /, `quot`, `rem`, `div`, `mod`+infixl 6  +, -++data  Ratio a  = !a :% !a+type  Rational = Ratio Integer++numerator, denominator  :: Ratio a -> a+numerator (x :% _)      =  x+denominator (_ :% y)    =  y+++class  (Eq a, Show a) => Num a  where+    (+), (-), (*)    :: a -> a -> a+    negate           :: a -> a+    abs, signum      :: a -> a+    fromInteger      :: Integer -> a+    fromInt          :: Int -> a++        -- Minimal complete definition:+        --      All, except negate or (-)+    x - y            =  x + negate y+    negate x         =  0 - x+    fromInt i = fromInteger (toInteger i)+    fromInteger x = fromInt (toInt x)++class  (Num a, Ord a) => Real a  where+    toRational       ::  a -> Rational+    toDouble         ::  a -> Double+    toDouble x = rationalToDouble (toRational x)++class  (Real a, Enum a) => Integral a  where+    quot, rem        :: a -> a -> a+    div, mod         :: a -> a -> a+    quotRem, divMod  :: a -> a -> (a,a)+    toInteger        :: a -> Integer+    toInt            :: a -> Int++        -- Minimal complete definition:+        --      quotRem, toInteger+    n `quot` d       =  q  where (q,r) = quotRem n d+    n `rem` d        =  r  where (q,r) = quotRem n d+    n `div` d        =  q  where (q,r) = divMod n d+    n `mod` d        =  r  where (q,r) = divMod n d+    divMod n d       =  if signum r == - signum d then (q-1, r+d) else qr+                        where qr@(q,r) = quotRem n d+    quotRem n d       =  (n `quot` d, n `rem` d)+    toInteger x = toInteger (toInt x)+    toInt x = toInt (toInteger x)++class  (Num a) => Fractional a  where+    (/)              :: a -> a -> a+    recip            :: a -> a+    fromRational     :: Rational -> a+    fromDouble       :: Double   -> a++        -- Minimal complete definition:+        --      fromRational and (recip or (/))+    recip x          =  1 / x+    x / y            =  x * recip y++    --fromDouble x = fromRational (doubleToRational x)+++fromIntegral   :: (Integral a, Num b) => a -> b+fromIntegral x =  fromInteger (toInteger x)++realToFrac     :: (Real a, Fractional b) => a -> b+realToFrac x   =  fromRational (toRational x)++{-# RULES+  "realToFrac/toRational"     realToFrac = toRational+  "realToFrac/fromRational"   realToFrac = fromRational+  "realToFrac/toDouble"       realToFrac = toDouble+  "realToFrac/fromDouble"     realToFrac = fromDouble+ #-}++{-# RULES+  "fromIntegral/Int"          fromIntegral = (id :: Int -> Int)+  "fromIntegral/Integer"      fromIntegral = (id :: Integer -> Integer)+  "fromIntegral/toInt"        fromIntegral = toInt+  "fromIntegral/fromInt"      fromIntegral = fromInt+  "fromIntegral/toInteger"    fromIntegral = toInteger+  "fromIntegral/fromInteger"  fromIntegral = fromInteger+ #-}+++{-# INLINE subtract #-}+subtract         :: (Num a) => a -> a -> a+subtract         =  flip (-)++{-# INLINE even #-}+{-# INLINE odd #-}++even, odd        :: (Integral a) => a -> Bool+even n           =  n `rem` 2 == 0+odd              =  not . even+
+ lib/base/src/Lhc/Options.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_LHC -N -fffi #-}++module Lhc.Options(target,Target(..)) where++data Target = Grin | GhcHs | DotNet | Java+++{-# NOINLINE target #-}+target :: Target+target = unknown_target++foreign import primitive unknown_target :: Target+
+ lib/base/src/Lhc/Order.hs view
@@ -0,0 +1,131 @@+{-# OPTIONS_LHC -N -fffi #-}++module Lhc.Order(+    Bool(..),+    Ordering(..),+    Eq(..),+    Ord(..),+    (&&),+    (||),+    not,+    otherwise+    ) where++import Lhc.Enum+import Lhc.Basics++data Bool = False | True+    deriving (Eq, Ord, Bounded, Enum)++data  Ordering    =  LT | EQ | GT+    deriving (Eq, Ord, Bounded, Enum)++infix  4  ==, /=, <, <=, >=, >++class Eq a where+    (==) :: a -> a -> Bool+    (/=) :: a -> a -> Bool+    x == y = case x /= y of+        True -> False+        False -> True+    x /= y = case x == y of+        True -> False+        False -> True++class  (Eq a) => Ord a  where+    compare              :: a -> a -> Ordering+    (<), (<=), (>=), (>) :: a -> a -> Bool+    max, min             :: a -> a -> a++    compare x y | x == y    = EQ+                | x <= y    = LT+                | otherwise = GT++    x <= y  = compare x y /= GT+    x <  y  = compare x y == LT+    x >= y  = compare x y /= LT+    x >  y  = compare x y == GT++    -- Note that (min x y, max x y) = (x,y) or (y,x)+    max x y | x <= y    =  y+            | otherwise =  x+    min x y | x <= y    =  x+            | otherwise =  y+++instance Eq () where+    () == () = True+    () /= () = False++instance Ord () where+    () <= () = True+    () <  () = False+    () >= () = True+    () >  () = False+    max () () = ()+    min () () = ()+    compare () () = EQ++instance Bounded () where+    minBound = ()+    maxBound = ()++instance Eq a => Eq [a] where+    [] == [] = True+    (x:xs) == (y:ys) | x == y = xs == ys+    _ == _ = False++instance Ord a => Ord [a] where+    compare (x:xs) (y:ys) = case compare x y of+        EQ -> compare xs ys+        z -> z+    compare [] [] = EQ+    compare [] _ = LT+    compare _ [] = GT++    [] < [] = False+    [] < _ = True+    (x:xs) < (y:ys) = if x == y then xs < ys else x < y++    x > y = y < x++    x >= y = not (x < y)+    x <= y = not (y < x)+++instance Eq Char where+    Char x == Char y = boxBool (equalsChar x y)+    Char x /= Char y = boxBool (nequalsChar x y)++instance Ord Char where+    Char x < Char y = boxBool (bits32ULt x y)+    Char x > Char y = boxBool (bits32UGt x y)+    Char x <= Char y = boxBool (bits32ULte x y)+    Char x >= Char y = boxBool (bits32UGte x y)++infixr 3  &&+infixr 2  ||++{-# INLINE (&&), (||), not, otherwise #-}+(&&), (||)       :: Bool -> Bool -> Bool+True  && x       =  x+False && _       =  False+True  || _       =  True+False || x       =  x+++not              :: Bool -> Bool+not x = if x then False else True+++otherwise        :: Bool+otherwise        =  True++foreign import primitive "Eq" equalsChar :: Char__ -> Char__ -> Bool__+foreign import primitive "NEq" nequalsChar :: Char__ -> Char__ -> Bool__+foreign import primitive "ULt" bits32ULt :: Char__ -> Char__ -> Bool__+foreign import primitive "ULte" bits32ULte :: Char__ -> Char__ -> Bool__+foreign import primitive "UGt" bits32UGt :: Char__ -> Char__ -> Bool__+foreign import primitive "UGte" bits32UGte :: Char__ -> Char__ -> Bool__+foreign import primitive "box" boxBool :: Bool__ -> Bool+
+ lib/base/src/Lhc/Order.m4 view
@@ -0,0 +1,39 @@+m4_divert(-1)+m4_dnl simple macros for defining instances for classes in Lhc.Order++m4_define(BOXBOOL,{{ONCE({{+foreign import primitive "box" boxBool :: Bool__ -> Bool+}})}})++m4_define(INST_EQ,{{+instance Eq $1 where+    $1 x == $1 y = boxBool (equals$2 x y)+    $1 x /= $1 y = boxBool (nequals$2 x y)+ONCE({{+foreign import primitive "Eq" equals$2 :: $2 -> $2 -> Bool__+foreign import primitive "NEq" nequals$2 :: $2 -> $2 -> Bool__+}})+BOXBOOL()+}})+++m4_define(INST_ORDER,{{+instance Ord $1 where+    $1 x < $1 y = boxBool (lt$2 x y)+    $1 x > $1 y = boxBool (gt$2 x y)+    $1 x <= $1 y = boxBool (lte$2 x y)+    $1 x >= $1 y = boxBool (gte$2 x y)+ONCE({{+foreign import primitive "$3Lt" lt$3$2   :: $2 -> $2 -> Bool__+foreign import primitive "$3Lte" lte$3$2 :: $2 -> $2 -> Bool__+foreign import primitive "$3Gt" gt$3$2   :: $2 -> $2 -> Bool__+foreign import primitive "$3Gte" gte$3$2 :: $2 -> $2 -> Bool__+}})+BOXBOOL()+}})++m4_define(INST_EQORDER,{{INST_EQ($1,$2)INST_ORDER($1,$2,$3)}})++m4_divert++
+ lib/base/src/Lhc/Prim.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_LHC -N -fffi -funboxed-tuples #-}+module Lhc.Prim where++-- this module is always included in all programs compiled by lhc. it defines some things that are needed to make lhc work at all.++import Lhc.String+import Lhc.Types++infixr 5  :+data [] a =  a : ([] a) | []++newtype IO a = IO (World__ -> (# World__, a #))++data World__ :: #++data Int+data Char = Char Char__++type Bool__ = Bits16_ -- Change to Bits1_ when the time comes+type Addr__ = BitsPtr_+type Int__  = Bits32_+type Char__ = Bits32_+type Enum__ = Bits16_+++-- | this is wrapped around arbitrary expressions and just evaluates them to whnf+foreign import primitive "seq" runRaw :: a -> World__ -> World__++-- | when no exception wrapper is wanted+runNoWrapper :: IO a -> World__ -> World__+runNoWrapper (IO run) w = case run w of (# w, _ #) -> w+++foreign import primitive "unsafeCoerce" unsafeCoerce__ :: a -> b++-- like 'const' but creates an artificial dependency on its second argument to guide optimization.+foreign import primitive dependingOn :: forall a b. a -> b -> a
+ lib/base/src/Lhc/Show.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS_LHC -N #-}+module Lhc.Show where++import Lhc.Int+import Lhc.Order+import Lhc.Basics++type  ShowS    = String -> String++class  Show a  where+    showsPrec        :: Int -> a -> ShowS+    show             :: a -> String+    showList         :: [a] -> ShowS++        -- Mimimal complete definition:+        --      show or showsPrec+    showsPrec _ x s   = show x ++ s++    show x            = showsPrec zero x ""++    showList []       = showString "[]"+    showList (x:xs)   = showChar '[' . shows x . showl xs+                        where showl []     = showChar ']'+                              showl (x:xs) = showChar ',' . shows x .+                                             showl xs++shows            :: (Show a) => a -> ShowS+shows            =  showsPrec zero++{-# INLINE showChar, showString #-}+showChar         :: Char -> ShowS+showChar         =  (:)++showString       :: String -> ShowS+showString       =  (++)++showParen        :: Bool -> ShowS -> ShowS+showParen b p    =  if b then showChar '(' . p . showChar ')' else p+++instance Show () where+    showsPrec _ () = showString "()"++instance (Show a, Show b) => Show (a,b)  where+    showsPrec _ (x,y) = showChar '(' . shows x . showChar ',' .+                                          shows y . showChar ')'++instance (Show a, Show b, Show c) => Show (a, b, c) where+    showsPrec _ (x,y,z) = showChar '(' . shows x . showChar ',' .+					    shows y . showChar ',' .+					    shows z . showChar ')'++instance Show a => Show [a]  where+    showsPrec p      = showList+++instance Show Bool where+    showsPrec d (False) = showString "False"+    showsPrec d (True) = showString "True"+++instance Show Ordering where+    showsPrec d (LT) = showString "LT"+    showsPrec d (EQ) = showString "EQ"+    showsPrec d (GT) = showString "GT"++
+ lib/base/src/Lhc/String.hs view
@@ -0,0 +1,103 @@+-- module for things dealing with string constants needed by the compiler internally+{-# OPTIONS_LHC -N -fffi -funboxed-values #-}+module Lhc.String(+    eqString,+    eqUnpackedString,+    unpackStringFoldr,+    eqSingleChar,+    unpackString+    )where+++import Lhc.Prim++-- TODO make it handle full UTF8++{-# VCONSTRUCTOR unpackString #-}+{-# NOINLINE unpackString #-}+unpackString :: Addr__ -> [Char]+unpackString addr = f addr where+    f addr = case constPeekByte addr of+        0# -> []+        c -> (Char c:f (increment addr))++{-+unpackFoldrString :: Addr__ -> (Char__ -> b -> b) -> b -> b+unpackFoldrString addr f e = unpack addr where+    unpack addr = case constPeekByte addr of+      '\NUL'# -> e+      ch  | ch `leChar__` '\x7F'# = ch `f` unpack (increment addr)+          | ch `leChar__` '\xDF'# = (((ch .&. '\x1f') `shiftL` 6#) .|. (constPeekByte (increment addr) .&. '\x3f')) `f` unpack (increment (increment addr))+           (chr# (((ord# ch                                  -# 0xC0#) `uncheckedIShiftL#`  6#) +#+                     (ord# (indexCharArray# addr (nh +# 1#)) -# 0x80#))) `f`+          unpack (nh +# 2#)+      | ch `leChar#` '\xEF'# =+           (chr# (((ord# ch                                  -# 0xE0#) `uncheckedIShiftL#` 12#) +#+                    ((ord# (indexCharArray# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#`  6#) +#+                     (ord# (indexCharArray# addr (nh +# 2#)) -# 0x80#))) `f`+          unpack (nh +# 3#)+      | otherwise            =+           (chr# (((ord# ch                                  -# 0xF0#) `uncheckedIShiftL#` 18#) +#+                    ((ord# (indexCharArray# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12#) +#+                    ((ord# (indexCharArray# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#`  6#) +#+                     (ord# (indexCharArray# addr (nh +# 3#)) -# 0x80#))) `f`+          unpack (nh +# 4#)+      where+	ch = indexCharArray# addr nh++-}++unpackStringFoldr :: Addr__ -> (Char -> b -> b) -> b -> b+unpackStringFoldr addr cons nil = f addr where+    f addr = case constPeekByte addr of+        0# -> nil+        c -> (Char c `cons` f (increment addr))++{-# NOINLINE eqUnpackedString #-}+eqUnpackedString :: Addr__ -> [Char] -> Bool__+eqUnpackedString addr cs = f addr cs where+    f :: Addr__ -> [Char] -> Bool__+    f offset [] = case constPeekByte offset of 0# -> 1#; _ -> 0#+    f offset (Char c:cs) = case constPeekByte offset of+        0# -> 0#+        uc -> case equalsChar uc c of+            0# -> 0#+            1# -> f (increment offset) cs++eqSingleChar :: Char__ -> [Char] -> Bool__+eqSingleChar ch (Char c:cs) = case equalsChar ch c of+    0# -> 0#+    1# -> case cs of+        [] -> 1#+        _ -> 0#+++{-# NOINLINE eqUnpacked #-}+eqUnpacked :: Addr__ -> [Char] -> Bool__+eqUnpacked addr cs = f addr cs where+    f :: Addr__ -> [Char] -> Bool__+    f offset [] = case constPeekByte offset of 0# -> 1#; _ -> 0#+    f offset (Char c:cs) = case constPeekByte offset of+        0# -> 0#+        uc -> case equalsChar uc c of+            0# -> 0#+            1# -> f (increment offset) cs++-- returns it in an Char__ even though it is just a byte+foreign import primitive constPeekByte :: Addr__ -> Char__+++eqString :: [Char] -> [Char] -> Bool__+eqString [] [] = 1#+eqString (Char x:xs) (Char y:ys) = case equalsChar x y of+    0# -> 0#+    1# -> eqString xs ys+eqString _ _ = 0#++foreign import primitive increment :: Addr__ -> Addr__+foreign import primitive "Eq" equalsChar :: Char__ -> Char__ -> Bool__+++++
+ lib/base/src/Lhc/Text/Read.hs view
@@ -0,0 +1,122 @@+{-# OPTIONS_LHC -N #-}+module Lhc.Text.Read where++import Lhc.Basics+import Lhc.Order+import Lhc.Int+import Lhc.List+import Prelude.CType++type  ReadS a  = String -> [(a,String)]++class  Read a  where+    readsPrec        :: Int -> ReadS a+    readList         :: ReadS [a]++        -- Minimal complete definition:+        --      readsPrec+    readList         = readParen False (\r -> [pr | ("[",s)  <- lex r,+                                                    pr       <- readl s])+                       where readl  s = [([],t)   | ("]",t)  <- lex s] +++                                        [(x:xs,u) | (x,t)    <- reads s,+                                                    (xs,u)   <- readl' t]+                             readl' s = [([],t)   | ("]",t)  <- lex s] +++                                        [(x:xs,v) | (",",t)  <- lex s,+                                                    (x,u)    <- reads t,+                                                    (xs,v)   <- readl' u]++reads            :: (Read a) => ReadS a+reads            =  readsPrec zero++readParen        :: Bool -> ReadS a -> ReadS a+readParen b g    =  if b then mandatory else optional+                    where optional r  = g r ++ mandatory r+                          mandatory r = [(x,u) | ("(",s) <- lex r,+                                                 (x,t)   <- optional s,+                                                 (")",u) <- lex t    ]+++-- This lexer is not completely faithful to the Haskell lexical syntax.+-- Current limitations:+--    Qualified names are not handled properly+--    Octal and hexidecimal numerics are not recognized as a single token+--    Comments are not treated properly++lex              :: ReadS String+lex ""           =  [("","")]+lex (c:s)+   | isSpace c   =  lex (dropWhile isSpace s)+lex ('\'':s)     =  [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,+                                         ch /= "'" ]+lex ('"':s)      =  [('"':str, t)      | (str,t) <- lexString s]+                    where+                    lexString ('"':s) = [("\"",s)]+                    lexString s = [(ch++str, u)+                                         | (ch,t)  <- lexStrItem s,+                                           (str,u) <- lexString t  ]++                    lexStrItem ('\\':('&':s)) =  [("\\&",s)]+                    lexStrItem ('\\':(c:s)) | isSpace c+                                           =  [("\\&",t) |+                                               '\\':t <-+                                                   [dropWhile isSpace s]]+                    lexStrItem s           =  lexLitChar s++lex (c:s) | isSingle c = [([c],s)]+          | isSym c    = [(c:sym,t)       | (sym,t) <- [span isSym s]]+          | isAlpha c  = [(c:nam,t)       | (nam,t) <- [span isIdChar s]]+          | isDigit c  = [(c:(ds++fe),t)  | (ds,s')  <- [span isDigit s],+                                            (fe,t)  <- lexFracExp s'     ]+          | otherwise  = []    -- bad character+             where+              isSingle c =  c `elem` ",;()[]{}_`"+              isSym c    =  c `elem` "!@#$%&*+./<=>?\\^|:-~"+              isIdChar c =  isAlphaNum c || c `elem` "_'"++              lexFracExp ('.':(c:cs)) | isDigit c+                            = [('.':ds++e,u) | (ds,t) <- lexDigits (c:cs),+                                               (e,u)  <- lexExp t]+              lexFracExp s  = lexExp s++              lexExp (e:s) | e `elem` "eE"+                       = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",+                                                 (ds,u) <- lexDigits t] +++                         [(e:ds,t)   | (ds,t) <- lexDigits s]+              lexExp s = [("",s)]++asciiTab :: [String]+asciiTab = --listArray ('\NUL', ' ')+           ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",+            "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",+            "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",+            "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",+            "SP"]++lexLitChar          :: ReadS String+lexLitChar ('\\':s) =  map (prefix '\\') (lexEsc s)+        where+          lexEsc :: String -> [(String,String)]+          lexEsc (c:s)     | c `elem` "abfnrtv\\\"'"  = [([c],s)]+          lexEsc ('^':(c:s)) | (c >= '@') && (c <= '_') = [(['^',c],s)]++          -- Numeric escapes+          lexEsc ('o':s)               = [prefix 'o' (span isOctDigit s)]+          lexEsc ('x':s)               = [prefix 'x' (span isHexDigit s)]+          lexEsc s@(d:_)   | isDigit d = [span isDigit s]++          -- Very crude approximation to \XYZ.+          lexEsc s@(c:_)   | isUpper c = [span isCharName s]+          lexEsc _                     = []++          isCharName c   = isUpper c || isDigit c+          prefix c (t,s) = (c:t, s)++lexLitChar (c:s)    =  [([c],s)]+lexLitChar ""       =  []++lexDigits        :: ReadS String+lexDigits        =  nonnull isDigit++nonnull          :: (Char -> Bool) -> ReadS String+nonnull p s      =  [(cs,t) | (cs@(_:_),t) <- [span p s]]+
+ lib/base/src/Lhc/Tuples.hs view
@@ -0,0 +1,115 @@+{-# OPTIONS_LHC -N #-}++-- | A place to collect the tuple instances.++module Lhc.Tuples where++import Lhc.Basics+import Lhc.Show+import Lhc.Order+import Lhc.List+import Lhc.Text.Read+++{- TUPGEN!++instance (#Tup Eq #t) => Eq (#Tup #t) where+    (#Tup #x) == (#Tup #y) = and [#List #x == #y]+    (#Tup #x) /= (#Tup #y) = or [#List #x /= #y]++-}++++instance (Ord a, Ord b) => Ord (a,b) where+    compare (x,y) (a,b) = case compare x a of+        EQ -> compare y b+        z -> z++--instance (Eq a, Eq b) => Eq (a,b) where+--    (x,y) == (a,b) = x == a && y == b+++++instance  (Read a, Read b) => Read (a,b)  where+    readsPrec p       = readParen False+                            (\r -> [((x,y), w) | ("(",s) <- lex r,+                                                 (x,t)   <- reads s,+                                                 (",",u) <- lex t,+                                                 (y,v)   <- reads u,+                                                 (")",w) <- lex v ] )++instance  (Read a, Read b, Read c) => Read (a,b,c)  where+    readsPrec p       = readParen False+                            (\r -> [((x,y,z), w) | ("(",s) <- lex r,+                                                 (x,t)   <- reads s,+                                                 (",",u) <- lex t,+                                                 (y,v)   <- reads u,+                                                 (",",w) <- lex v,+                                                 (z,p)   <- reads w,+                                                 (")",w) <- lex p ] )++++instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where+    showsPrec _ (w,x,y,z) s = (showChar '(' . shows w . showChar ',' .+                                              shows x . showChar ',' .+                                              shows y . showChar ',' .+                                              shows z . showChar ')')+                              s++instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where+    showsPrec _ (v,w,x,y,z) s = (showChar '(' . shows v . showChar ',' .+                                                shows w . showChar ',' .+                                                shows x . showChar ',' .+                                                shows y . showChar ',' .+                                                shows z . showChar ')')+                                    s++instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show (a, b, c, d, e, f) where+    showsPrec _ (v,w,x,y,z,a) s = (showChar '(' . shows v . showChar ',' .+                                                  shows w . showChar ',' .+                                                  shows x . showChar ',' .+                                                  shows y . showChar ',' .+                                                  shows z . showChar ',' .+                                                  shows a . showChar ')')+                                    s+++-- tupgen 2++instance (Eq t1,Eq t2) => Eq (t1,t2) where+    (x1,x2) == (y1,y2) = and [x1 == y1,x2 == y2]+    (x1,x2) /= (y1,y2) = or [x1 /= y1,x2 /= y2]++-- tupgen 3++instance (Eq t1,Eq t2,Eq t3) => Eq (t1,t2,t3) where+    (x1,x2,x3) == (y1,y2,y3) = and [x1 == y1,x2 == y2,x3 == y3]+    (x1,x2,x3) /= (y1,y2,y3) = or [x1 /= y1,x2 /= y2,x3 /= y3]++-- tupgen 4++instance (Eq t1,Eq t2,Eq t3,Eq t4) => Eq (t1,t2,t3,t4) where+    (x1,x2,x3,x4) == (y1,y2,y3,y4) = and [x1 == y1,x2 == y2,x3 == y3,x4 == y4]+    (x1,x2,x3,x4) /= (y1,y2,y3,y4) = or [x1 /= y1,x2 /= y2,x3 /= y3,x4 /= y4]++-- tupgen 5++instance (Eq t1,Eq t2,Eq t3,Eq t4,Eq t5) => Eq (t1,t2,t3,t4,t5) where+    (x1,x2,x3,x4,x5) == (y1,y2,y3,y4,y5) = and [x1 == y1,x2 == y2,x3 == y3,x4 == y4,x5 == y5]+    (x1,x2,x3,x4,x5) /= (y1,y2,y3,y4,y5) = or [x1 /= y1,x2 /= y2,x3 /= y3,x4 /= y4,x5 /= y5]++-- tupgen 6++instance (Eq t1,Eq t2,Eq t3,Eq t4,Eq t5,Eq t6) => Eq (t1,t2,t3,t4,t5,t6) where+    (x1,x2,x3,x4,x5,x6) == (y1,y2,y3,y4,y5,y6) = and [x1 == y1,x2 == y2,x3 == y3,x4 == y4,x5 == y5,x6 == y6]+    (x1,x2,x3,x4,x5,x6) /= (y1,y2,y3,y4,y5,y6) = or [x1 /= y1,x2 /= y2,x3 /= y3,x4 /= y4,x5 /= y5,x6 /= y6]++-- tupgen 7++instance (Eq t1,Eq t2,Eq t3,Eq t4,Eq t5,Eq t6,Eq t7) => Eq (t1,t2,t3,t4,t5,t6,t7) where+    (x1,x2,x3,x4,x5,x6,x7) == (y1,y2,y3,y4,y5,y6,y7) = and [x1 == y1,x2 == y2,x3 == y3,x4 == y4,x5 == y5,x6 == y6,x7 == y7]+    (x1,x2,x3,x4,x5,x6,x7) /= (y1,y2,y3,y4,y5,y6,y7) = or [x1 /= y1,x2 /= y2,x3 /= y3,x4 /= y4,x5 /= y5,x6 /= y6,x7 /= y7]+
+ lib/base/src/Lhc/Types.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS_LHC -N  #-}+module Lhc.Types where++data Bits1_ :: #++data Bits8_   :: #+data Bits16_  :: #+data Bits32_  :: #+data Bits64_  :: #+data Bits128_ :: #+data BitsPtr_ :: #+data BitsMax_ :: #++data Float32_ :: #+data Float64_ :: #+data Float80_ :: #+data Float128_ :: #
+ lib/base/src/Numeric.hs view
@@ -0,0 +1,360 @@+module Numeric(fromRat,+               showSigned, showIntAtBase,+               showInt, showOct, showHex,+               readSigned, readInt,+               readDec, readOct, readHex,+               floatToDigits,+               showEFloat, showFFloat, showGFloat, showFloat,+               readFloat, lexDigits) where++import Data.Word+import Prelude.CType   ( isDigit, isOctDigit, isHexDigit+                   , digitToInt, intToDigit )+import Data.Ratio  ( (%), numerator, denominator )+--import Array  ( (!), Array, array )+import Prelude.Text+import Lhc.Text.Read++-- This converts a rational to a floating.  This should be used in the+-- Fractional instances of Float and Double.++fromRat :: (RealFloat a) => Rational -> a+fromRat = error "fromRat not implemented yet"++{-+fromRat :: (RealFloat a) => Rational -> a+fromRat x =+    if x == 0 then encodeFloat 0 0              -- Handle exceptional cases+    else if x < 0 then - fromRat' (-x)          -- first.+    else fromRat' x++-- Conversion process:+-- Scale the rational number by the RealFloat base until+-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).+-- Then round the rational to an Integer and encode it with the exponent+-- that we got from the scaling.+-- To speed up the scaling process we compute the log2 of the number to get+-- a first guess of the exponent.+fromRat' :: (RealFloat a) => Rational ->  a+fromRat' x = fromRat'' x undefined++fromRat'' :: (RealFloat a) => Rational -> a -> a+fromRat'' x _x = r+  where b = floatRadix r+        p = floatDigits r+        (minExp0, _) = floatRange r+        minExp = minExp0 - p            -- the real minimum exponent+        xMin = toRational (expt b (p-1))+        xMax = toRational (expt b p)+        p0 = (integerLogBase b (numerator x) -+              integerLogBase b (denominator x) - p) `max` minExp+        f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1+        (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)+        r = encodeFloat (round x') p' `asTypeOf` _x++-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.+scaleRat :: Rational -> Int -> Rational -> Rational ->+             Int -> Rational -> (Rational, Int)+scaleRat b minExp xMin xMax p x =+    if p <= minExp then+        (x, p)+    else if x >= xMax then+        scaleRat b minExp xMin xMax (p+1) (x/b)+    else if x < xMin  then+        scaleRat b minExp xMin xMax (p-1) (x*b)+    else+        (x, p)+        -}+-- Exponentiation with a cache for the most common numbers.+minExpt = 0::Int+maxExpt = 1100::Int+expt :: Integer -> Int -> Integer+expt base n = base^n+{-+expt base n =+    if base == 2 && n >= minExpt && n <= maxExpt then+        expts!n+    else+        base^n++expts :: Array Int Integer+expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]+-}++-- Compute the (floor of the) log of i in base b.+-- Simplest way would be just divide i by b until it's smaller then b,+-- but that would be very slow!  We are just slightly more clever.+integerLogBase :: Integer -> Integer -> Int+integerLogBase b i =+     if i < b then+        0+     else+        -- Try squaring the base first to cut down the number of divisions.+        let l = 2 * integerLogBase (b*b) i+            doDiv :: Integer -> Int -> Int+            doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)+        in  doDiv (i `div` (b^l)) l+++-- Misc utilities to show integers and floats+{-# SPECIALIZE showSigned :: (Int -> ShowS) -> Int -> Int -> ShowS #-}+{-# SPECIALIZE showSigned :: (Integer -> ShowS) -> Int -> Integer -> ShowS #-}++showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS+showSigned showPos p x+  | x < 0     = showParen (p > 6) (showChar '-' . showPos (negate x))+  | otherwise = showPos x++{-# INLINE showInt #-}++-- showInt, showOct, showHex are used for positive numbers only+showInt, showOct, showHex :: Integral a => a -> ShowS+showOct = showIntAtBase  8 intToDigit+showInt = showIntAtBase 10 intToDigit+showHex = showIntAtBase 16 intToDigit++{-# SPECIALIZE showIntAtBase :: Word -> (Int -> Char) -> Word -> ShowS #-}+{-# SPECIALIZE showIntAtBase :: WordMax -> (Int -> Char) -> WordMax -> ShowS #-}+++showIntAtBase :: Integral a+	      => a              -- base+	      -> (Int -> Char)  -- digit to char+	      -> a              -- number to show+	      -> ShowS+showIntAtBase base intToDig n rest+  | n < 0     = error $ "Numeric.showIntAtBase: can't show negative numbers " ++ show n+  | n' == 0   = rest'+  | otherwise = showIntAtBase base intToDig n' rest'+  where+    (n',d) = quotRem n base+    rest'  = intToDig (fromIntegral d) : rest+++readSigned :: (Real a) => ReadS a -> ReadS a+readSigned readPos = readParen False read'+                     where read' r  = read'' r +++                                      [(-x,t) | ("-",s) <- lex r,+                                                (x,t)   <- read'' s]+                           read'' r = [(n,s)  | (str,s) <- lex r,+                                                (n,"")  <- readPos str]+++-- readInt reads a string of digits using an arbitrary base.+-- Leading minus signs must be handled elsewhere.++{-# SPECIALIZE readInt :: Int -> (Char -> Bool) -> (Char -> Int) -> ReadS Int #-}+{-# SPECIALIZE readInt :: Integer -> (Char -> Bool) -> (Char -> Int) -> ReadS Integer #-}++readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a+readInt radix isDig digToInt s =+   [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)+          | (ds,r) <- nonnull isDig s ]++-- Unsigned readers for various bases+readDec, readOct, readHex :: (Integral a) => ReadS a+readDec = readInt 10 isDigit    digitToInt+readOct = readInt  8 isOctDigit digitToInt+readHex = readInt 16 isHexDigit digitToInt+++showEFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS+showFFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS+showGFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS+showFloat      :: (RealFloat a) => a -> ShowS++showEFloat d x =  showString (formatRealFloat FFExponent d x)+showFFloat d x =  showString (formatRealFloat FFFixed d x)+showGFloat d x =  showString (formatRealFloat FFGeneric d x)+showFloat      =  showGFloat Nothing++-- These are the format types.  This type is not exported.++data FFFormat = FFExponent | FFFixed | FFGeneric++formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String+formatRealFloat fmt decs x+  = s+  where+    base = 10+    s = if isNaN x then+            "NaN"+        else if isInfinite x then+            if x < 0 then "-Infinity" else "Infinity"+        else if x < 0 || isNegativeZero x then+            '-' : doFmt fmt (floatToDigits (toInteger base) (-x))+        else+            doFmt fmt (floatToDigits (toInteger base) x)++    doFmt fmt (is, e)+      = let+           ds = map intToDigit is+        in+        case fmt of+          FFGeneric ->+              doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)+                    (is, e)+          FFExponent ->+            case decs of+              Nothing ->+                case ds of+                   []    -> "0.0e0"+                   [d]   -> d : ".0e" ++ show (e-1)+                   d:ds  -> d : '.' : ds ++ 'e':show (e-1)++              Just dec ->+                let dec' = max dec 1 in+                case is of+                  [] -> '0':'.':take dec' (repeat '0') ++ "e0"+                  _ ->+                    let (ei, is') = roundTo base (dec'+1) is+                        d:ds = map intToDigit+                                   (if ei > 0 then init is' else is')+                    in d:'.':ds  ++ "e" ++ show (e-1+ei)++          FFFixed ->+            case decs of+               Nothing 	-- Always prints a decimal point+                 | e > 0     -> take e (ds ++ repeat '0')+                                ++ '.' : mk0 (drop e ds)+                 | otherwise -> "0." ++ mk0 (replicate (-e) '0' ++ ds)++               Just dec ->  -- Print decimal point iff dec > 0+                 let dec' = max dec 0 in+                 if e >= 0 then+                   let (ei, is') = roundTo base (dec' + e) is+                       (ls, rs)  = splitAt (e+ei)+                                              (map intToDigit is')+                   in  mk0 ls ++ mkdot0 rs+                 else+                   let (ei, is') = roundTo base dec'+                                           (replicate (-e) 0 ++ is)+                       d : ds = map intToDigit+                                    (if ei > 0 then is' else 0:is')+                   in  d : mkdot0 ds+            where+              mk0 "" = "0"        -- Print 0.34, not .34+              mk0 s  = s++              mkdot0 "" = ""       -- Print 34, not 34.+              mkdot0 s  = '.' : s  -- when the format specifies no+			           -- digits after the decimal point+++roundTo :: Int -> Int -> [Int] -> (Int, [Int])+roundTo base d is | base `seq` d `seq` True = case f d is of+                (0, is) -> (0, is)+                (1, is) -> (1, 1 : is)+  where b2 = base `div` 2+        f n [] = (0, replicate n 0)+        f 0 (i:_) = (if i >= b2 then 1 else 0, [])+        f d (i:is) =+            let (c, ds) = f (d-1) is+                i' = c + i+            in  if i' == base then (1, 0:ds) else (0, i':ds)++--+-- Based on "Printing Floating-Point Numbers Quickly and Accurately"+-- by R.G. Burger and R. K. Dybvig, in PLDI 96.+-- The version here uses a much slower logarithm estimator.+-- It should be improved.++-- This function returns a non-empty list of digits (Ints in [0..base-1])+-- and an exponent.  In general, if+--      floatToDigits r = ([a, b, ... z], e)+-- then+--      r = 0.ab..z * base^e+--++floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)++floatToDigits _ 0 = ([], 0)+floatToDigits base x =+    let (f0, e0) = decodeFloat x+        (minExp0, _) = floatRange x+        p = floatDigits x+        b = floatRadix x+        minExp = minExp0 - p            -- the real minimum exponent++        -- Haskell requires that f be adjusted so denormalized numbers+        -- will have an impossibly low exponent.  Adjust for this.+        f :: Integer+        e :: Int+        (f, e) = let n = minExp - e0+                 in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)++        (r, s, mUp, mDn) =+           if e >= 0 then+               let be = b^e in+               if f == b^(p-1) then+                   (f*be*b*2, 2*b, be*b, b)+               else+                   (f*be*2, 2, be, be)+           else+               if e > minExp && f == b^(p-1) then+                   (f*b*2, b^(-e+1)*2, b, 1)+               else+                   (f*2, b^(-e)*2, 1, 1)+        k =+            let k0 =+                    if b==2 && base==10 then+                        -- logBase 10 2 is slightly bigger than 3/10 so+                        -- the following will err on the low side.  Ignoring+                        -- the fraction will make it err even more.+                        -- Haskell promises that p-1 <= logBase b f < p.+                        (p - 1 + e0) * 3 `div` 10+                    else+                        ceiling ((log ((fromInteger (f+1))::Double) ++                                 fromIntegral e * log (fromInteger b)) /+                                  log (fromInteger base))+                fixup n =+                    if n >= 0 then+                        if r + mUp <= expt base n * s then n else fixup (n+1)+                    else+                        if expt base (-n) * (r + mUp) <= s then n+                                                           else fixup (n+1)+            in  fixup (k0::Int)++        gen ds rn sN mUpN mDnN =+            let (dn, rn') = (rn * base) `divMod` sN+                mUpN' = mUpN * base+                mDnN' = mDnN * base+            in  case (rn' < mDnN', rn' + mUpN' > sN) of+                (True,  False) -> dn : ds+                (False, True)  -> dn+1 : ds+                (True,  True)  -> if rn' * 2 < sN then dn : ds else dn+1 : ds+                (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'+        rds =+            if k >= 0 then+                gen [] r (s * expt base k) mUp mDn+            else+                let bk = expt base (-k)+                in  gen [] (r * bk) s (mUp * bk) (mDn * bk)+    in  (map fromIntegral (reverse rds), k)++++-- This floating point reader uses a less restrictive syntax for floating+-- point than the Haskell lexer.  The `.' is optional.++readFloat     :: (RealFrac a) => ReadS a+readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,+                                                       (k,t)   <- readExp s] +++                 [ (0/0, t) | ("NaN",t)      <- lex r] +++                 [ (1/0, t) | ("Infinity",t) <- lex r]+               where+                 readFix r = [(read (ds++ds'), length ds', t)+                             | (ds,d) <- lexDigits r,+                               (ds',t) <- lexFrac d ]++                 lexFrac ('.':ds) = lexDigits ds+                 lexFrac s        = [("",s)]++                 readExp (e:s) | e `elem` "eE" = readExp' s+                 readExp s                     = [(0,s)]++                 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]+                 readExp' ('+':s) = readDec s+                 readExp' s       = readDec s++
+ lib/base/src/Prelude.hs view
@@ -0,0 +1,416 @@+{-# OPTIONS_LHC -funboxed-tuples #-}+module Prelude(+    -- export everything here+    module Prelude,+    -- export types from elsewhere+    IO(),+    IOError(),+    Rational(),+    -- functions from elsewhere+    putStr,+    putStrLn,+    error,+    concatMap,+    concat,+    any,+    all,+    subtract,+    even,+    odd,+    foldr,+    and,+    filter,+    or,+    length,+    null,+    head,+    tail,+    last,+    init,+    takeWhile,+    dropWhile,+    span,+    break,+    (!!),+    Maybe(Just,Nothing),+    maybe,+    sequence,+    sequence_,+    -- submodules+    module Lhc.Basics,+    module Lhc.Float,+    module Lhc.Enum,+    module Lhc.Order,+    module Lhc.Show,+    Num(..),+    fromIntegral,+    elem,notElem,+    realToFrac,+    Real(..),+    Integral(..),+    Fractional(..),+    Floating(..),+    RealFrac(properFraction,truncate,round,ceiling,floor),+    RealFloat(..),+    module Lhc.Monad,+    Int(),++    module Prelude.IO,+    module Prelude.Text+    ) where+++import Lhc.Basics+import Lhc.Float+import Data.Int(Int())++import Lhc.Inst.Enum+import Lhc.Inst.Read+import Lhc.Inst.Show+import Lhc.Inst.Storable++import Data.Ratio+import Lhc.Enum+import Lhc.IO+import Lhc.List+import Lhc.Monad+import Lhc.Num+import Lhc.Order+import Lhc.Show+import Lhc.Maybe+import Lhc.Tuples+import Prelude.Float+import Prelude.IO+import Prelude.IOError+import Prelude.Text+import qualified Data.Char as Char(isSpace,ord,chr)++++-- infixr 9  .+--infixr 8  ^, ^^, **+infixr 8  ^, ^^+--infixl 7  *  , /, `quot`, `rem`, `div`, `mod`+--infixl 6  +, -+--infixr 5  :+--infix  4  ==, /=, <, <=, >=, >+--infixr 3  &&+--infixr 2  ||+--infixl 1  >>, >>=+--infixr 1  =<<+-- infixr 0  $, $!, `seq`++++-- Numeric functions+++++{-# SPECIALIZE gcd :: Int -> Int -> Int #-}+{-# SPECIALIZE gcd :: Integer -> Integer -> Integer #-}+gcd              :: (Integral a) => a -> a -> a+gcd 0 0          =  error "Prelude.gcd: gcd 0 0 is undefined"+gcd x y          =  gcd' (abs x) (abs y)+                    where gcd' x 0  =  x+                          gcd' x y  =  gcd' y (x `rem` y)+++{-# SPECIALIZE lcm :: Int -> Int -> Int #-}+{-# SPECIALIZE lcm :: Integer -> Integer -> Integer #-}+lcm              :: (Integral a) => a -> a -> a+lcm _ 0          =  0+lcm 0 _          =  0+lcm x y          =  abs ((x `quot` (gcd x y)) * y)+++{-# SPECIALIZE (^) :: Int -> Int -> Int #-}+{-# SPECIALIZE (^) :: Integer -> Int -> Integer #-}+{-# SPECIALIZE (^) :: Double -> Int -> Double #-}++(^)              :: (Num a, Integral b) => a -> b -> a+x ^ 0            =  1+x ^ n | n > 0    =  f x (n-1) x+                    where f _ 0 y = y+                          f x n y = g x n  where+                                    g x n | even n  = g (x*x) (n `quot` 2)+                                          | otherwise = f x (n-1) (x*y)+_ ^ _            = error "Prelude.^: negative exponent"+++(^^)             :: (Fractional a, Integral b) => a -> b -> a+x ^^ n           =  if n >= 0 then x^n else recip (x^(-n))++++++++++data Either a b = Left a | Right b+    deriving (Eq, Ord, Read, Show)++either :: (a -> c) -> (b -> c) -> Either a b -> c+either f g (Left x)  =  f x+either f g (Right y) =  g y++++until            :: (a -> Bool) -> (a -> a) -> a -> a+until p f x+     | p x       =  x+     | otherwise =  until p f (f x)++++++++-- foldl, applied to a binary operator, a starting value (typically the+-- left-identity of the operator), and a list, reduces the list using+-- the binary operator, from left to right:+--  foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn+-- foldl1 is a variant that has no starting value argument, and  thus must+-- be applied to non-empty lists.  scanl is similar to foldl, but returns+-- a list of successive reduced values from the left:+--      scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]+-- Note that  last (scanl f z xs) == foldl f z xs.+-- scanl1 is similar, again without the starting element:+--      scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]+++++foldl1           :: (a -> a -> a) -> [a] -> a+foldl1 f (x:xs)  =  foldl f x xs+foldl1 _ []      =  error "Prelude.foldl1: empty list"++++scanl1           :: (a -> a -> a) -> [a] -> [a]+scanl1 f (x:xs)  =  scanl f x xs+scanl1 _ []      =  []++-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the+-- above functions.+++--foldr :: (a -> b -> b) -> b -> [a] -> b+--foldr k z [] = z+--foldr k z (x:xs) = k x (foldr k z xs)+++foldr1           :: (a -> a -> a) -> [a] -> a+foldr1 f [x]     =  x+foldr1 f (x:xs)  =  f x (foldr1 f xs)+foldr1 _ []      =  error "Prelude.foldr1: empty list"+++scanr             :: (a -> b -> b) -> b -> [a] -> [b]+scanr f q0 []     =  [q0]+scanr f q0 (x:xs) =  f x q : qs where qs@(q:_) = scanr f q0 xs+++scanr1          :: (a -> a -> a) -> [a] -> [a]+scanr1 f []     =  []+scanr1 f [x]    =  [x]+scanr1 f (x:xs) =  f x q : qs where qs@(q:_) = scanr1 f xs+++-- replicate n x is a list of length n with x the value of every element++replicate        :: Int -> a -> [a]+replicate n x    = f n where+    f n | n <= 0 = []+    f n = let n' = n - 1 in n' `seq` (x:f n')++-- cycle ties a finite list into a circular one, or equivalently,+-- the infinite repetition of the original list.  It is the identity+-- on infinite lists.+++cycle            :: [a] -> [a]+cycle []         =  error "Prelude.cycle: empty list"+cycle xs         =  xs' where xs' = xs ++ xs'++-- take n, applied to a list xs, returns the prefix of xs of length n,+-- or xs itself if n > length xs.  drop n xs returns the suffix of xs+-- after the first n elements, or [] if n > length xs.  splitAt n xs+-- is equivalent to (take n xs, drop n xs).+++take :: Int -> [a] -> [a]+take n xs = f n xs where+    f n _      | n <= 0 =  []+    f _ []              =  []+    f n (x:xs)          =  x : f (n-1) xs+++drop :: Int -> [a] -> [a]+drop n xs = f n xs where+    f n xs | n <= 0 =  xs+    f _ [] = []+    f n (_:xs) = f (n-1) xs++++splitAt                  :: Int -> [a] -> ([a],[a])+--splitAt n xs             =  (take n xs, drop n xs)+splitAt n ls | n < 0	= ([], ls)+splitAt n ls = splitAt' n ls where+    splitAt' :: Int -> [a] -> ([a], [a])+    splitAt' 0  xs  = ([], xs)+    splitAt' _  []  = ([], [])+    splitAt' m (x:xs) = case splitAt' (m - 1) xs of+        (xs', xs'') -> (x:xs', xs'')++-- lines breaks a string up into a list of strings at newline characters.+-- The resulting strings do not contain newlines.  Similary, words+-- breaks a string up into a list of words, which were delimited by+-- white space.  unlines and unwords are the inverse operations.+-- unlines joins lines with terminating newlines, and unwords joins+-- words with separating spaces.+++lines            :: String -> [String]+lines ""         =  []+lines s          =  let (l, s') = break (== '\n') s+                      in  l : case s' of+                                []      -> []+                                (_:s'') -> lines s''+++words            :: String -> [String]+words s          =  case dropWhile Char.isSpace s of+                      "" -> []+                      s' -> w : words s''+                            where (w, s'') = break Char.isSpace s'+++unlines          :: [String] -> String+unlines [] = []+unlines (l:ls) = l ++ '\n' : unlines ls+--unlines          =  concatMap (++ "\n")+++unwords          :: [String] -> String+unwords []		=  ""+unwords [w]		= w+unwords (w:ws)		= w ++ ' ' : unwords ws+++-- lookup key assocs looks up a key in an association list.++{- SPECIALIZE lookup :: forall b . Char -> (Char,b) -> Maybe b #-}+{- SPECIALIZE lookup :: forall b . Int -> (Int,b) -> Maybe b #-}++lookup           :: (Eq a) => a -> [(a,b)] -> Maybe b+lookup key []    =  Nothing+lookup key ((x,y):xys)+    | key == x   =  Just y+    | otherwise  =  f x y xys where+        f x y _ | key == x = Just y+        f _ _ ((x,y):xys)  = f x y xys+        f _ _ []           = Nothing++-- sum and product compute the sum or product of a finite list of numbers.++sum, product     :: (Num a) => [a] -> a+--sum              =  foldl (+) 0+--product          =  foldl (*) 1+sum l	= sum' l 0 where+    sum' []     a = a+    sum' (x:xs) a = sum' xs (a+x)+product	l = prod l 1 where+    prod []     a = a+    prod (x:xs) a = prod xs (a*x)++-- maximum and minimum return the maximum or minimum value from a list,+-- which must be non-empty, finite, and of an ordered type.++maximum, minimum :: (Ord a) => [a] -> a+maximum []       =  error "Prelude.maximum: empty list"+maximum xs       =  foldl1 max xs++minimum []       =  error "Prelude.minimum: empty list"+minimum xs       =  foldl1 min xs+++zip3             :: [a] -> [b] -> [c] -> [(a,b,c)]+zip3             =  zipWith3 (\a b c -> (a,b,c))++++zipWith3         :: (a->b->c->d) -> [a]->[b]->[c]->[d]+zipWith3 z (a:as) (b:bs) (c:cs)+                 =  z a b c : zipWith3 z as bs cs+zipWith3 _ _ _ _ =  []+++-- unzip transforms a list of pairs into a pair of lists.+++unzip            :: [(a,b)] -> ([a],[b])+unzip            =  foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])+++unzip3           :: [(a,b,c)] -> ([a],[b],[c])+unzip3           =  foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))+                          ([],[],[])+++instance Real Integer where+    toRational = fromInteger+instance Real Int where+    toRational = fromInt++++{-# RULES "drop/0"        forall . drop 0 = \xs -> xs #-}+{-# RULES "drop/1"        forall x xs . drop 1 (x:xs) = xs #-}+{-# RULES "drop/2"        forall x y xs . drop 2 (x:y:xs) = xs #-}+{-# RULES "drop/3"        forall x y z xs . drop 3 (x:y:z:xs) = xs #-}+{-# RULES "take/0"        forall xs . take 0 xs = [] #-}+{-# RULES "take/1"        forall x xs . take 1 (x:xs) = [x] #-}+{-# RULES "take/2"        forall x y xs . take 2 (x:y:xs) = [x,y] #-}+{-# RULES "take/3"        forall x y z xs . take 3 (x:y:z:xs) = [x,y,z] #-}+{-# RULES "!!/0"          forall x xs . (x:xs) !! 0 = x #-}+{-# RULES "!!/1"          forall x y xs . (x:y:xs) !! 1 = y #-}+{-# RULES "!!/2"          forall x y z xs . (x:y:z:xs) !! 2 = z #-}+{-# RULES "concat/Map"    forall f xs . concat (map f xs) = concatMap f xs #-}+{-# RULES "sequence/map"  forall f xs . sequence (map f xs) = mapM f xs #-}+{-# RULES "sequence_/map" forall f xs . sequence_ (map f xs) = mapM_ f xs #-}+{-# RULES "++/emptyr"     forall xs . xs ++ [] = xs #-}+{-# RULES "++/refix"      forall xs ys zs . (xs ++ ys) ++ zs = xs ++ (ys ++ zs) #-}+--{-# RULES "++/tick4"      forall x y z x' xs ys . (x:y:z:x':xs) ++ ys = x:y:z:x':(xs ++ ys) #-}+--{-# RULES "++/tick2"      forall x y xs ys . (x:y:xs) ++ ys = x:y:(xs ++ ys) #-}+--{-# RULES "++/tick1"      forall x xs ys . (x:xs) ++ ys = x:(xs ++ ys) #-}+{-# RULES "++/tick0"      forall xs . [] ++ xs = xs #-}+{-# RULES "++/tick1"      forall x xs . [x] ++ xs = x:xs #-}+{-# RULES "++/tick2"      forall x y xs . [x,y] ++ xs = x:y:xs #-}+{-# RULES "++/tick3"      forall x y z xs . [x,y,z] ++ xs = x:y:z:xs #-}+{-# RULES "map/map"       forall f g xs . map f (map g xs) = map (\x -> f (g x)) xs #-}+{-# RULES "concatMap/map" forall f g xs . concatMap f (map g xs) = concatMap (\x -> f (g x)) xs #-}+{---# RULES "concat/tick"   forall x xs . concat (x:xs) = x ++ concat xs #-}+{-# RULES "concat/[]"     concat [] = [] #-}+{-# RULES "map/[]"        forall f . map f [] = [] #-}+{-# RULES "concatMap/[]"  forall f . concatMap f [] = [] #-}+{-# RULES "concatMap/++"  forall xs ys f . concatMap f (xs ++ ys) = concatMap f xs ++ concatMap f ys #-}+{-# RULES "map/++"        forall xs ys f . map f (xs ++ ys) = map f xs ++ map f ys #-}++{-# RULES "foldr/map" forall k z f xs . foldr k z (map f xs) = foldr (\x y -> k (f x) y) z xs #-}+{-# RULES "foldr/concatMap" forall k z f xs . foldr k z (concatMap f xs) = foldr (\x y -> foldr k (f x) y) z xs #-}+{-# RULES "foldr/filter" forall k z f xs . foldr k z (filter f xs) = foldr (\x y -> if f x then k x y else y) z xs #-}+{-# RULES "foldr/++" forall k z xs ys . foldr k z (xs ++ ys) = foldr k (foldr k z ys) xs #-}+{-# RULES "foldr/concat" forall k z xs . foldr k z (concat xs) = foldr (\x y -> foldr k y x) z xs #-}+{-# RULES "foldr/repeat" forall k _z x . foldr k _z (repeat x) = let r = k x r in r #-}+-- causes horrible code bloat+-- {-# RULES "foldr/x:xs" forall k z x xs . foldr k z (x:xs) = k x (foldr k z xs) #-}+{-# RULES "foldr/zip" forall k z xs ys . foldr k z (zip xs ys) = let zip' (a:as) (b:bs) = k (a,b) (zip' as bs); zip' _ _ = z in zip' xs ys #-}+-- {-# RULES "foldr/sequence" forall k z xs . foldr k z (sequence xs) = foldr (\x y -> do rx <- x; ry <- y; return (k rx ry)) (return z) xs #-}+-- {-# RULES "foldr/mapM" forall k z f xs . foldr k z (mapM f xs) = foldr (\x y -> do rx <- f x; ry <- y; return (k rx ry)) (return z) xs   #-}++default(Int,Double)
+ lib/base/src/Prelude/CType.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS_LHC -N #-}+module Prelude.CType (+    isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,+    isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,+    digitToInt, intToDigit,+    toUpper, toLower+    ) where++import Lhc.Basics+import Lhc.Order+import Lhc.Num+import Data.Word+import Lhc.IO+import Lhc.List++-- Character-testing operations+isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,+ isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum :: Char -> Bool++isAscii c                =  c < '\x80'++isLatin1 c               =  c <= '\xff'++isControl c              =  c < ' ' || c >= '\DEL' && c <= '\x9f'++isPrint c               =  isLatin1 c && not (isControl c)++isSpace c                =  c `elem` " \t\n\r\f\v\xA0"++isUpper c                =  c >= 'A' && c <= 'Z'++isLower c                =  c >= 'a' && c <= 'z'++isAlpha c                =  isUpper c || isLower c++isDigit c                =  c >= '0' && c <= '9'++isOctDigit c             =  c >= '0' && c <= '7'++isHexDigit c             =  isDigit c || c >= 'A' && c <= 'F' ||+                                         c >= 'a' && c <= 'f'++isAlphaNum c             =  isAlpha c || isDigit c++-- Digit conversion operations+digitToInt :: Char -> Int+digitToInt c+  | isDigit c            =  ord c - ord '0'+  | c >= 'a' && c <= 'f' =  ord c - (ord 'a' + 10)+  | c >= 'A' && c <= 'F' =  ord c - (ord 'A' + 10)+  | otherwise            =  error "Char.digitToInt: not a digit"++intToDigit :: Int -> Char+intToDigit i = f (fromIntegral i :: Word) where+    f w | w < 10 = chr (ord '0' + i)+        | w < 16 = chr ((ord 'a' - 10) + i)+        | otherwise = error "Char.intToDigit: not a digit"++-- Case-changing operations+toUpper :: Char -> Char+toUpper c | isLower c = chr $ ord c - 32+          | otherwise = c++toLower :: Char -> Char+toLower c | isUpper c = chr $ ord c + 32+          | otherwise = c++elem    :: Char -> [Char] -> Bool+elem _ []	= False+elem x (y:ys)+    | x == y = True+    | otherwise = f y ys where+        f y _ | x == y = True+        f _ (y:ys) = f y ys+        f _ [] = False
+ lib/base/src/Prelude/Float.hs view
@@ -0,0 +1,303 @@+{-# OPTIONS_LHC -N -fffi -fm4  #-}++module Prelude.Float(readDouble,doubleToDigits,doubleToRational) where++import Lhc.Order+import Lhc.Basics+import Lhc.Monad+import Lhc.IO+import Lhc.Float+import Lhc.Num+import Lhc.Types+import Data.Word+import Foreign.Storable+import Foreign.C.Types+import Foreign.Ptr+import Foreign.Marshal.Alloc+import Numeric+import Prelude.Text+import Lhc.List+import Prelude((^),(^^),elem,take)+++++m4_define(INST,{{+++foreign import primitive "FDiv" divide$2 ::  $2 -> $2 -> $2+foreign import primitive "FPwr" exponent$2 ::  $2 -> $2 -> $2+foreign import primitive "FAtan2" atan2$1 ::  $1 -> $1 -> $1+foreign import primitive "F2I"  toInteger$1 :: $1 -> Integer+foreign import primitive "const.M_PI" c_pi$1 :: $1++instance Fractional $1 where+    $1 x / $1 y = $1 (divide$2 x y)+    fromRational x = fromInteger (numerator x) / fromInteger (denominator x)++m4_define(FI,foreign import primitive "{{$}}1"  {{$}}2$2 :: $2 -> $2)++FI(Sqrt,sqrt)+FI(Exp,exp)+FI(Log,log)+FI(Sin,sin)+FI(Cos,cos)+FI(Tan,tan)+FI(Sinh,sinh)+FI(Cosh,cosh)+FI(Tanh,tanh)+FI(Asin,asin)+FI(Acos,acos)+FI(Atan,atan)++m4_undefine({{FI}})++instance Floating $1 where+    pi = c_pi$1+    sqrt ($1 x) = $1 (sqrt$2 x)+    exp ($1 x) = $1 (exp$2 x)+    log ($1 x) = $1 (log$2 x)+    sin ($1 x) = $1 (sin$2 x)+    cos ($1 x) = $1 (cos$2 x)+    tan ($1 x) = $1 (tan$2 x)+    asin ($1 x) = $1 (asin$2 x)+    acos ($1 x) = $1 (acos$2 x)+    atan ($1 x) = $1 (atan$2 x)+    sinh ($1 x) = $1 (sinh$2 x)+    cosh ($1 x) = $1 (cosh$2 x)+    tanh ($1 x) = $1 (tanh$2 x)+    $1 x ** $1 y = $1 (exponent$2 x y)++    asinh = c_asinh$1+    acosh = c_acosh$1+    atanh = c_atanh$1+++instance RealFrac $1 where+    properFraction x+      = case (decodeFloat x)      of { (m,n) ->+    	let  b = floatRadix x     in+    	if n >= 0 then+	    (fromInteger m * fromInteger b ^ n, 0.0)+    	else+	    case (quotRem m (b^(negate n))) of { (w,r) ->+	    (fromInteger w, encodeFloat r n)+	    }+        }++    truncate x = fromInteger (toInteger$1 x)+    round x = fromInteger (toInteger$1 (roundf x))+    ceiling x = fromInteger (toInteger$1 (ceilingf x))+    floor x = fromInteger (toInteger$1 (floorf x))+++    properFractionf x = (c_trunc$1 x,x - c_trunc$1 x)+    truncatef x = c_trunc$1 x+    roundf x = c_nearbyint$1 x+    ceilingf x = c_ceil$1 x+    floorf x = c_floor$1 x+++foreign import ccall "-lm math.h asinh$3" c_asinh$1 :: $1 -> $1+foreign import ccall "-lm math.h acosh$3" c_acosh$1 :: $1 -> $1+foreign import ccall "-lm math.h atanh$3" c_atanh$1 :: $1 -> $1+foreign import ccall "-lm math.h trunc$3" c_trunc$1 :: $1 -> $1+foreign import ccall "-lm math.h ceil$3" c_ceil$1 :: $1 -> $1+foreign import ccall "-lm math.h floor$3" c_floor$1 :: $1 -> $1+foreign import ccall "-lm math.h nearbyint$3" c_nearbyint$1 :: $1 -> $1++foreign import ccall "math.h isnan" c_isnan$3 :: $1 -> CInt+foreign import ccall "math.h isinf" c_isinfinite$3 :: $1 -> CInt+foreign import ccall "math.h signbit" c_signbit$3 :: $1 -> CInt++foreign import ccall "math.h ldexp$3"  c_ldexp$3 :: $1 -> CInt -> $1+foreign import ccall "math.h frexp$3"  c_frexp$3 :: $1 -> Ptr CInt -> IO $1++}})++INST(Float,Float32_,f)+INST(Double,Float64_)+++instance Real Float where+    toRational x	=  (m:%1)*(b:%1)^^n+			   where (m,n) = decodeFloat x+				 b     = floatRadix  x+    toDouble x = floatToDouble x++instance Real Double where+    toRational x = doubleToRational x+    toDouble x = x+++++instance RealFloat Float where+    floatRadix _ = 2+    floatDigits _ = 24+    floatRange _ = (-125,128)++    exponent x		= case decodeFloatf x of (_,n) -> n+    significand x	= case decodeFloatf x of (m,_) -> m++    isNaN x = c_isnanf x /= 0+    isInfinite x = c_isinfinitef x /= 0+    isDenormalized _ = False+    isNegativeZero x = x == 0 && c_signbitf x /= 0+    isIEEE _ = True++    scaleFloat k x = c_ldexpf x (fromInt k)+    decodeFloatf x = unsafePerformIO $ alloca $ \ptr -> do+        x' <- c_frexpf x ptr+        exp <- peek ptr+        return (x', fromIntegral exp)++    encodeFloat i e = c_ldexpf (fromInteger i) (fromInt e)+    decodeFloat x = unsafePerformIO $ alloca $ \ptr -> do+        x' <- c_frexp (floatToDouble x) ptr+        exp <- peek ptr+        let x'' =  c_ldexp x' (fromInt $ floatDigits x)+        return (double2integer x'', fromIntegral exp  - floatDigits x)++    atan2 = atan2Float+++++instance RealFloat Double where+    floatRadix _ = 2+    floatDigits _ = 53+    floatRange _ = (-1021,1024)++    exponent x		= case decodeFloatf x of (_,n) -> n+    significand x	= case decodeFloatf x of (m,_) -> m++    isNaN x = c_isnan x /= 0+    isInfinite x = c_isinfinite x /= 0+    isDenormalized _ = False+    isNegativeZero x = x == 0 && c_signbit x /= 0+    isIEEE _ = True+    scaleFloat k x = c_ldexp x (fromInt k)+    decodeFloatf x = unsafePerformIO $ alloca $ \ptr -> do+        x' <- c_frexp x ptr+        exp <- peek ptr+        return (x', fromIntegral exp)++    encodeFloat i e =  c_ldexp (integer2double i) (fromInt e)+    decodeFloat x = unsafePerformIO $ alloca $ \ptr -> do+        x' <- c_frexp x ptr+        exp <- peek ptr+        let x'' = c_ldexp x' (fromInt $ floatDigits x)+        return (double2integer x'', fromIntegral exp  - floatDigits x)+++    atan2 = atan2Double++++foreign import primitive "I2F" integer2float :: Integer -> Float+foreign import primitive "I2F" integer2double :: Integer -> Double+foreign import primitive "F2I" double2integer :: Double -> Integer++++readDouble :: ReadS Double+readDouble r    = [((fromInteger n * (10^^(k-d))),t) | (n,d,s) <- readFix r,(k,t)   <- readExp s] +++                 [ (0/0, t) | ("NaN",t)      <- lex r] +++                 [ (1/0, t) | ("Infinity",t) <- lex r]+               where+                 readFix r = [(read (take 15 $ ds++ds'), length ds', t)+                             | (ds,d) <- lexDigits r,+                               (ds',t) <- lexFrac d ]++                 lexFrac ('.':ds) = lexDigits ds+                 lexFrac s        = [("",s)]++                 readExp (e:s) | e `elem` "eE" = readExp' s+                 readExp s                     = [(0,s)]++                 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]+                 readExp' ('+':s) = readDec s+                 readExp' s       = readDec s+++doubleToDigits :: Integer -> Double -> ([Int], Int)+doubleToDigits n d | n `seq` d `seq` d == 0 = ([], 0)+doubleToDigits base' x =+    let (f0', e0) = decodeFloat x+        base, f0 :: WordMax+        base = fromInteger base'+        f0 = fromIntegral f0'+        (minExp0, _) = floatRange x+        p = floatDigits x+        b :: WordMax+        b = fromInteger $ floatRadix x+        minExp = minExp0 - p            -- the real minimum exponent++        -- Haskell requires that f be adjusted so denormalized numbers+        -- will have an impossibly low exponent.  Adjust for this.+        f :: WordMax+        e :: Int+        (f, e) = let n = minExp - e0+                 in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)++        (r, s, mUp, mDn) =+           if e >= 0 then+               let be = b^e in+               if f == b^(p-1) then+                   (f*be*b*2, 2*b, be*b, b)+               else+                   (f*be*2, 2, be, be)+           else+               if e > minExp && f == b^(p-1) then+                   (f*b*2, b^(-e+1)*2, b, 1)+               else+                   (f*2, b^(-e)*2, 1, 1)+        k =+            let k0 =+                    if b==2 && base==10 then+                        -- logBase 10 2 is slightly bigger than 3/10 so+                        -- the following will err on the low side.  Ignoring+                        -- the fraction will make it err even more.+                        -- Haskell promises that p-1 <= logBase b f < p.+                        (p - 1 + e0) * 3 `div` 10+                    else+                        ceiling ((log ((fromIntegral (f+1))::Double) ++                                 fromIntegral e * log (fromIntegral b)) /+                                  log (fromIntegral base))+                fixup n =+                    if n >= 0 then+                        if r + mUp <= expt base n * s then n else fixup (n+1)+                    else+                        if expt base (-n) * (r + mUp) <= s then n+                                                           else fixup (n+1)+            in  fixup (k0::Int)++        gen ds rn sN mUpN mDnN | rn `seq` sN `seq` mUpN `seq` mDnN `seq` True =+            let (dn, rn') = (rn * base) `divMod` sN+                mUpN' = mUpN * base+                mDnN' = mDnN * base+            in  case (rn' < mDnN', rn' + mUpN' > sN) of+                (True,  False) -> toInt dn : ds+                (False, True)  -> toInt (dn+1) : ds+                (True,  True)  -> if rn' * 2 < sN then toInt dn : ds else toInt (dn+1) : ds+                (False, False) -> gen (toInt dn:ds) rn' sN mUpN' mDnN'+        rds,rrds :: [Int]+        rrds = reverse rds+        rds =+            if k >= 0 then+                gen [] r (s * expt base k) mUp mDn+            else+                let bk = expt base (-k)+                in  gen [] (r * bk) s (mUp * bk) (mDn * bk)+        expt :: WordMax -> Int -> WordMax+        expt base n = base^n+    in  k `seq` f `seq` e `seq` b `seq` rrds `seq` (rrds, k)+++doubleToRational :: Double -> Rational+doubleToRational x  =  (m:%1)*(b:%1)^^n where+    (m,n) = decodeFloat x+    b     = floatRadix  x++
+ lib/base/src/Prelude/IO.hs view
@@ -0,0 +1,131 @@+{-# OPTIONS_LHC -N -fffi -funboxed-values #-}+module Prelude.IO(+    IO(),+    ioError,+    catch,+    runExpr,+    FilePath(),+    putStr,+    putStrLn,+    print,+    getLine,+    getContents,+    readFile,+    interact,+    writeFile,+    appendFile,+    putChar,+    runExpr,+    getChar,+    userError+    ) where++import Foreign.C.String+import Foreign.C.Types+import Foreign.Ptr+import Lhc.Addr+import Lhc.Basics+import Lhc.IO+import Lhc.Monad+import Lhc.Order+import Lhc.Show+import Prelude.IOError+++-- IO operations exported by the prelude++type  FilePath = String++++{-# RULES "putStr/++"      forall xs ys . putStr (xs ++ ys) = putStr xs >> putStr ys #-}++putStr     :: String -> IO ()+putStr s   =  mapM_ putChar s++putStrLn   :: String -> IO ()+putStrLn s =  do putStr s+                 putChar '\n'++print      :: Show a => a -> IO ()+print x    =  putStrLn (show x)+++getLine    :: IO String+getLine    =  do c <- getChar+                 if c == '\n' then return "" else+                    do s <- getLine+                       return (c:s)++getContents :: IO String+getContents = unsafeInterleaveIO getContents' where+    getContents' = do+        ch <- c_getwchar+        if ch == -1 then return [] else  do+            xs <- unsafeInterleaveIO getContents'+            return (unsafeChr ch:xs)+++readFile :: FilePath -> IO String+readFile fn = do+    file <- withCString fn $ \fnc -> c_fopen fnc (ptrFromAddr__ "r"#)+    if  (file == nullPtr) then (fail "Could not open file.") else do+        let gc = do+                ch <- c_fgetwc file+                if ch == -1 then c_fclose file >> return [] else do+                        xs <- unsafeInterleaveIO gc+                        return (unsafeChr ch:xs)+        unsafeInterleaveIO gc+++foreign import ccall "stdio.h fopen" c_fopen :: CString -> CString -> IO (Ptr ())+foreign import ccall "stdio.h fclose" c_fclose :: Ptr () -> IO CInt+foreign import ccall "wchar.h lhc_utf8_getc" c_fgetwc :: Ptr () -> IO Int++-- | The 'interact' function takes a function of type @String->String@+-- as its argument.  The entire input from the standard input device is+-- passed to this function as its argument, and the resulting string is+-- output on the standard output device.++interact        ::  (String -> String) -> IO ()+interact f      =   do s <- getContents+                       putStr (f s)+{-+interact    ::  (String -> String) -> IO ()+-- The hSetBuffering ensures the expected interactive behaviour+interact f  =  do hSetBuffering stdin  NoBuffering+                  hSetBuffering stdout NoBuffering+                  s <- getContents+                  putStr (f s)++-}+++writeFile  :: FilePath -> String -> IO ()+writeFile  =  error "writeFile"++appendFile :: FilePath -> String -> IO ()+appendFile =  error "appendFile"++++putChar :: Char -> IO ()+putChar c = c_putwchar (ord c)++-- | 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++--TODO EOF == -1+getChar :: IO Char+getChar = do+    ch <- c_getwchar+    if ch == -1 then fail "End of file." else return (unsafeChr ch)++foreign import primitive "I2I" cwintToChar :: CWint -> Char+foreign import primitive "U2U" charToCWchar :: Char -> CWchar++foreign import ccall "stdio.h lhc_utf8_putchar" c_putwchar :: Int -> IO ()+foreign import ccall "wchar.h lhc_utf8_getchar" c_getwchar :: IO Int++
+ lib/base/src/Prelude/IOError.hs view
@@ -0,0 +1,62 @@+{-# OPTIONS_LHC -N #-}+module Prelude.IOError(IOError(),showIOError,userError) where++import Lhc.IO+import Lhc.Show++instance Show IOError where+    showsPrec _ s = showString (showIOError s)++{-++data IOError = IOError {+     ioe_handle   :: Maybe Handle,   -- the handle used by the action flagging+				     -- the error.+     ioe_type     :: IOErrorType,    -- what it was.+     ioe_location :: String,	     -- location.+     ioe_description :: String,      -- error type specific information.+     ioe_filename :: Maybe FilePath  -- filename the error is related to.+   } deriving(Eq)+++-- | An abstract type that contains a value for each variant of 'IOError'.+data IOErrorType+  = AlreadyExists+  | NoSuchThing+  | ResourceBusy+  | ResourceExhausted+  | EOF+  | IllegalOperation+  | PermissionDenied+  | UserError++instance Show IOErrorType where+  showsPrec _ e =+    showString $+    case e of+      AlreadyExists	-> "already exists"+      NoSuchThing       -> "does not exist"+      ResourceBusy      -> "resource busy"+      ResourceExhausted -> "resource exhausted"+      EOF		-> "end of file"+      IllegalOperation	-> "illegal operation"+      PermissionDenied  -> "permission denied"+      UserError		-> "user error"++instance Show IOException where+    showsPrec p (IOError hdl iot loc s fn) =+      (case fn of+	 Nothing -> case hdl of+		        Nothing -> id+			Just h  -> showsPrec p h . showString ": "+	 Just name -> showString name . showString ": ") .+      (case loc of+         "" -> id+	 _  -> showString loc . showString ": ") .+      showsPrec p iot .+      (case s of+	 "" -> id+	 _  -> showString " (" . showString s . showString ")")++-}+
+ lib/base/src/Prelude/Text.hs view
@@ -0,0 +1,123 @@+module Prelude.Text (+    ReadS, ShowS,+    Read(readsPrec, readList),+    Show(showsPrec, show, showList),+    reads, shows, read, lex,+    showChar, showString, readParen, showParen,readIO,readLn ) where++-- The instances of Read and Show for+--      Bool, Maybe, Either, Ordering+-- are done via "deriving" clauses in Prelude.hs+import Lhc.Show+import Lhc.Inst.Show()+import Prelude.Float+import Lhc.Basics+import Lhc.Monad+import Lhc.IO+import Prelude.IO+import Lhc.Order+import Lhc.Maybe+import Lhc.Text.Read+++import Data.Char(isSpace, isAlpha, isDigit, isAlphaNum,+                 showLitChar, readLitChar, lexLitChar)++import Numeric(showSigned, showInt, readSigned, readDec, showFloat,+               readFloat, lexDigits)++readLn :: Read a => IO a+readLn =  do l <- getLine+             r <- readIO l+             return r++  -- raises an exception instead of an error+readIO   :: Read a => String -> IO a+readIO s =  case [x | (x,t) <- reads s, ("","") <- lex t] of+              [x] -> return x+              []  -> ioError (userError "Prelude.readIO: no parse")+              _   -> ioError (userError "Prelude.readIO: ambiguous parse")++++read             :: (Read a) => String -> a+read s           =  case [x | (x,t) <- reads s, ("","") <- lex t] of+                         [x] -> x+                         []  -> error "Prelude.read: no parse"+                         _   -> error "Prelude.read: ambiguous parse"++++instance  Read Int  where+  readsPrec p r = [(fromInteger i, t) | (i,t) <- readsPrec p r]+        -- Reading at the Integer type avoids+        -- possible difficulty with minInt+++instance  Read Integer  where+    readsPrec p         = readSigned readDec++instance  Show Float  where+    showsPrec p         = showFloat+++instance  Show Double  where+    showsPrec p         = showFloat+++instance  Show Char  where+    showsPrec p '\'' = showString "'\\''"+    showsPrec p c    = showChar '\'' . showLitChar c . showChar '\''++    showList cs = showChar '"' . showl cs+                 where showl ""       = showChar '"'+                       showl ('"':cs) = showString "\\\"" . showl cs+                       showl (c:cs)   = showLitChar c . showl cs++instance  Read Char  where+    readsPrec p      = readParen False+                            (\r -> [(c,t) | ('\'':s,t)<- lex r,+                                            (c,"\'")  <- readLitChar s])++    readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,+                                               (l,_)      <- readl s ])+        where readl ('"':s)      = [("",s)]+              readl ('\\':('&':s)) = readl s+              readl s            = [(c:cs,u) | (c ,t) <- readLitChar s,+                                               (cs,u) <- readl t       ]+++instance  (Read a) => Read [a]  where+    readsPrec p      = readList++++instance Read Bool where+    readsPrec d input =+              (\ inp -> [((False) , rest) | ("False" , rest) <- lex inp]) input+              +++              (\ inp -> [((True) , rest) | ("True" , rest) <- lex inp]) input+++instance Read Ordering where+    readsPrec d input =+              (\ inp -> [((LT) , rest) | ("LT" , rest) <- lex inp]) input+              +++              (\ inp -> [((EQ) , rest) | ("EQ" , rest) <- lex inp]) input+              +++              (\ inp -> [((GT) , rest) | ("GT" , rest) <- lex inp]) input+++++instance (Read a) => Read (Maybe a) where+    readsPrec d input =+	      (\ inp -> [((Nothing) , rest) | ("Nothing" , rest) <- lex inp])+	      input+	      +++	      readParen (d > 9)+	      (\ inp ->+	       [((Just aa) , rest) | ("Just" , inp) <- lex inp ,+		(aa , rest) <- readsPrec 10 inp])+	      input+
+ lib/base/src/System.hs view
@@ -0,0 +1,84 @@+{-# OPTIONS_LHC -fffi #-}+module System (+    ExitCode(ExitSuccess,ExitFailure),+    getArgs, getProgName, getEnv, system, exitWith, exitFailure+  ) where++import Foreign.C.String+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.C.Types+import Lhc.IO(exitFailure)+import qualified Lhc.Options++data ExitCode = ExitSuccess | ExitFailure !Int+            deriving (Eq, Ord, Read, Show)++getArgs     :: IO [String]+getProgName :: IO String+getEnv      :: String -> IO String+system      :: String -> IO ExitCode+exitWith    :: ExitCode -> IO a+exitFailure :: IO a+++exitWith ExitSuccess = do+    c_exit 0+    return undefined+exitWith (ExitFailure n) = do+    c_exit n+    return undefined+++getProgName = case Lhc.Options.target of+    Lhc.Options.GhcHs -> ghc_getProgName+    _ -> peek lhc_progname >>= peekCString++getArgs = case Lhc.Options.target of+    Lhc.Options.GhcHs -> ghc_getArgs+    _ -> do+        argc <- peek lhc_argc+        argv <- peek lhc_argv+        let f n = peekElemOff argv n >>= peekCString+        mapM f [0 .. fromIntegral argc - 1]+++getEnv s = withCString s c_getenv >>= \p ->+    if p == nullPtr then fail ("getEnv: " ++ show s)  else peekCString p+++system s = withCString s c_system >>= \r -> case r of+    0 -> return ExitSuccess+    _ -> return $ ExitFailure (fromIntegral r)++foreign import unsafe ccall "exit" c_exit :: Int -> IO ()+foreign import unsafe ccall "system" c_system :: CString -> IO CInt+foreign import unsafe ccall "stdlib.h getenv" c_getenv :: Ptr CChar -> IO (Ptr CChar)++foreign import ccall "&lhc_progname" lhc_progname :: Ptr CString+foreign import ccall "&lhc_argc" lhc_argc :: Ptr CInt+foreign import ccall "&lhc_argv" lhc_argv :: Ptr (Ptr CString)++ghc_getArgs :: IO [String]+ghc_getArgs =+    alloca $ \ p_argc ->+    alloca $ \ p_argv -> do+        getProgArgv p_argc p_argv+        p    <- peek p_argc+        argv <- peek p_argv+        let f n = peekElemOff argv n >>= peekCString+        mapM f [1 .. fromIntegral p - 1]+++foreign import unsafe ccall "getProgArgv"+  getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()++ghc_getProgName :: IO String+ghc_getProgName =+  alloca $ \ p_argc ->+  alloca $ \ p_argv -> do+     getProgArgv p_argc p_argv+     argv <- peek p_argv+     peekElemOff argv 0 >>= peekCString+
+ lib/base/src/System/CPUTime.hs view
@@ -0,0 +1,3 @@+-- | Skeleton only, fixme.+module System.CPUTime where+
+ lib/base/src/System/Console/GetOpt.hs view
@@ -0,0 +1,303 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Console.GetOpt+-- Copyright   :  (c) Sven Panne 2002-2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- This library provides facilities for parsing the command-line options+-- in a standalone program.  It is essentially a Haskell port of the GNU+-- @getopt@ library.+--+-----------------------------------------------------------------------------++{-+Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small+changes Dec. 1997)++Two rather obscure features are missing: The Bash 2.0 non-option hack+(if you don't already know it, you probably don't want to hear about+it...) and the recognition of long options with a single dash+(e.g. '-help' is recognised as '--help', as long as there is no short+option 'h').++Other differences between GNU's getopt and this implementation:++* To enforce a coherent description of options and arguments, there+  are explanation fields in the option/argument descriptor.++* Error messages are now more informative, but no longer POSIX+  compliant... :-(++And a final Haskell advertisement: The GNU C implementation uses well+over 1100 lines, we need only 195 here, including a 46 line example!+:-)+-}++module System.Console.GetOpt (+   -- * GetOpt+   getOpt,+   usageInfo,+   ArgOrder(..),+   OptDescr(..),+   ArgDescr(..),++   -- * Example++   -- $example+) where++import Prelude -- necessary to get dependencies right++import Data.List ( isPrefixOf )++-- |What to do with options following non-options+data ArgOrder a+  = RequireOrder                -- ^ no option processing after first non-option+  | Permute                     -- ^ freely intersperse options and non-options+  | ReturnInOrder (String -> a) -- ^ wrap non-options into options++{-|+Each 'OptDescr' describes a single option.++The arguments to 'Option' are:++* list of short option characters++* list of long option strings (without \"--\")++* argument descriptor++* explanation of option for user+-}+data OptDescr a =              -- description of a single options:+   Option [Char]                --    list of short option characters+          [String]              --    list of long option strings (without "--")+          (ArgDescr a)          --    argument descriptor+          String                --    explanation of option for user++-- |Describes whether an option takes an argument or not, and if so+-- how the argument is injected into a value of type @a@.+data ArgDescr a+   = NoArg                   a         -- ^   no argument expected+   | ReqArg (String       -> a) String -- ^   option requires argument+   | OptArg (Maybe String -> a) String -- ^   optional argument++data OptKind a                -- kind of cmd line arg (internal use only):+   = Opt       a                --    an option+   | NonOpt    String           --    a non-option+   | EndOfOpts                  --    end-of-options marker (i.e. "--")+   | OptErr    String           --    something went wrong...++-- | Return a string describing the usage of a command, derived from+-- the header (first argument) and the options described by the+-- second argument.+usageInfo :: String                    -- header+          -> [OptDescr a]              -- option descriptors+          -> String                    -- nicely formatted decription of options+usageInfo header optDescr = unlines (header:table)+   where (ss,ls,ds)     = (unzip3 . concatMap fmtOpt) optDescr+         table          = zipWith3 paste (sameLen ss) (sameLen ls) ds+         paste x y z    = "  " ++ x ++ "  " ++ y ++ "  " ++ z+         sameLen xs     = flushLeft ((maximum . map length) xs) xs+         flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]++fmtOpt :: OptDescr a -> [(String,String,String)]+fmtOpt (Option sos los ad descr) =+   case lines descr of+     []     -> [(sosFmt,losFmt,"")]+     (d:ds) ->  (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ]+   where sepBy _  []     = ""+         sepBy _  [x]    = x+         sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs+         sosFmt = sepBy ',' (map (fmtShort ad) sos)+         losFmt = sepBy ',' (map (fmtLong  ad) los)++fmtShort :: ArgDescr a -> Char -> String+fmtShort (NoArg  _   ) so = "-" ++ [so]+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"++fmtLong :: ArgDescr a -> String -> String+fmtLong (NoArg  _   ) lo = "--" ++ lo+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"++{-|+Process the command-line, and return the list of values that matched+(and those that didn\'t). The arguments are:++* The order requirements (see 'ArgOrder')++* The option descriptions (see 'OptDescr')++* The actual command line arguments (presumably got from+  'System.Environment.getArgs').++'getOpt' returns a triple, consisting of the argument values, a list+of options that didn\'t match, and a list of error messages.+-}+getOpt :: ArgOrder a                   -- non-option handling+       -> [OptDescr a]                 -- option descriptors+       -> [String]                     -- the commandline arguments+       -> ([a],[String],[String])      -- (options,non-options,error messages)+getOpt _        _        []         =  ([],[],[])+getOpt ordering optDescr (arg:args) = procNextOpt opt ordering+   where procNextOpt (Opt o)    _                 = (o:os,xs,es)+         procNextOpt (NonOpt x) RequireOrder      = ([],x:rest,[])+         procNextOpt (NonOpt x) Permute           = (os,x:xs,es)+         procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,es)+         procNextOpt EndOfOpts  RequireOrder      = ([],rest,[])+         procNextOpt EndOfOpts  Permute           = ([],rest,[])+         procNextOpt EndOfOpts  (ReturnInOrder f) = (map f rest,[],[])+         procNextOpt (OptErr e) _                 = (os,xs,e:es)++         (opt,rest) = getNext arg args optDescr+         (os,xs,es) = getOpt ordering optDescr rest++-- take a look at the next cmd line arg and decide what to do with it+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+getNext ('-':'-':[]) rest _        = (EndOfOpts,rest)+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr+getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr+getNext a            rest _        = (NonOpt a,rest)++-- handle long option+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+longOpt ls rs optDescr = long ads arg rs+   where (opt,arg) = break (=='=') ls+         getWith p = [ o  | o@(Option _ ls _ _) <- optDescr, l <- ls, opt `p` l ]+         exact     = getWith (==)+         options   = if null exact then getWith isPrefixOf else exact+         ads       = [ ad | Option _ _ ad _ <- options ]+         optStr    = ("--"++opt)++         long (_:_:_)      _        rest     = (errAmbig options optStr,rest)+         long [NoArg  a  ] []       rest     = (Opt a,rest)+         long [NoArg  _  ] ('=':_)  rest     = (errNoArg optStr,rest)+         long [ReqArg _ d] []       []       = (errReq d optStr,[])+         long [ReqArg f _] []       (r:rest) = (Opt (f r),rest)+         long [ReqArg f _] ('=':xs) rest     = (Opt (f xs),rest)+         long [OptArg f _] []       rest     = (Opt (f Nothing),rest)+         long [OptArg f _] ('=':xs) rest     = (Opt (f (Just xs)),rest)+         long _            _        rest     = (errUnrec optStr,rest)++-- handle short option+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])+shortOpt x xs rest optDescr = short ads xs rest+  where options = [ o  | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ]+        ads     = [ ad | Option _ _ ad _ <- options ]+        optStr  = '-':[x]++        short (_:_:_)        _  rest     = (errAmbig options optStr,rest)+        short (NoArg  a  :_) [] rest     = (Opt a,rest)+        short (NoArg  a  :_) xs rest     = (Opt a,('-':xs):rest)+        short (ReqArg _ d:_) [] []       = (errReq d optStr,[])+        short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)+        short (ReqArg f _:_) xs rest     = (Opt (f xs),rest)+        short (OptArg f _:_) [] rest     = (Opt (f Nothing),rest)+        short (OptArg f _:_) xs rest     = (Opt (f (Just xs)),rest)+        short []             [] rest     = (errUnrec optStr,rest)+        short []             xs rest     = (errUnrec optStr,('-':xs):rest)++-- miscellaneous error formatting++errAmbig :: [OptDescr a] -> String -> OptKind a+errAmbig ods optStr = OptErr (usageInfo header ods)+   where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"++errReq :: String -> String -> OptKind a+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")++errUnrec :: String -> OptKind a+errUnrec optStr = OptErr ("unrecognized option `" ++ optStr ++ "'\n")++errNoArg :: String -> OptKind a+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")++{-+-----------------------------------------------------------------------------------------+-- and here a small and hopefully enlightening example:++data Flag = Verbose | Version | Name String | Output String | Arg String   deriving Show++options :: [OptDescr Flag]+options =+   [Option ['v']     ["verbose"]           (NoArg Verbose)      "verbosely list files",+    Option ['V','?'] ["version","release"] (NoArg Version)      "show version info",+    Option ['o']     ["output"]            (OptArg out "FILE")  "use FILE for dump",+    Option ['n']     ["name"]              (ReqArg Name "USER") "only dump USER's files"]++out :: Maybe String -> Flag+out Nothing  = Output "stdout"+out (Just o) = Output o++test :: ArgOrder Flag -> [String] -> String+test order cmdline = case getOpt order options cmdline of+                        (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n ++ "\n"+                        (_,_,errs) -> concat errs ++ usageInfo header options+   where header = "Usage: foobar [OPTION...] files..."++-- example runs:+-- putStr (test RequireOrder ["foo","-v"])+--    ==> options=[]  args=["foo", "-v"]+-- putStr (test Permute ["foo","-v"])+--    ==> options=[Verbose]  args=["foo"]+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])+--    ==> options=[Arg "foo", Verbose]  args=[]+-- putStr (test Permute ["foo","--","-v"])+--    ==> options=[]  args=["foo", "-v"]+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])+--    ==> options=[Version, Output "stdout", Name "bar", Name "baz"]  args=[]+-- putStr (test Permute ["--ver","foo"])+--    ==> option `--ver' is ambiguous; could be one of:+--          -v      --verbose             verbosely list files+--          -V, -?  --version, --release  show version info+--        Usage: foobar [OPTION...] files...+--          -v        --verbose             verbosely list files+--          -V, -?    --version, --release  show version info+--          -o[FILE]  --output[=FILE]       use FILE for dump+--          -n USER   --name=USER           only dump USER's files+-----------------------------------------------------------------------------------------+-}++{- $example++To hopefully illuminate the role of the different data+structures, here\'s the command-line options for a (very simple)+compiler:++>    module Opts where+>+>    import System.Console.GetOpt+>    import Data.Maybe ( fromMaybe )+>+>    data Flag+>     = Verbose  | Version+>     | Input String | Output String | LibDir String+>       deriving Show+>+>    options :: [OptDescr Flag]+>    options =+>     [ Option ['v']     ["verbose"] (NoArg Verbose)       "chatty output on stderr"+>     , Option ['V','?'] ["version"] (NoArg Version)       "show version number"+>     , Option ['o']     ["output"]  (OptArg outp "FILE")  "output FILE"+>     , Option ['c']     []          (OptArg inp  "FILE")  "input FILE"+>     , Option ['L']     ["libdir"]  (ReqArg LibDir "DIR") "library directory"+>     ]+>+>    inp,outp :: Maybe String -> Flag+>    outp = Output . fromMaybe "stdout"+>    inp  = Input  . fromMaybe "stdout"+>+>    compilerOpts :: [String] -> IO ([Flag], [String])+>    compilerOpts argv =+>       case (getOpt Permute options argv) of+>          (o,n,[]  ) -> return (o,n)+>          (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))+>      where header = "Usage: ic [OPTION...] files..."++-}
+ lib/base/src/System/Directory.hs view
@@ -0,0 +1,40 @@+module System.Directory where+{-+ (+    Permissions( Permissions, readable, writable, executable, searchable ),+    createDirectory, removeDirectory, removeFile,+    renameDirectory, renameFile, getDirectoryContents,+    getCurrentDirectory, setCurrentDirectory,+    doesFileExist, doesDirectoryExist,+    getPermissions, setPermissions,+    getModificationTime ) where++import Time ( ClockTime )++data Permissions = Permissions {+    readable,   writable,+    executable, searchable :: Bool+   } deriving (Eq,Ord,Read,Show)+++++createDirectory  :: FilePath -> IO ()+removeDirectory  :: FilePath -> IO ()+removeFile  :: FilePath -> IO ()+renameDirectory  :: FilePath -> FilePath -> IO ()+renameFile  :: FilePath -> FilePath -> IO ()++getDirectoryContents  :: FilePath -> IO [FilePath]+getCurrentDirectory  :: IO FilePath+setCurrentDirectory  :: FilePath -> IO ()++doesFileExist :: FilePath -> IO Bool+doesDirectoryExist :: FilePath -> IO Bool++getPermissions :: FilePath -> IO Permissions+setPermissions :: FilePath -> Permissions -> IO ()++getModificationTime :: FilePath -> IO ClockTime++-}
+ lib/base/src/System/IO.hs view
@@ -0,0 +1,158 @@+{-# OPTIONS_LHC -fffi #-}+module System.IO(+    BufferMode(..),+    Handle,+    IOMode(..),+    SeekMode(..),+    hClose,+    hFileSize,+    hSeek,+    hTell,+    hFlush,+    hGetBuf,+    hGetPosn,+    hSetPosn,+    hGetContents,+    hIsOpen,+    hPrint,+    hPutBuf,+    hPutChar,+    hPutStr,+    hPutStrLn,+    openFile,+    withFile,+    fixIO,+    stdin,stdout,stderr,+    try++    ) where++import Lhc.IO+import Lhc.Handle+import Prelude.IOError+import Foreign.Ptr+import Foreign.Storable+import Foreign.C.Types+import Data.Char(ord)+import Data.Int+++data BufferMode = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)+    deriving(Eq, Ord, Read, Show)+data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd+    deriving(Eq,Ord,Bounded,Enum,Read,Show)++type HandlePosn = Integer++++try            :: IO a -> IO (Either IOError a)+try f          =  catch (do r <- f+                            return (Right r))+                        (return . Left)+++withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r+withFile fp iom action = do+    h <- openFile fp iom+    r <- action h+    hClose h+    return r++++hFlush :: Handle -> IO ()+hFlush h = withHandle h c_fflush++isEOF :: IO Bool+isEOF = hIsEOF stdin++hIsEOF :: Handle -> IO Bool+hIsEOF h = withHandle h $ \ptr -> do+    r <- c_feof ptr+    return (r /= 0)++hPutChar h ch = withHandle h $ \ptr -> do+    c_fputwc (fromInt (ord ch)) ptr+    return ()++hPutStr     :: Handle -> String -> IO ()+hPutStr h s   = withHandle h $ \ptr -> do+    sequence_ [ c_fputwc (fromInt (ord ch)) ptr | ch <- s ]++hPutStrLn   :: Handle -> String -> IO ()+hPutStrLn h s = do+    hPutStr h s+    hPutChar h '\n'++hPrint      :: Show a => Handle -> a -> IO ()+hPrint h x    =  hPutStrLn h (show x)+++hGetContents :: Handle -> IO String+hGetContents h = withHandle h $ \ptr -> do+    let getContents' = do+            ch <- c_fgetwc ptr+            case ch of+                -1 -> return []+                _ -> do+                    xs <- unsafeInterleaveIO getContents'+                    return (unsafeChr ch:xs)+    unsafeInterleaveIO getContents'++hTell :: Handle -> IO Integer+hTell h = withHandle h $ \ptr -> fmap fromIntegral (c_ftell ptr)++hSeek :: Handle -> SeekMode -> Integer -> IO ()+hSeek h v w = withHandle h $ \ptr -> do+    let sm x = case x of+            AbsoluteSeek -> c_SEEK_SET+            RelativeSeek -> c_SEEK_CUR+            SeekFromEnd  -> c_SEEK_END+    c_fseek ptr (fromIntegral w) (sm v)+    return ()++hGetPosn :: Handle -> IO HandlePosn+hGetPosn h = hTell h++hSetPosn :: Handle -> HandlePosn -> IO ()+hSetPosn h hp = hSeek h AbsoluteSeek hp++hPutBuf :: Handle -> Ptr a -> Int -> IO ()+hPutBuf h p c = do+    let count = fromIntegral c+    rc <- withHandle h $ fwrite p 1 count+    if rc /= count then fail "hPutBuf: short write" else return ()++hGetBuf :: Handle -> Ptr a -> Int -> IO Int+hGetBuf h p c = do+    let count = fromIntegral c+    rc <- withHandle h $ fread p 1 count+    return $ fromIntegral rc++hFileSize :: Handle -> IO Integer+hFileSize h = do+    cp <- hTell h+    hSeek h SeekFromEnd 0+    fl <- hTell h+    hSeek h AbsoluteSeek cp+    return fl++foreign import ccall "stdio.h fwrite_unlocked" fwrite  :: Ptr a -> CSize -> CSize -> Ptr Handle -> IO CSize+foreign import ccall "stdio.h fread_unlocked" fread :: Ptr a -> CSize -> CSize -> Ptr Handle -> IO CSize++foreign import primitive "I2I" cwintToChar :: CWint -> Char++foreign import ccall "stdio.h fflush" c_fflush :: Ptr Handle -> IO ()++foreign import ccall "wchar.h lhc_utf8_getc" c_fgetwc :: Ptr Handle -> IO Int+foreign import ccall "wchar.h lhc_utf8_putc" c_fputwc :: Int -> Ptr Handle -> IO Int++foreign import ccall "stdio.h feof" c_feof :: Ptr Handle -> IO CInt+foreign import ccall "stdio.h ftell" c_ftell :: Ptr Handle -> IO IntMax                  -- XXX+foreign import ccall "stdio.h fseek" c_fseek :: Ptr Handle -> IntMax -> CInt -> IO CInt  -- XXX++foreign import primitive "const.SEEK_SET" c_SEEK_SET :: CInt+foreign import primitive "const.SEEK_CUR" c_SEEK_CUR :: CInt+foreign import primitive "const.SEEK_END" c_SEEK_END :: CInt+
+ lib/base/src/System/IO/Binary.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS_LHC -fffi #-}+module System.IO.Binary(readBinaryFile,putWord8,getWord8) where++import Data.Word+import Lhc.IO+import Foreign.C.Types+import Foreign.C.String+import Foreign.Ptr+import Foreign.C.Error++-- | Lazily read a file as a sequence of bytes.++readBinaryFile :: FilePath -> IO [Word8]+readBinaryFile fn = do+    file <- withCString fn $ \fnc -> c_fopen fnc read_str+    if  (file == nullPtr) then getErrno >>= \errno -> (ioError $ errnoToIOError "readBinaryFile" errno Nothing (Just fn)) else do+        let gc = do+                ch <- c_getc file+                case ch of+                    -1 -> c_fclose file >> return []+                    _ -> do+                        xs <- unsafeInterleaveIO gc+                        return (cintToWord8 ch:xs)+        unsafeInterleaveIO gc++foreign import primitive "Lobits" cintToWord8 :: CInt -> Word8+foreign import primitive "const.\"rb\"" read_str :: Ptr CChar++foreign import ccall "stdio.h getc_unlocked" c_getc :: Ptr () -> IO CInt+foreign import ccall "stdio.h fopen" c_fopen :: CString -> CString -> IO (Ptr ())+foreign import ccall "stdio.h fclose" c_fclose :: Ptr () -> IO CInt++-- Int translates to CInt in the calling conventions so this is safe.+foreign import ccall "stdio.h putchar_unlocked" c_putchar :: Int -> IO Int+foreign import ccall "stdio.h getchar_unlocked" c_getchar :: IO Int+++putWord8 :: Word8 -> IO ()+putWord8 w = c_putchar (fromIntegral w) >> return ()++getWord8 :: IO Word8+getWord8 = do+    c <- c_getchar+    case c of+        -1 -> fail "EOF"+        _ -> return $ fromIntegral c+
+ lib/base/src/System/IO/Continuation.hs view
@@ -0,0 +1,19 @@+module System.IO.Continuation(IOCont(),newContinuation,callContinuation) where++import Lhc.JumpPoint+import Lhc.Hole++data IOCont s a = IOCont (Hole a) JumpPoint++newContinuation :: (forall s . IOCont s a -> IO b) -> (a -> IO b) -> IO b+newContinuation act cc = do+    ref <- newHole+    withJumpPoint__ $ \jp r -> case r of+        False -> do act (IOCont ref jp)+        True  -> do readHole ref >>= cc++callContinuation :: IOCont s a -> a -> IO b+callContinuation (IOCont ref jp) x = do+    fillHole ref x+    jumpJumpPoint__ jp+
+ lib/base/src/System/IO/Error.hs view
@@ -0,0 +1,1 @@+module System.IO.Error where
+ lib/base/src/System/IO/Unsafe.hs view
@@ -0,0 +1,6 @@+{-# OPTIONS -N #-}+module System.IO.Unsafe(unsafePerformIO, unsafeInterleaveIO) where++import Lhc.IO++
+ lib/base/src/System/Info.hs view
@@ -0,0 +1,6 @@+{-# OPTIONS_LHC -N #-}+module System.Info where+++compilerName = "lhc"+compilerVersion = "0"
+ lib/base/src/System/Locale.hs view
@@ -0,0 +1,30 @@+module System.Locale where++data TimeLocale = TimeLocale {+        wDays  :: [(String, String)],   -- full and abbreviated week days+        months :: [(String, String)],   -- full and abbreviated months+        amPm   :: (String, String),     -- AM/PM symbols+        dateTimeFmt, dateFmt,           -- formatting strings+          timeFmt, time12Fmt :: String+        } deriving (Eq, Ord,Show)++defaultTimeLocale :: TimeLocale+defaultTimeLocale =  TimeLocale {+        wDays  = [("Sunday",   "Sun"),  ("Monday",    "Mon"),+                  ("Tuesday",  "Tue"),  ("Wednesday", "Wed"),+                  ("Thursday", "Thu"),  ("Friday",    "Fri"),+                  ("Saturday", "Sat")],++        months = [("January",   "Jan"), ("February",  "Feb"),+                  ("March",     "Mar"), ("April",     "Apr"),+                  ("May",       "May"), ("June",      "Jun"),+                  ("July",      "Jul"), ("August",    "Aug"),+                  ("September", "Sep"), ("October",   "Oct"),+                  ("November",  "Nov"), ("December",  "Dec")],++        amPm = ("AM", "PM"),+        dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y",+        dateFmt = "%m/%d/%y",+        timeFmt = "%H:%M:%S",+        time12Fmt = "%I:%M:%S %p"+        }
+ lib/base/src/System/Random.hs view
@@ -0,0 +1,268 @@+{-# OPTIONS_LHC -fffi #-}+{-+The June 1988 (v31 #6) issue of the Communications of the ACM has an+article by Pierre L'Ecuyer called, "Efficient and Portable Combined+Random Number Generators".  Here is the Portable Combined Generator of+L'Ecuyer for 32-bit computers.  It has a period of roughly 2.30584e18.++Transliterator: Lennart Augustsson++sof 1/99 - code brought (kicking and screaming) into the new Random+world..++malcolm 2/00 - patched for nhc98+-}++module System.Random+	(+	  RandomGen(next, split, genRange)+	, StdGen+	, mkStdGen+	, Random ( random,   randomR,+		   randoms,  randomRs,+		   randomIO, randomRIO )+	, getStdRandom+	, getStdGen+	, setStdGen+	, newStdGen+	) where++import Data.Char ( isSpace, chr, ord )+import Numeric+import Foreign.Storable+import Foreign.Ptr++++class RandomGen g where+    next  :: g -> (Int, g)+    split :: g -> (g, g)+    genRange :: g -> (Int,Int)+    genRange g = (minBound,maxBound)++data StdGen = StdGen !Int !Int++instance RandomGen StdGen where+  next  = stdNext+  split = stdSplit+  genRange g = (minBound,maxBound)+  -- without this Hat+nhc98 do not work++instance Show StdGen where+  showsPrec p (StdGen s1 s2) =+     showsPrec p s1 .+     showChar ' ' .+     showsPrec p s2++instance Read StdGen where+  readsPrec _p = \ r ->+     case try_read r of+       r@[_] -> r+       _   -> [stdFromString r] -- because it shouldn't ever fail.+    where+      try_read r = do+         (s1, r1) <- readDec (dropWhile isSpace r)+	 (s2, r2) <- readDec (dropWhile isSpace r1)+	 return (StdGen s1 s2, r2)++{-+ If we cannot unravel the StdGen from a string, create+ one based on the string given.+-}+stdFromString         :: String -> (StdGen, String)+stdFromString s        = (mkStdGen num, rest)+	where (cs, rest) = splitAt 6 s+              num        = foldl (\a x -> x + 3 * a) 1 (map ord cs)+++mkStdGen :: Int -> StdGen -- why not Integer ?+mkStdGen s+ | s < 0     = mkStdGen (-s)+ | otherwise = StdGen (s1+1) (s2+1)+      where+	(q, s1) = s `divMod` 2147483562+	s2      = q `mod` 2147483398++createStdGen :: Integer -> StdGen+createStdGen s+ | s < 0     = createStdGen (-s)+ | otherwise = StdGen (toInt (s1+1)) (toInt (s2+1))+      where+	(q, s1) = s `divMod` 2147483562+	s2      = q `mod` 2147483398++++class Random a where+  -- Minimal complete definition: random and randomR+  random  :: RandomGen g => g -> (a, g)+  randomR :: RandomGen g => (a,a) -> g -> (a,g)+  randoms  :: RandomGen g => g -> [a]+  randomRs :: RandomGen g => (a,a) -> g -> [a]+  randomIO  :: IO a+  randomRIO :: (a,a) -> IO a++  randomRs ival g = x : randomRs ival g' where+    (x,g') = randomR ival g+  randomIO	   = getStdRandom random+  randoms  g      = (\(x,g') -> x : randoms g') (random g)+  randomRIO range  = getStdRandom (randomR range)++instance Random Int where+  randomR (a,b) g = randomIvalInteger (toInteger a, toInteger b) g+  random g        = randomR (minBound,maxBound) g++instance Random Char where+  randomR (a,b) g =+      case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of+        (x,g) -> (chr x, g)+  random g	  = randomR (minBound,maxBound) g++instance Random Bool where+  randomR (a,b) g =+      case (randomIvalInteger (toInteger (bool2Int a), toInteger (bool2Int b)) g) of+        (x, g) -> (int2Bool (x::Int), g)+       where+         bool2Int False = (0::Int)+         bool2Int True  = 1++	 int2Bool 0	= False+	 int2Bool _	= True++  random g	  = randomR (minBound,maxBound) g++instance Random Integer where+  randomR ival g = randomIvalInteger ival g+  random g	 = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g++instance Random Double where+  randomR ival g = randomIvalDouble ival id g+  random g       = randomR (0::Double,1) g++-- hah, so you thought you were saving cycles by using Float?++instance Random Float where+  random g        = randomIvalDouble (0::Double,1) realToFrac g+  randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g++++mkStdRNG :: Integer -> IO StdGen+mkStdRNG o = return (createStdGen o)+--mkStdRNG :: Integer -> IO StdGen+--mkStdRNG o = do+--    ct          <- getCPUTime+--    (TOD sec _) <- getClockTime+--    return (createStdGen (sec * 12345 + ct + o))++randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)+randomIvalInteger (l,h) rng+ | l > h     = randomIvalInteger (h,l) rng+ | otherwise = case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')+     where+       k = h - l + 1+       b = 2147483561+       --b = 2147  -- TODO Bad!+       n = iLogBase b k++       f 0 acc g = (acc, g)+       f n acc g =+          let+	   (x,g')   = next g+	  in+	  f (n-1) (fromInt x + acc * b) g'++randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g)+randomIvalDouble (l,h) fromDouble rng+  | l > h     = randomIvalDouble (h,l) fromDouble rng+  | otherwise =+       case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of+         (x, rng') ->+	    let+	     scaled_x =+		fromDouble ((l+h)/2) ++                fromDouble ((h-l) / realToFrac intRange) *+		fromIntegral (x::Int)+	    in+	    (scaled_x, rng')++intRange :: Integer+intRange  = toInteger (maxBound::Int) - toInteger (minBound::Int)++iLogBase :: Integer -> Integer -> Integer+iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)++stdNext :: StdGen -> (Int, StdGen)+stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'')+	where	z'   = if z < 1 then z + 2147483562 else z+		z    = s1'' - s2''++		k    = s1 `quot` 53668+		s1'  = 40014 * (s1 - k * 53668) - k * 12211+		s1'' = if s1' < 0 then s1' + 2147483563 else s1'++		k'   = s2 `quot` 52774+		s2'  = 40692 * (s2 - k' * 52774) - k' * 3791+		s2'' = if s2' < 0 then s2' + 2147483399 else s2'++stdSplit            :: StdGen -> (StdGen, StdGen)+stdSplit std@(StdGen s1 s2)+                     = (left, right)+                       where+                        -- no statistical foundation for this!+                        left    = StdGen new_s1 t2+                        right   = StdGen t1 new_s2++                        new_s1 | s1 == 2147483562 = 1+                               | otherwise        = s1 + 1++                        new_s2 | s2 == 1          = 2147483398+                               | otherwise        = s2 - 1++                        StdGen t1 t2 = snd (next std)+--  #else+-- stdSplit :: StdGen -> (StdGen, StdGen)+-- stdSplit std@(StdGen s1 _) = (std, unsafePerformIO (mkStdRNG (fromInt s1)))+--  #endif	+++--ptr_a = unsafePerformIO $ malloc+--ptr_b = unsadePerformIO $ malloc++--setStdGen :: StdGen -> IO ()+--setStdGen sgen = writeIORef theStdGen sgen++--getStdGen :: IO StdGen+--getStdGen  = readIORef theStdGen++--theStdGen :: IORef StdGen+--theStdGen  = unsafePerformIO (newIORef (createStdGen 0))++setStdGen :: StdGen -> IO ()+getStdGen :: IO StdGen+setStdGen (StdGen a b) = do+    pokeElemOff c_stdrnd 0 a+    pokeElemOff c_stdrnd 1 b+getStdGen = do+    a <- peekElemOff c_stdrnd 0+    b <- peekElemOff c_stdrnd 1+    return $ StdGen a b+++foreign import ccall "&lhc_stdrnd" c_stdrnd :: Ptr Int+++newStdGen :: IO StdGen+newStdGen = do+  rng <- getStdGen+  let (a,b) = split rng+  setStdGen a+  return b++getStdRandom :: (StdGen -> (a,StdGen)) -> IO a+getStdRandom f = do+   rng		<- getStdGen+   let (v, new_rng) = f rng+   setStdGen new_rng+   return v+
+ lib/base/src/System/Time.hs view
@@ -0,0 +1,232 @@+{-# OPTIONS_LHC -fffi #-}+module System.Time (+    ClockTime,+    Month(..),+    Day(..),+    CalendarTime(..),+    TimeDiff(..),+    getClockTime,+    addToClockTime,+    diffClockTimes,+    toCalendarTime,+    toUTCTime,+    toClockTime,+    calendarTimeToString,+    formatCalendarTime+    ) where++import Data.Char+import Data.Ix+import Foreign.C.Types+import Foreign.Ptr+import System.Locale+import System.IO.Unsafe++data ClockTime = TOD !Integer !Integer -- Implementation-dependent+    deriving(Eq,Ord)++-- When a ClockTime is shown, it is converted to a CalendarTime in the current+-- timezone and then printed.  FIXME: This is arguably wrong, since we can't+-- get the current timezone without being in the IO monad.++instance Show ClockTime where+    showsPrec _ t = showString (calendarTimeToString+	  			 (unsafePerformIO (toCalendarTime t)))++data Month =  January   | February | March    | April+           |  May       | June     | July     | August+           |  September | October  | November | December+           deriving (Eq, Ord, Enum, Bounded, Read, Show)++instance Ix Month where+    range (x,y) = enumFromTo x y+    index (x,y) i+        | y < x || i < x || i > y = error "Time.Month.Ix: index out of range"+        | otherwise = fromEnum i - fromEnum x+    inRange (x,y) i = y >= x && (not $ i < x || i > y)+    rangeSize (x,y)+        | y < x = 0+        | otherwise = fromEnum y - fromEnum x++++data Day   =  Sunday | Monday  | Tuesday  | Wednesday | Thursday+           |  Friday | Saturday+           deriving (Eq, Ord, Enum, Bounded, Read, Show)++instance Ix Day where+    range (x,y) = enumFromTo x y+    index (x,y) i+        | y < x || i < x || i > y = error "Time.Day.Ix: index out of range"+        | otherwise = fromEnum i - fromEnum x+    inRange (x,y) i = y >= x && (not $ i < x || i > y)+    rangeSize (x,y)+        | y < x = 0+        | otherwise = fromEnum y - fromEnum x++data CalendarTime = CalendarTime {+    ctYear       :: !Int,+    ctMonth      :: !Month,+    ctDay, ctHour, ctMin, ctSec  :: !Int,+    ctPicosec    :: !Integer,+    ctWDay       :: !Day,+    ctYDay       :: !Int,+    ctTZName     :: String,+    ctTZ         :: !Int,+    ctIsDST      :: !Bool+    } deriving (Eq, Ord)++data TimeDiff = TimeDiff {+    tdYear, tdMonth, tdDay, tdHour, tdMin, tdSec :: !Int,+    tdPicosec      :: !Integer+    } deriving (Eq, Ord)+++-- Functions on times+getClockTime         :: IO ClockTime+getClockTime = do+    secs <- c_time nullPtr -- can't fail, according to POSIX+    return (TOD (ctimeToInteger secs) 0)++foreign import primitive "U2U" ctimeToInteger :: CTime -> Integer+   -- -----------------------------------------------------------------------------+-- | converts an internal clock time to a local time, modified by the+-- timezone and daylight savings time settings in force at the time+-- of conversion.  Because of this dependence on the local environment,+-- 'toCalendarTime' is in the 'IO' monad.++toCalendarTime :: ClockTime -> IO CalendarTime+toCalendarTime =  toCalTime False++-- | converts an internal clock time into a 'CalendarTime' in standard+-- UTC format.++toUTCTime :: ClockTime -> CalendarTime+toUTCTime      =  unsafePerformIO . toCalTime True++toCalTime :: Bool -> ClockTime -> IO CalendarTime+toCalTime = error "toCalTime"++toClockTime          :: CalendarTime -> ClockTime+toClockTime = error "toClockTime"++calendarTimeToString    :: CalendarTime -> String+calendarTimeToString    =  formatCalendarTime defaultTimeLocale "%c"++-- -----------------------------------------------------------------------------+-- | @'addToClockTime' d t@ adds a time difference @d@ and a+-- clock time @t@ to yield a new clock time.  The difference @d@+-- may be either positive or negative.++addToClockTime  :: TimeDiff  -> ClockTime -> ClockTime+addToClockTime (TimeDiff year mon day hour min sec psec)+	       (TOD c_sec c_psec) =+	let+	  sec_diff = toInteger sec ++                     60 * toInteger min ++                     3600 * toInteger hour ++                     24 * 3600 * toInteger day+	  cal      = toUTCTime (TOD (c_sec + sec_diff) (c_psec + psec))+                                                       -- FIXME! ^^^^+          new_mon  = fromEnum (ctMonth cal) + r_mon+	  month' = fst tmp+	  yr_diff = snd tmp+          tmp+	    | new_mon < 0  = (toEnum (12 + new_mon), (-1))+	    | new_mon > 11 = (toEnum (new_mon `mod` 12), 1)+	    | otherwise    = (toEnum new_mon, 0)++	  (r_yr, r_mon) = mon `quotRem` 12++          year' = ctYear cal + year + r_yr + yr_diff+	in+	toClockTime cal{ctMonth=month', ctYear=year'}++-- | @'diffClockTimes' t1 t2@ returns the difference between two clock+-- times @t1@ and @t2@ as a 'TimeDiff'.++diffClockTimes  :: ClockTime -> ClockTime -> TimeDiff+-- diffClockTimes is meant to be the dual to `addToClockTime'.+-- If you want to have the TimeDiff properly splitted, use+-- `normalizeTimeDiff' on this function's result+--+-- CAVEAT: see comment of normalizeTimeDiff+diffClockTimes (TOD sa pa) (TOD sb pb) =+    noTimeDiff{ tdSec     = fromIntegral (sa - sb)+                -- FIXME: can handle just 68 years...+              , tdPicosec = pa - pb+              }++noTimeDiff :: TimeDiff+noTimeDiff = TimeDiff 0 0 0 0 0 0 0+++formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String+formatCalendarTime l fmt ct@(CalendarTime year mon day hour min sec sdec+                                           wday yday tzname _ _) =+        doFmt fmt+  where doFmt ('%':c:cs) = decode c ++ doFmt cs+        doFmt (c:cs) = c : doFmt cs+        doFmt "" = ""++        to12 :: Int -> Int+        to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h'++        decode 'A' = fst (wDays l  !! fromEnum wday)+        decode 'a' = snd (wDays l  !! fromEnum wday)+        decode 'B' = fst (months l !! fromEnum mon)+        decode 'b' = snd (months l !! fromEnum mon)+        decode 'h' = snd (months l !! fromEnum mon)+        decode 'C' = show2 (year `quot` 100)+        decode 'c' = doFmt (dateTimeFmt l)+        decode 'D' = doFmt "%m/%d/%y"+        decode 'd' = show2 day+        decode 'e' = show2' day+        decode 'H' = show2 hour+        decode 'I' = show2 (to12 hour)+        decode 'j' = show3 yday+        decode 'k' = show2' hour+        decode 'l' = show2' (to12 hour)+        decode 'M' = show2 min+        decode 'm' = show2 (fromEnum mon+1)+        decode 'n' = "\n"+        decode 'p' = (if hour < 12 then fst else snd) (amPm l)+        decode 'R' = doFmt "%H:%M"+        decode 'r' = doFmt (time12Fmt l)+        decode 'T' = doFmt "%H:%M:%S"+        decode 't' = "\t"+        decode 'S' = show2 sec+--        decode 's' = ...                -- Implementation-dependent+        decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7)+        decode 'u' = show (let n = fromEnum wday in+                           if n == 0 then 7 else n)+        decode 'V' =+            let (week, days) =+                   (yday + 7 - if fromEnum wday > 0 then+                               fromEnum wday - 1 else 6) `divMod` 7+            in  show2 (if days >= 4 then+                          week+1+                       else if week == 0 then 53 else week)++        decode 'W' =+            show2 ((yday + 7 - if fromEnum wday > 0 then+                               fromEnum wday - 1 else 6) `div` 7)+        decode 'w' = show (fromEnum wday)+        decode 'X' = doFmt (timeFmt l)+        decode 'x' = doFmt (dateFmt l)+        decode 'Y' = show year+        decode 'y' = show2 (year `rem` 100)+        decode 'Z' = tzname+        decode '%' = "%"+        decode c   = [c]++show2, show2', show3 :: Int -> String+show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)]++show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x++show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100)+++foreign import unsafe ccall "time.h time" c_time :: Ptr CTime -> IO CTime+
+ lib/base/src/Text/Printf.hs view
@@ -0,0 +1,276 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Printf+-- Copyright   :  (c) Lennart Augustsson, 2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  lennart@augustsson.net+-- Stability   :  provisional+-- Portability :  portable+--+-- A C printf like formatter.+--+-----------------------------------------------------------------------------++module Text.Printf(+   printf, hPrintf,+   PrintfType, HPrintfType, PrintfArg, IsChar+) where++import Prelude+import Data.Char+import Numeric(showEFloat, showFFloat, showGFloat)+import System.IO++-------------------++-- | Format a variable number of arguments with the C-style formatting string.+-- The return value is either 'String' or @('IO' a)@.+--+-- The format string consists of ordinary characters and /conversion+-- specifications/, which specify how to format one of the arguments+-- to printf in the output string.  A conversion specification begins with the+-- character @%@, followed by one or more of the following flags:+--+-- >    -      left adjust (default is right adjust)+-- >    0      pad with zeroes rather than spaces+--+-- followed optionally by a field width:+--+-- >    num    field width+-- >    *      as num, but taken from argument list+--+-- followed optionally by a precision:+--+-- >    .num   precision (number of decimal places)+--+-- and finally, a format character:+--+-- >    c      character               Char, Int, Integer+-- >    d      decimal                 Char, Int, Integer+-- >    o      octal                   Char, Int, Integer+-- >    x      hexadecimal             Char, Int, Integer+-- >    u      unsigned decimal        Char, Int, Integer+-- >    f      floating point          Float, Double+-- >    g      general format float    Float, Double+-- >    e      exponent format float   Float, Double+-- >    s      string                  String+--+-- Mismatch between the argument types and the format string will cause+-- an exception to be thrown at runtime.+--+-- Examples:+--+-- >   > printf "%d\n" (23::Int)+-- >   23+-- >   > printf "%s %s\n" "Hello" "World"+-- >   Hello World+-- >   > printf "%.2f\n" pi+-- >   3.14+--+printf :: (PrintfType r) => String -> r+printf fmt = spr fmt []++-- | Similar to 'printf', except that output is via the specified+-- 'Handle'.  The return type is restricted to @('IO' a)@.+hPrintf :: (HPrintfType r) => Handle -> String -> r+hPrintf hdl fmt = hspr hdl fmt []++-- |The 'PrintfType' class provides the variable argument magic for+-- 'printf'.  Its implementation is intentionally not visible from+-- this module. If you attempt to pass an argument of a type which+-- is not an instance of this class to 'printf' or 'hPrintf', then+-- the compiler will report it as a missing instance of 'PrintfArg'.+class PrintfType t where+    spr :: String -> [UPrintf] -> t++-- | The 'HPrintfType' class provides the variable argument magic for+-- 'hPrintf'.  Its implementation is intentionally not visible from+-- this module.+class HPrintfType t where+    hspr :: Handle -> String -> [UPrintf] -> t++{- not allowed in Haskell 98+instance PrintfType String where+    spr fmt args = uprintf fmt (reverse args)+-}+instance (IsChar c) => PrintfType [c] where+    spr fmt args = map fromChar (uprintf fmt (reverse args))++instance PrintfType (IO a) where+    spr fmt args = do+	putStr (uprintf fmt (reverse args))+	return undefined++instance HPrintfType (IO a) where+    hspr hdl fmt args = do+	hPutStr hdl (uprintf fmt (reverse args))+	return undefined++instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where+    spr fmt args = \ a -> spr fmt (toUPrintf a : args)++instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where+    hspr hdl fmt args = \ a -> hspr hdl fmt (toUPrintf a : args)++class PrintfArg a where+    toUPrintf :: a -> UPrintf++instance PrintfArg Char where+    toUPrintf c = UChar c++{- not allowed in Haskell 98+instance PrintfArg String where+    toUPrintf s = UString s+-}+instance (IsChar c) => PrintfArg [c] where+    toUPrintf s = UString (map toChar s)++instance PrintfArg Int where+    toUPrintf i = UInt i++instance PrintfArg Integer where+    toUPrintf i = UInteger i++instance PrintfArg Float where+    toUPrintf f = UFloat f++instance PrintfArg Double where+    toUPrintf d = UDouble d++class IsChar c where+    toChar :: c -> Char+    fromChar :: Char -> c++instance IsChar Char where+    toChar c = c+    fromChar c = c++-------------------++data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double++uprintf :: String -> [UPrintf] -> String+uprintf ""       []       = ""+uprintf ""       (_:_)    = fmterr+uprintf ('%':'%':cs) us   = '%':uprintf cs us+uprintf ('%':_)  []       = argerr+uprintf ('%':cs) us@(_:_) = fmt cs us+uprintf (c:cs)   us       = c:uprintf cs us++fmt :: String -> [UPrintf] -> String+fmt cs us =+	let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us+	    adjust (pre, str) =+		let lstr = length str+		    lpre = length pre+		    fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""+		in  if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str+        in+	case cs' of+	[]     -> fmterr+	c:cs'' ->+	    case us' of+	    []     -> argerr+	    u:us'' ->+		(case c of+		'c' -> adjust ("", [toEnum (toint u)])+		'd' -> adjust (fmti u)+		'x' -> adjust ("", fmtu 16 u)+		'o' -> adjust ("", fmtu 8  u)+		'u' -> adjust ("", fmtu 10 u)+		'e' -> adjust (dfmt' c prec u)+		'f' -> adjust (dfmt' c prec u)+		'g' -> adjust (dfmt' c prec u)+		's' -> adjust ("", tostr u)+		c   -> perror ("bad formatting char " ++ [c])+		 ) ++ uprintf cs'' us''++fmti (UInt i)     = if i < 0 then+			if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i))+		    else+			("", itos i)+fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i)+fmti (UChar c)    = fmti (UInt (fromEnum c))+fmti u		  = baderr++fmtu b (UInt i)     = if i < 0 then+			  if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i))+		      else+			  itosb b (toInteger i)+fmtu b (UInteger i) = itosb b i+fmtu b (UChar c)    = itosb b (toInteger (fromEnum c))+fmtu b u            = baderr++maxi :: Integer+maxi = (toInteger (maxBound::Int) + 1) * 2++toint (UInt i)     = i+toint (UInteger i) = toInt i+toint (UChar c)    = fromEnum c+toint u		   = baderr++tostr (UString s) = s+tostr u		  = baderr++itos n =+	if n < 10 then+	    [toEnum (fromEnum '0' + toInt n)]+	else+	    let (q, r) = quotRem n 10 in+	    itos q ++ [toEnum (fromEnum '0' + toInt r)]++itosb :: Integer -> Integer -> String+itosb b n =+	if n < b then+	    [intToDigit $ fromInteger n]+	else+	    let (q, r) = quotRem n b in+	    itosb b q ++ [intToDigit $ fromInteger r]++stoi :: Int -> String -> (Int, String)+stoi a (c:cs) | isDigit c = stoi (a*10 + fromEnum c - fromEnum '0') cs+stoi a cs                 = (a, cs)++getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf])+getSpecs l z ('-':cs) us = getSpecs True z cs us+getSpecs l z ('0':cs) us = getSpecs l True cs us+getSpecs l z ('*':cs) us =+        case us of+        [] -> argerr+        nu : us' ->+	    let n = toint nu+		(p, cs'', us'') =+		    case cs of+                    '.':'*':r -> case us' of { [] -> argerr; pu:us'' -> (toint pu, r, us'') }+		    '.':r     -> let (n, cs') = stoi 0 r in (n, cs', us')+		    _         -> (-1, cs, us')+	    in  (n, p, l, z, cs'', us'')+getSpecs l z ('.':cs) us =+	let (p, cs') = stoi 0 cs+	in  (0, p, l, z, cs', us)+getSpecs l z cs@(c:_) us | isDigit c =+	let (n, cs') = stoi 0 cs+	    (p, cs'') = case cs' of+			'.':r -> stoi 0 r+			_     -> (-1, cs')+	in  (n, p, l, z, cs'', us)+getSpecs l z cs       us = (0, -1, l, z, cs, us)++dfmt' c p (UDouble d) = dfmt c p d+dfmt' c p (UFloat f)  = dfmt c p f+dfmt' c p u           = baderr++dfmt c p d =+	case (case c of 'e' -> showEFloat; 'f' -> showFFloat; 'g' -> showGFloat)+               (if p < 0 then Nothing else Just p) d "" of+	'-':cs -> ("-", cs)+	cs     -> ("" , cs)++perror s = error ("Printf.printf: "++s)+fmterr = perror "formatting string ended prematurely"+argerr = perror "argument list ended prematurely"+baderr = perror "bad argument"++toInt :: (Integral a) => a -> Int+toInt x = fromInteger (toInteger x)
+ lib/base/src/Text/Show/Functions.hs view
@@ -0,0 +1,5 @@+module Text.Show.Functions where+++instance Show (a -> b) where+    showsPrec _ _ = showString "<function>"
+ lib/base/src/Typeable.hs view
@@ -0,0 +1,15 @@+module Typeable where++class Typeable a where+    typeOf :: a -> String+    typeOf _ = "Unknown"++instance Typeable Char where+    typeOf _ = "Char"++instance Typeable Bool where+    typeOf _ = "Bool"++instance Typeable a => Typeable [a] where+    typeOf x = "[" ++ typeOf (head x) ++ "]"+
+ lib/base/src/Unsafe/Coerce.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_LHC -N -fffi #-}+module Unsafe.Coerce(unsafeCoerce) where+++foreign import primitive unsafeCoerce :: a -> b