some junk from icfp

src/LibJunk/Bits.hs

@@ -0,0 +1,58 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+--
+-- I hate this
+--
+module Bit where
+
+import Data.Int
+import Data.Bits
+import GHC.Exts
+import GHC.Prim
+import GHC.Word
+
+getBits :: Int -> Int -> Int32 -> Int32
+getBits start len op = op' .&. mask
+    where
+      op' = op `shiftR` start
+      mask = (1 `shiftL` len) - 1
+
+composeBytesH :: [Word8] -> Int -> Word32
+composeBytesH [] n = 0
+composeBytesH (h:t) n = (shiftL (fromIntegral (fromEnum h) :: Word32) (8*n)) .|. (composeBytesH t (n+1))
+compBytes :: [Word8] -> Word32
+compBytes b = composeBytesH b 0 --((length b)-1)
+
+composeBytes64H :: [Word8] -> Int -> Word64
+composeBytes64H [] n = 0
+composeBytes64H (h:t) n = (shiftL (fromIntegral (fromEnum h) :: Word64) (8*n)) .|. (composeBytes64H t (n+1))
+compBytes64 :: [Word8] -> Word64
+compBytes64 b = composeBytes64H b 0 --((length b)-1)
+
+
+w64ToDouble :: Word64 -> Double
+w64ToDouble (W64# b#) = D# (unsafeCoerce# b#)
+wordsToDouble :: [Word8] -> Double
+wordsToDouble = w64ToDouble . compBytes64
+
+doubleToW64 :: Double -> Word64
+doubleToW64 (D# d#) = W64# (unsafeCoerce# d#)
+
+getByte :: Bits a => a -> Int -> a
+getByte i b= 255 .&. (shiftR i (8*b))
+_getBytes :: Int32 -> Int -> Int -> [Char]
+_getBytes i n t | n == t = []
+                | otherwise =
+                    (toEnum . fromIntegral $ (getByte i n) :: Char) :
+                      (_getBytes i (n+1) t)
+
+getBytes :: Int32 -> [Char]
+getBytes i = _getBytes i 0 4
+
+_getBytes64 :: Word64 -> Int -> Int -> [Char]
+_getBytes64 i n t | n == t = []
+                  | otherwise =
+     (toEnum (fromIntegral (getByte i n) :: Int) :: Char):
+       (_getBytes64 i (n+1) t)
+
+getBytes64 :: Word64 -> [Char]
+getBytes64 i = _getBytes64 i 0 8

src/LibJunk/IO.hs

@@ -0,0 +1,68 @@
+--
+-- Quasi objects and IO utils
+--
+module IO where
+
+import Data.IORef
+import Control.Monad.State
+import Control.Exception
+
+encapsulateState :: (b -> State s a) -> s -> IO (b -> IO a)
+encapsulateState st init = do
+  ios <- newIORef init
+  return $ \p -> do
+    s <- readIORef ios
+    let (v, s') = runState (st p) s
+    writeIORef ios s'
+    return v
+
+ignoreExns :: IO () -> IO ()
+ignoreExns a = handle h a
+    where
+      h :: SomeException -> IO ()
+      h e = return ()
+
+type Alarm = (Int, IORef Int)
+newAlarm :: Int -> IO Alarm
+newAlarm n = do
+  r <- newIORef 0
+  return (n, r)
+
+bumpAlarm :: Alarm -> IO Bool
+bumpAlarm (max, r) = do
+  v <- readIORef r
+  if v == max then do
+              writeIORef r 0
+              return True
+   else do
+     writeIORef r (v+1)
+     return False
+
+newCounter :: IO (IORef Int)
+newCounter = newIORef (-1)
+
+bumpCounter :: IORef Int -> IO Int
+bumpCounter i = do
+  c <- readIORef i
+  writeIORef i (c+1)
+  return c
+
+newTrashCan :: IO (IORef [a])
+newTrashCan = newIORef []
+
+putItInTheTrash :: IORef [a] -> a -> IO ()
+putItInTheTrash i x = do
+  modifyIORef i (x:)
+
+emptyTheTrash :: IORef [a] -> IO [a]
+emptyTheTrash i = do
+  v <- readIORef i
+  return $ reverse v
+
+
+everyN :: Int -> (a -> IO ()) -> IO (a -> IO ())
+everyN n a = do
+  c <- newAlarm n
+  return $ \v -> do
+               t <- bumpAlarm c
+               if t then a v else return ()

src/LibJunk/Monad.hs

@@ -0,0 +1,18 @@
+--
+-- Control structures mostly
+--
+module Monad where
+
+import Control.Monad
+
+
+doUntil :: Monad m => m Bool -> m ()
+doUntil m = do
+  v <- m
+  if v then doUntil m else return ()
+
+loopM :: Monad m => Int -> (a -> m a) -> a -> m a
+loopM 0 _ v = return v
+loopM n m v = do
+  v' <- m v
+  loopM (n-1) m v'

src/LibJunk/Server.hs

@@ -0,0 +1,15 @@
+module Server(serve) where
+
+import Network
+import LibJunk.IO
+
+serve :: Int -> (Handle -> IO()) -> IO ()
+serve port action = do
+    sock <- listenOn (PortNumber (toEnum port))
+    accept_loop sock action
+
+accept_loop :: Socket -> (Handle -> IO()) -> IO ()
+accept_loop s action = do
+  (h, _, _) <- accept s
+  ignoreExns $ action h
+  accept_loop s serve