packages feed

pugs-compat (empty) → 0.0.1

raw patch · 10 files changed

+996/−0 lines, 10 filesdep +arraydep +basedep +bytestringsetup-changed

Dependencies added: array, base, bytestring, containers, directory, haskell98, mtl, network, process, random, stm, stringtable-atom, time, unix, utf8-string

Files

+ LICENSE view
@@ -0,0 +1,18 @@+Copyright 2008 by Audrey Tang++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to+deal in the Software without restriction, including without limitation the+rights to use, copy, modify, merge, publish, distribute, sublicense, and/or+sell copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:+  +The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.+   +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL+THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ pugs-compat.cabal view
@@ -0,0 +1,35 @@+Name           : pugs-compat+Version        : 0.0.1+Build-type     : Simple+Category       : Pugs+License        : BSD3+License-file   : LICENSE+Maintainer     : audreyt@audreyt.org+Synopsis       : Portable Haskell/POSIX layer for Pugs+Description    : Portable Haskell/POSIX layer for Pugs+Cabal-Version  : >=1.2.1++Library {+  Extensions      : CPP, MagicHash, ScopedTypeVariables, MultiParamTypeClasses,+                    TypeSynonymInstances, FlexibleInstances, PatternGuards,+                    UndecidableInstances, FlexibleContexts, OverlappingInstances++  Build-depends   : base+  Exposed-modules : Pugs.Compat+  Other-modules   : Pugs.Compat.Cast Pugs.Compat.Global Pugs.Compat.ID+                    Pugs.Compat.Monads Pugs.Compat.Posix Pugs.Compat.String++  Ghc-Options     : -fparr++  Hs-source-dirs  : src++  if os(windows)+    Build-depends : base, haskell98, time, directory, process,+                    random, network, containers, bytestring, array, mtl, stm, utf8-string, stringtable-atom+    Extensions    : GeneralizedNewtypeDeriving, ForeignFunctionInterface, DeriveDataTypeable+  else+    Build-depends : base, haskell98, unix, time, directory, process,+                    random, network, containers, bytestring, array, mtl, stm, utf8-string, stringtable-atom+    Extensions    : ForeignFunctionInterface+    CPP-options   : -DPUGS_HAVE_POSIX+}
+ src/Pugs/Compat.hs view
@@ -0,0 +1,92 @@+{-|+    Internal utilities and library imports.++>   Though here at journey's end I lie+>   in darkness buried deep,+>   beyond all towers strong and high,+>   beyond all mountains steep,+>   above all shadows rides the Sun+>   and Stars for ever dwell:+>   I will not say the Day is done,+>   nor bid the Stars farewell.+-}++module Pugs.Compat ( module X ) where++import Pugs.Compat.Cast       as X +import Pugs.Compat.Global     as X +import Pugs.Compat.ID         as X +import Pugs.Compat.Monads     as X +import Pugs.Compat.String     as X +import Pugs.Compat.Posix      as X ++import Control.Concurrent     as X +import Control.Concurrent.STM as X +import Control.Exception      as X (catchJust, errorCalls, Exception(..))+import Control.Monad          as X (replicateM, forM, forM_, MonadPlus(..), msum, liftM2, liftM3, guard, foldM, unless, liftM, filterM, join, when)+import Control.Monad.Error    as X (MonadError(..), ErrorT(..), Error(..))+import Control.Monad.Fix      as X (fix)+import Control.Monad.Identity as X (Identity(..))+import Control.Monad.Reader   as X (MonadReader(..), ReaderT(..), asks)+import Control.Monad.State    as X (MonadState(..), gets, modify)+import Control.Monad.Trans    as X (MonadIO(..), MonadTrans(..))+import Control.Monad.Writer   as X (MonadWriter(..), WriterT(..), censor)+import Data.Array             as X (elems)+import Data.Bits              as X hiding (shift)+import Data.ByteString        as X (ByteString)+import Data.Char              as X +import Data.Complex           as X +import Data.Dynamic           as X hiding (cast)+import Data.Either            as X +import Data.Generics          as X (Data)+import Data.IORef             as X +import Data.IntMap            as X (IntMap)+import Data.List              as X ( (\\), find, genericLength, insert, sortBy, intersperse, partition, group, sort, genericReplicate, isPrefixOf, isSuffixOf, genericTake, genericDrop, unfoldr, nub, nubBy, transpose, delete, foldl')+import Data.Map               as X (Map)+import Data.Maybe             as X +import Data.Monoid            as X +import Data.Ratio             as X +import Data.Sequence          as X (Seq, singleton)+import Data.Set               as X (Set)+import Data.Time              as X +import Data.Time.Clock.POSIX  as X +import Data.Tree              as X +import Data.Unique            as X +import Data.Word              as X hiding (Word)+import Debug.Trace            as X +import GHC.Conc               as X (unsafeIOToSTM)+import GHC.Exts               as X (unsafeCoerce#, Word(W#), Word#)+import GHC.PArr               as X +import Network                as X +import Numeric                as X (showHex)+import System.Cmd             as X +import System.Directory       as X (Permissions(..), getPermissions, getTemporaryDirectory, createDirectory, removeDirectory, removeFile, getDirectoryContents, getModificationTime)+import System.Environment     as X (getArgs, withArgs, getProgName)+import System.Exit            as X +import System.IO              as X ( Handle, stdin, stdout, hClose, hGetLine, hGetChar, hGetContents, openFile, hSetBinaryMode, hPutStr, hPutStrLn, IOMode(..), stderr, SeekMode(..), hSetBuffering, BufferMode(..), hIsTerminalDevice, hFlush, hPrint, isEOF, hSeek, hTell, hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable)+import System.IO.Error        as X (ioeGetErrorString, isUserError)+import System.IO.Unsafe       as X +import System.Mem             as X +import System.Mem.Weak        as X +import System.Process         as X +import System.Random          as X hiding (split)++-- Instances.+instance Show Unique where+    show = show . hashUnique+instance (Typeable a, Typeable b) => Show (a -> b) where+    show _ = "(" ++ typA ++ " -> " ++ typB ++ ")"+        where+        typA = show $ typeOf (undefined :: a)+        typB = show $ typeOf (undefined :: b)+instance (Typeable a, Typeable b) => Eq (a -> b) where+    x == y = show x == show y+instance (Typeable a, Typeable b) => Ord (a -> b) where+    compare x y = compare (show x) (show y)+instance Eq Dynamic where+    x == y = show x == show y+instance Ord Dynamic where+    compare x y = compare (show x) (show y)++instance Typeable1 [::] where+    typeOf1 _ = mkTyConApp (mkTyCon "[::]") []
+ src/Pugs/Compat/Cast.hs view
@@ -0,0 +1,81 @@+module Pugs.Compat.Cast (+    (:>:)(..),+    (:<:)(..),+    addressOf,+    showAddressOf,+    fromTypeable,+    _cast+) where++import Data.Dynamic hiding (cast)+import GHC.Exts (unsafeCoerce#, Word(W#), Word#)+import Data.ByteString (ByteString)+import Data.Sequence (Seq)+import Numeric (showHex)+import Data.Foldable (toList)+import GHC.PArr (fromP, toP, mapP)+import qualified Data.Sequence as Seq+import qualified Data.Typeable as Typeable+import qualified Data.ByteString.UTF8 as UTF8++--+-- Nominal subtyping relationship with widening cast.+-- +-- The function "cast" is injective: for distinct values of "b",+-- it must produce distinct values of "a".+--+-- Also, it must work for all values of type "b".+-- +class ((:>:) a) b where+    {-# SPECIALISE cast :: a -> a #-}+    {-# SPECIALISE cast :: ByteString -> ByteString #-}+    {-# SPECIALISE cast :: String -> ByteString #-}+    {-# SPECIALISE cast :: ByteString -> String #-}+    {-# SPECIALISE cast :: String -> String #-}+    cast :: b -> a++class ((:<:) a) b where+    castBack :: a -> b++instance (b :<: a) => (:>:) a b where+    cast = castBack++{-# INLINE _cast #-}+{-# SPECIALISE _cast :: String -> String #-}+{-# SPECIALISE _cast :: String -> ByteString #-}+_cast :: (a :>: String) => String -> a+_cast = cast++instance (:<:) a a where castBack = id++instance ((:>:) [a]) (Seq a) where cast = toList+instance ((:<:) [a]) (Seq a) where castBack = Seq.fromList+instance ((:>:) [a]) [:a:] where cast = fromP+instance ((:<:) [a]) [:a:] where castBack = toP++-- "map cast" can be written as "cast"+instance (a :>: b) => ((:>:) [a]) [b] where cast = map cast+instance (a :>: b) => ((:>:) [:a:]) [:b:] where cast = mapP cast++fromTypeable :: forall m a b. (Monad m, Typeable a, Typeable b) => a -> m b+fromTypeable x = case Typeable.cast x of+    Just y -> return y+    _      -> fail $ "Cannot cast from " ++ (show $ typeOf x) ++ " to " ++ (show $ typeOf (undefined :: b))++{-# INLINE addressOf #-}+addressOf :: a -> Word+addressOf x = W# (unsafeCoerce# x)++{-# INLINE showAddressOf #-}+showAddressOf :: String -> a -> String+showAddressOf typ x = addr `seq` ('<' : typ ++ ":0x" ++ showHex addr ">")+    where+    addr = addressOf x++instance ((:>:) String) ByteString where+    cast = UTF8.toString+instance ((:<:) String) ByteString where+    castBack = UTF8.fromString++instance ((:<:) ByteString) String where+    castBack = UTF8.toString
+ src/Pugs/Compat/Global.hs view
@@ -0,0 +1,25 @@+module Pugs.Compat.Global (+    _GlobalFinalizer,+    safeMode+) where++import Data.IORef+import System.IO.Unsafe+import Pugs.Compat.Posix+import Pugs.Compat.Monads++{-|+Returns @True@ if the environment variable @PUGS_SAFEMODE@ is set to a+true value. Most IO primitives are disabled under safe mode.+-}+safeMode :: Bool+safeMode = case (inlinePerformIO $ getEnv "PUGS_SAFEMODE") of+    Nothing     -> False+    Just ""     -> False+    Just "0"    -> False+    _           -> True++{-# NOINLINE _GlobalFinalizer #-}+_GlobalFinalizer :: IORef (IO ())+_GlobalFinalizer = unsafePerformIO $ newIORef (return ())+
+ src/Pugs/Compat/ID.hs view
@@ -0,0 +1,95 @@+{-# OPTIONS_GHC -fno-full-laziness -fno-cse -cpp #-}++module Pugs.Compat.ID (+    ID, bufToID, hashNew,+    __, (+++), nullID, +) where++import StringTable.Atom+import Pugs.Compat.Cast+import Data.Int+import Data.Bits+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.HashTable as H++type ID = Atom++bufToID :: ByteString -> ID+bufToID = toAtom++{-# INLINE hashNew #-}+hashNew :: IO (H.HashTable ByteString a)+hashNew = H.new (==) hashByteString++hashByteString :: ByteString -> Int32+hashByteString = BS.foldl' f golden+    where+    f m c = fromIntegral c * magic + hashInt32 m+    magic = 0xdeadbeef+    golden :: Int32+    golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32+    hashInt32 :: Int32 -> Int32+    hashInt32 x = mulHi x golden + x+    mulHi a b = fromIntegral (r `shiftR` 32)+        where+        r :: Int64+        r = fromIntegral a * fromIntegral b++{-+-- XXX - Under GHCI, our global _BufToID table could be refreshed into+--       nonexistence, so we need to compare IDs based on the actual buffer,+--       not its unique key.+data ID = MkID+#ifdef PUGS_UNDER_GHCI+    { idBuf :: !ByteString, idKey :: !Int }+#else+    { idKey :: !Int, idBuf :: !ByteString }+#endif+    deriving (Typeable, Data)++instance Eq ID where+    MkID x _ == MkID y _ = x == y+    MkID x _ /= MkID y _ = x /= y++instance Ord ID where+    compare (MkID x _) (MkID y _) = compare x y+    MkID x _ <= MkID y _ = x <= y+    MkID x _ >= MkID y _ = x >= y+    MkID x _ < MkID y _ = x < y+    MkID x _ > MkID y _ = x > y++instance Show ID where+    showsPrec x MkID{ idBuf = buf } = showsPrec x buf++instance Read ID where+    readsPrec p s = [ (unsafePerformIO (bufToID (UTF8.pack x)), y) | (x, y) <- readsPrec p s]+-}++{-# NOINLINE nullID #-}+nullID :: ID+nullID = _cast ""++{-# INLINE __ #-}+__ :: String -> ByteString+__ = UTF8.fromString++{-# INLINE (+++) #-}+(+++) :: ByteString -> ByteString -> ByteString+(+++) = BS.append++instance ((:>:) ID) String where+    cast = toAtom++instance ((:>:) String) ID where+    cast = fromAtom++instance ((:<:) String) ID where+    castBack = toAtom++instance ((:<:) ID) ByteString where+    castBack = fromAtom++instance ((:<:) ByteString) ID where+    castBack = toAtom
+ src/Pugs/Compat/Monads.hs view
@@ -0,0 +1,132 @@+module Pugs.Compat.Monads (+    internalError,+    fatalError,++    traceM,++    warn,+    die,++    fmapM,+    fmapM_,++    combine,+    modifyTVar,+    inlinePerformIO,+    inlinePerformSTM,+    unsafePerformSTM,+    maybeM, finallyM,+    catchIO, evaluateIO+) where++import Prelude hiding (mapM)+import GHC.Base (realWorld#)+import Data.Traversable+import Debug.Trace+import qualified Data.ByteString.Internal as I (inlinePerformIO)+import System.Exit+import System.IO (hPutStrLn, stderr)+import System.IO.Unsafe+import Control.Exception (Exception(..))+import Control.Concurrent.STM+import Control.Monad.Trans (MonadIO(..))+import qualified Control.Exception (catch, evaluate)++{-|+Compose a list of @(a -> a)@ transformer functions into a single chained+function, using @foldr@ via the @(.)@ operator.++Note that the transformations are applied to the eventual argument in +right-to-left order.+-}+combine :: [a -> a] -- ^ List of transformer functions+        -> (a -> a) -- ^ The final combined transformer+combine = foldr (.) id++{-# INLINE inlinePerformIO #-}+inlinePerformIO :: IO a -> a+inlinePerformIO = I.inlinePerformIO++{-# INLINE inlinePerformSTM #-}+inlinePerformSTM :: STM a -> a+inlinePerformSTM m = I.inlinePerformIO (atomically m)++{-# NOINLINE unsafePerformSTM #-}+unsafePerformSTM :: STM a -> a+unsafePerformSTM m = unsafePerformIO (atomically m)++{-|+Read an STM variable, apply some transformation function to it, and write the+transformed value back to the same variable.+-}+modifyTVar :: TVar a +           -> (a -> a) +           -> STM ()+modifyTVar var f = do+    x <- readTVar var+    writeTVar var (f x)++-- instance MonadIO STM where+--     liftIO = unsafeIOToSTM++{-|+Extract a @Maybe@ value from the first argument (a monad).++If it's a @Just@ (i.e. it contains a value), apply the second argument+(a monad-producing function) to it, and @return@ the contents of /that/ +wrapped in a @Just@.++Otherwise, merely @return Nothing@.++(Strictly speaking, this function can operate with any @FunctorM@, not just+@Maybe@, but it helps to have a concrete example to explain things.)+-}+maybeM :: (Traversable f, Monad m) +       => m (f a)    -- ^ A @Maybe@ value encapsulated in a monad+       -> (a -> m b) -- ^ Action to perform on the first arg /if/ it contains+                     --     a value+       -> m (f b)    -- ^ Monad containing (@Just@ /result/) or @Nothing@+maybeM f m = mapM m =<< f++catchIO :: IO a -> (Control.Exception.Exception -> IO a) -> IO a+catchIO = Control.Exception.catch++evaluateIO :: a -> IO a+evaluateIO = Control.Exception.evaluate++{-# INLINE finallyM #-}+finallyM :: (Monad m) +     => m a     -- ^ The actual action+     -> m b     -- ^ the finalizer+     -> m a     -- ^ Result of the actual action+finallyM ma mb = do+    r <- ma+    mb+    return r++internalError :: String -> a+internalError s = error $+    "Internal error:\n    " ++ s ++ "\nPlease file a bug report."++fatalError :: (MonadIO m, Show a) => String -> a -> m b+fatalError x y = do+    warn x y+    liftIO $ exitFailure++die :: (Monad m, Show a) => String -> a -> m b+die str a = fail $ str ++ ": " ++ show a++warn :: (MonadIO m, Show a) => String -> a -> m ()+warn str val = liftIO $ do+    hPutStrLn stderr $ "*** " ++ str ++ ":\n    " ++ show val++-- | This is just @Debug.Trace.trace@, but allows for cleaner code in do blocks.+traceM :: Monad m => String -> m ()+traceM s = trace s $ return ()++fmapM :: (Functor t, Traversable t, Monad m) => (a -> m b) -> t a -> m (t b)+fmapM = mapM++fmapM_ :: (Functor t, Traversable t, Monad m) => (a -> m b) -> t a -> m ()+fmapM_ f x = mapM f x >> return ()+
+ src/Pugs/Compat/Posix.hs view
@@ -0,0 +1,344 @@+{-|+    POSIX calls and emulations.++>   And now all those lands lie under the wave.+>   And I walk in Ambarona, in Tauremorna, in Aldalome.+>   In my own land, in the country of Fangorn,+>   Where the roots are long,+>   And the years lie thicker than the leaves+>   In Tauremornalome.+-}++module Pugs.Compat.Posix (+    _PUGS_HAVE_POSIX,+    createLink,+    createSymbolicLink,+    readSymbolicLink,+    rename,+    removeLink,+    setFileMode,+    getEnvironment,+    getArg0,+    statFileSize,+    statFileMTime,+    statFileCTime,+    statFileATime,+    getProcessID,+    getRealUserID,+    getEffectiveUserID,+    getRealGroupID,+    getEffectiveGroupID,+    getProcessTimes,+    setEnv,+    getEnv,+    unsetEnv,+    signalProcess,+    ProcessTimes(..),+    clocksPerSecond,+    DirStream,+    openDirStream,+    readDirStream,+    rewindDirStream,+    closeDirStream,+    executeFile',        -- the prime signifies we changed signature.+    getCurrentDirectory,+    setCurrentDirectory,+    doesFileExist,+    doesDirectoryExist,+    doesExist,+    pugsTimeSpec+) where++import Foreign+import System.Cmd+import System.Posix.Types+import Data.Time++#ifdef PUGS_HAVE_POSIX+import System.Posix.Files+import System.Posix.Process+import System.Posix.Env hiding (getEnvironment)+import System.Posix.Directory+import System.Posix.User+import System.Exit+import System.Environment (getEnvironment)+import Foreign.C.Types+import Foreign.C.String+import Data.Typeable+import qualified System.Posix.Signals++_PUGS_HAVE_POSIX :: Bool+_PUGS_HAVE_POSIX = True++doesExist :: FilePath -> IO Bool+doesExist = fileExist++testStatusWith :: (FileStatus -> Bool) -> FilePath -> IO Bool+testStatusWith t f = fmap t (getFileStatus f) `catch` const (return False)++doesFileExist :: FilePath -> IO Bool+doesFileExist = testStatusWith isRegularFile++doesDirectoryExist :: FilePath -> IO Bool+doesDirectoryExist = testStatusWith isDirectory++getCurrentDirectory :: IO FilePath+getCurrentDirectory = getWorkingDirectory++setCurrentDirectory :: FilePath -> IO ()+setCurrentDirectory = changeWorkingDirectory++executeFile' :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO ExitCode+executeFile' prog True args Nothing = rawSystem prog args+executeFile' prog search args env = do+    print (prog, search, args, env)+    executeFile prog search args env+    return $ ExitFailure 1            -- if we got here, it failed.++statFileSize :: FilePath -> IO Integer+statFileSize f = do+    s <- getFileStatus f+    return (toInteger (fileSize s))++statFileTime :: (FileStatus -> EpochTime) -> FilePath -> IO Integer+statFileTime op f = do+    s <- getFileStatus f+    return (toInteger $ fromEnum $ op s)++statFileMTime :: FilePath -> IO Integer+statFileMTime f = statFileTime modificationTime f >>= return++statFileCTime :: FilePath -> IO Integer+statFileCTime f = statFileTime statusChangeTime f >>= return++statFileATime :: FilePath -> IO Integer+statFileATime f = statFileTime accessTime f >>= return++type Signal = System.Posix.Signals.Signal+signalProcess :: Signal -> ProcessID -> IO ()+signalProcess = System.Posix.Signals.signalProcess++clocksPerSecond :: (Num a) => a+clocksPerSecond = 1000000++instance Typeable DirStream where+    typeOf _ = mkTyConApp (mkTyCon "DirStream") []++#else++import qualified Control.Exception+import Debug.Trace+import qualified System.Environment+import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist, doesDirectoryExist)+import IO+import System.IO+import System.Exit+import Foreign.C.String+import Foreign.Ptr+import Foreign.C.Types+import Data.Ratio+import Data.Typeable+import System.Posix.Compat+import Foreign.C.Error++_PUGS_HAVE_POSIX :: Bool+_PUGS_HAVE_POSIX = False++failWith :: (Monad m) => String -> m a+failWith s = fail $ "'" ++ s ++ "' not implemented on this platform."++failWithIncomplete :: (Monad m) => String -> m a+failWithIncomplete s = fail $ "'" ++ s ++ "' not fully implemented on this platform."++warnWith :: String -> IO ()+warnWith s = trace ("'" ++ s ++ "' not implemented on this platform.") $ return ()++-- This should all be moved into Compat.Win32, once we go that route++-- This is partially right - but some APIs return even "better" resolution+clocksPerSecond :: (Num a) => a+clocksPerSecond = 1000000++foreign import stdcall unsafe "SetEnvironmentVariableW" win32SetEnv :: CWString -> CWString -> IO ()++setEnv :: String -> String -> Bool -> IO ()+setEnv k v _ = withCWString k $ withCWString v . win32SetEnv++getEnv :: String -> IO (Maybe String)+getEnv k = (fmap Just (System.Environment.getEnv k)) `Control.Exception.catch` (const $ return Nothing)++unsetEnv :: String -> IO ()+unsetEnv k = withCWString k $ \ key -> withCWString "" $ \ v -> do+               win32SetEnv key v+-- #unsetEnv _ = warnWith "unsetEnv"++getEnvironment :: IO [(String, String)]+getEnvironment = System.Environment.getEnvironment++createLink :: FilePath -> FilePath -> IO ()+createLink _ _ = warnWith "link"++createSymbolicLink :: FilePath -> FilePath -> IO ()+createSymbolicLink _ _ = warnWith "symlink"++readSymbolicLink :: FilePath -> IO FilePath+readSymbolicLink _ = failWith "readlink"++rename :: FilePath -> FilePath -> IO ()+rename _ _ = warnWith "rename"++removeLink :: FilePath -> IO ()+removeLink _ = warnWith "unlink"++setFileMode :: FilePath -> FileMode -> IO ()+setFileMode _ _ = warnWith "chmod"++newtype DirStream = DirStream (Ptr CDir)+    deriving (Typeable)++openDirStream :: FilePath -> IO DirStream+openDirStream name =+  withCString name $ \s -> do+    dirp <- c_opendir s+    return (DirStream dirp)++readDirStream :: DirStream -> IO FilePath+readDirStream (DirStream dirp) =+  alloca $ \ptr_dEnt  -> loop ptr_dEnt+ where+  loop ptr_dEnt = do+    resetErrno+    r <- readdir dirp ptr_dEnt+    if (r == 0)+        then do+            dEnt <- peek ptr_dEnt+            if (dEnt == nullPtr) then return [] else do+                entry <- (d_name dEnt >>= peekCString)+                freeDirEnt dEnt+                return entry+        else do+            errno <- getErrno+            if (errno == eINTR) then loop ptr_dEnt else do+                let (Errno eo) = errno+                if (eo == end_of_dir)+                    then return []+                    else throwErrno "readDirStream"++rewindDirStream :: DirStream -> IO ()+rewindDirStream (DirStream dirp) = do+    c_rewinddir dirp+    return ()++closeDirStream :: DirStream -> IO ()+closeDirStream (DirStream dirp) = do+    c_closedir dirp+    return ()++-- Win32 specific++type FILETIME = CULLong -- we'll keep the accuracy as long as possible++data ProcessTimes = ProcessTimes {+  elapsedTime :: Rational+  , userTime :: Rational+  , systemTime :: Rational+  , childUserTime :: Rational+  , childSystemTime :: Rational+}++foreign import stdcall unsafe "GetProcessTimes" win32GetProcessTimes ::+  Int -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO Int+-- relies on Int == Int32 on Windows++filetimeToSeconds :: FILETIME -> Rational+filetimeToSeconds ft = ((toInteger ft) % 10)++-- See Perl5 win32/win32.c for the complete implementation+-- that works on Windows 95 as well+getProcessTimes :: IO ProcessTimes+getProcessTimes = do+                    pid <- getProcessHandle+                    alloca $ \ pDummy  -> do+                    alloca $ \ pKernel -> do+                    alloca $ \ pUser   -> do+                      poke pDummy 0+                      poke pKernel 0+                      poke pUser 0+                      win32GetProcessTimes pid pDummy pDummy pKernel pUser+                      user    <- peek pUser+                      kernel  <- peek pKernel+                      return $ ProcessTimes 0 (filetimeToSeconds user) (filetimeToSeconds kernel) 0 0++-- This is Win32 specific, dunno about other non POSIX platforms+statFileSize :: FilePath -> IO Integer+statFileSize n = bracket (openFile n ReadMode) hClose hFileSize+-- statFileSize _ = failWith "-s"++-- Again, Win32 specific magic, as stolen from GHC+foreign import stdcall unsafe "GetCurrentProcessId" getProcessID :: IO Int -- relies on Int == Int32 on Windows+foreign import stdcall "GetCurrentProcess" getProcessHandle :: IO Int -- relies on Int == Int32 on Windows++-- getProcessID :: IO Int+-- getProcessID = return $ 1++type UserID = Int+type GroupID = Int++getRealUserID :: IO UserID+getRealUserID = return 1++getEffectiveUserID :: IO UserID+getEffectiveUserID = return 1++getRealGroupID :: IO GroupID+getRealGroupID = return 1++getEffectiveGroupID :: IO GroupID+getEffectiveGroupID = return 1++signalProcess :: Int -> Int -> IO ()+signalProcess _ _ = failWith "kill"++executeFile' :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO ExitCode+executeFile' prog True args Nothing = rawSystem prog args+executeFile' _ _ _ _ = failWithIncomplete "executeFile"++doesExist :: FilePath -> IO Bool+doesExist f = do+    rv <- doesFileExist f+    if rv then return rv else doesDirectoryExist f++statFileMTime :: FilePath -> IO Integer+statFileMTime _ = failWith "-M"++statFileCTime :: FilePath -> IO Integer+statFileCTime _ = failWith "-C"++statFileATime :: FilePath -> IO Integer+statFileATime _ = failWith "-A"++#endif++foreign import ccall unsafe "getProgArgv"+  getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()++getArg0 :: IO String+getArg0 = do+    alloca $ \ p_argc -> do+    alloca $ \ p_argv -> do+        getProgArgv p_argc p_argv+        argv <- peek p_argv+        peekCString =<< peekElemOff argv 0++epochY2K :: UTCTime+epochY2K = UTCTime+    { utctDay     = fromGregorian 2000 01 01+    , utctDayTime = 0+    }++{-|+Convert an internal @ClockTime@ to a Pugs-style fractional time.+Used by op0 "time", @Pugs.Run.prepareEnv@, and the file time tests.+-}+pugsTimeSpec :: UTCTime -> Rational+pugsTimeSpec clkt = toRational (diffUTCTime clkt epochY2K)
+ src/Pugs/Compat/String.hs view
@@ -0,0 +1,171 @@+module Pugs.Compat.String (+    split,+    split_n,+    breakOnGlue,+    afterPrefix,+    decodeUTF8,+    encodeUTF8,+    toQuoteMeta+) where++import Debug.Trace+import Pugs.Compat.Monads+import Data.Char++split :: (Eq a) => [a] -> [a] -> [[a]]+split []  _   = internalError "splitting by an empty list"+split sep str =+   case breakOnGlue sep str of+     Just (before, after) -> before : split sep after+     Nothing -> [str]++split_n :: (Eq a) => [a] -> [a] -> Int -> [[a]]+split_n [] _ _ = internalError "splitting by an empty list"+split_n sep str n+   | n == 1 = [str]+   | otherwise =+   case breakOnGlue sep str of+       Just (before, after) -> before : split_n sep after (n-1)+       Nothing -> [str]++-- returns Nothing if the glue isn't there+breakOnGlue :: (Eq a) => [a] -> [a] -> Maybe ([a], [a])+breakOnGlue _    [] = Nothing+breakOnGlue glue list@(x:xs) =+   case afterPrefix glue list of+      Just rest -> Just ([], rest)+      Nothing -> case breakOnGlue glue xs of+                    Just (before, after) -> Just (x : before, after)+                    Nothing -> Nothing++afterPrefix :: (Eq a) => [a] -> [a] -> Maybe [a]+afterPrefix []     list = Just list+afterPrefix _      []   = Nothing  -- non-empty prefix of an empty list+afterPrefix (p:ps) (x:xs)+   | p == x = afterPrefix ps xs+   | otherwise = Nothing++{-# INLINE decodeUTF8 #-}+decodeUTF8 :: String -> String+decodeUTF8 xs = concatMap decodeUTF8' (chunkDec4096 xs)++{-# INLINE decodeUTF8' #-}+decodeUTF8' :: String -> String+decodeUTF8' [] = []+decodeUTF8' (c:cs)+    | c < '\x80'+    = let rest = decodeUTF8' cs+       in seq rest+          (c:rest)+decodeUTF8' (c:d:cs)+    | '\xC0' <= c, c <= '\xDF'+    , '\x80' <= d, d <= '\xBF'+    = let rest = decodeUTF8' cs+       in seq rest+          ( toEnum ( (fromEnum c `mod` 0x20) * 0x40+                   + fromEnum d `mod` 0x40+                   )+          : rest+          )+decodeUTF8' (c:d:e:cs)+    | '\xE0' <= c, c <= '\xEF'+    , '\x80' <= d, d <= '\xBF'+    , '\x80' <= e, e <= '\xBF'+    = let rest = decodeUTF8' cs+       in seq rest+          ( toEnum ( (fromEnum c `mod` 0x10 * 0x1000)+                   + (fromEnum d `mod` 0x40) * 0x40+                   + fromEnum e `mod` 0x40+                   )+          : rest+          )+decodeUTF8' (c:d:e:f:cs)+    | '\xF0' <= c, c <= '\xF7'+    , '\x80' <= d, d <= '\xBF'+    , '\x80' <= e, e <= '\xBF'+    , '\x80' <= f, f <= '\xBF'+    = let rest = decodeUTF8' cs+       in seq rest+          ( toEnum ( (fromEnum c `mod` 0x10 * 0x40000)+                   + (fromEnum d `mod` 0x40) * 0x1000+                   + (fromEnum e `mod` 0x40) * 0x40+                   + fromEnum f `mod` 0x40+                   )+          : rest+          )+decodeUTF8' (x:xs) = trace ("decodeUTF8': bad data: " ++ show x) (x:decodeUTF8' xs)++{-# INLINE chunkDec4096 #-}+chunkDec4096 :: [Char] -> [[Char]]+chunkDec4096 xs = doChunk (splitAt 4096 xs)+    where+    doChunk ([], _)  = []+    doChunk (pre, post@(c:_))+        | c < '\x80' = pre : chunkDec4096 post+        | c > '\xBF' = pre : chunkDec4096 post+        | otherwise  = doChunk (init pre, last pre : post)+    doChunk (pre, _) = [pre]++{-# INLINE chunk #-}+chunk :: Int -> [Char] -> [[Char]]+chunk _    [] = []+chunk size xs = case splitAt size xs of (xs', xs'') -> xs' : chunk size xs''++{-# INLINE encodeUTF8 #-}+encodeUTF8 :: String -> String+encodeUTF8 xs = concatMap encodeUTF8' (chunk 4096 xs)++{-# INLINE encodeUTF8' #-}+encodeUTF8' :: String -> String+encodeUTF8' [] = []+-- In the \0 case, we diverge from the Unicode standard to remove any trace+-- of embedded nulls in our bytestrings, to allow the use of Judy.StrMap+-- and to make passing CString around easier.  See Java for the same treatment:+-- http://java.sun.com/j2se/1.5.0/docs/api/java/io/DataInput.html#modified-utf-8+encodeUTF8' ('\0':cs)+    = let rest = encodeUTF8' cs+       in seq rest+          ('\xC0':'\x80':rest)+encodeUTF8' (c:cs)+    | c < '\x80'+    = let rest = encodeUTF8' cs+       in seq rest+          (c:rest)+    | c < '\x800'+    = let i     = fromEnum c+          rest  = encodeUTF8' cs+       in seq rest+          ( toEnum (0xC0 + i `div` 0x40)+          : toEnum (0x80 + i `mod` 0x40)+          : rest+          )+    | c < '\x10000'+    = let i     = fromEnum c+          rest  = encodeUTF8' cs+       in seq rest+          ( toEnum (0xE0 + i `div` 0x1000)+          : toEnum (0x80 + (i `div` 0x40) `mod` 0x40)+          : toEnum (0x80 + i `mod` 0x40)+          : rest+          )+    | otherwise+    = let i     = fromEnum c+          rest  = encodeUTF8' cs+       in seq rest+          ( toEnum (0xF0 + i `div` 0x40000)+          : toEnum (0x80 + (i `div` 0x1000) `mod` 0x40)+          : toEnum (0x80 + (i `div` 0x40) `mod` 0x40)+          : toEnum (0x80 + i `mod` 0x40)+          : rest+          )++-- perform char quotation according to original Perl 5 quotemeta+-- have to return a string because of the quote, this requires+-- concat in quotemeta above.+toQuoteMeta :: Char -> String+toQuoteMeta c =+   if not (isLatin1 c) -- Ignore Unicode characters beyond the 256-th+      || isAsciiUpper c || isAsciiLower c || isDigit c || c == '_'+      then [ c ]+      else [ '\\', c ]+