haskell代碼片段

-- 一個經典的菲波納契數列的函數定義，求每一個位置上的數值
fib 1 = 1
fib 2 = 1
fib n = fib(n-1) + fib(n-2)

-- 產生一個無限長的fib數列
fib_l n = fib n : fib_l(n+1)

take 10 (fib_l 1) ＝> [1,1,2,3,5,8,13,21,34,55]

--另一個更快解法

fibs = fibgen 1 1 
  where fibgen n1 n2 = n1 : fibgen n2 (n1+n2)

--求解素數的一個無限數列方法：

prime = sieve [2..]
  where sieve (x:xs) = x : sieve (filter (/y ->y `rem` x /= 0) xs)

take 25 prime => [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97]

--對可變（mutable）變量的讀寫

incRef :: IORef Int -> IO ( )

incRef var = do {
   val <- readIORef var
writeIORef var (val+1)
}

--文件操作

 readUtf8File :: FilePath -> IO String 
 readUtf8File filePath 
     = do   h <- openFile filePath ReadMode 
hSetEncoding h utf8 
hSetEncoding stdout utf8 
hGetContents h

   betterStdGen :: IO StdGen
betterStdGen = alloca $ /p -> do
   h <- openBinaryFile "/dev/urandom" ReadMode
   hGetBuf h p $ sizeOf (undefined :: Int)
   hClose h
   mkStdGen <$> peek p

--模擬for循環的函數

nTimes :: Int -> IO () -> IO ()
nTimes 0 do_this = return ()
nTimes n do_this = do {
   do_this;
   nTimes (n-1) do_this;
}

main = nTimes 10 (hPutStr stdout "Hello")  --重複輸出10個"Hello"

-- for(i=0; i<100; i++) {}
   for :: Monad m => a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
for start test step body = loop start where
    loop x = if test x
        then body x >> loop (step x)
        else return ()

main = for 0 (< 100) (+ 1) $ /i -> do
    -- do something with i
    print i

--例外處理

 set_prefs = do
finally 
     (catch (appendFile ".darcs/defaults" "/nALL --ignore-times/n")
            (/e -> fail $ "Unable to set preferences: " ++ show e))
     (createDirectoryIfMissing  False ".darcs")

catchIO :: MonadIO m => IO () -> m ()
catchIO f = liftIO (f `catch` /e -> hPrint stderr e >> hFlush stderr)

spawnPID :: MonadIO m => String -> m ProcessID
spawnPID x = liftIO . forkProcess . finally nullStdin $ do
                uninstallSignalHandlers
                createSession
executeFile "/bin/sh" False ["-c", x] Nothing
 where
    nullStdin = do
        fd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
dupTo fd stdInput
closeFd fd


--如果值有空格就加上引號

> [k ++ "=" ++ c ++ v ++ c | (k,v) <- [("key1","123"),("key2","abc 456")] ,let c = ['/"' | any isSpace v]]
["key1=123","key2=/"abc 456/""]

--轉義

escapeHTML = concatMap f
    where
        f '/"' = "&quot;"
        f '<' = "&lt;"
        f '>' = "&gt;"
        f '&' = "&amp;"
        f '/n' = "<br/>"
        f x = [x]

escapeCGI = concatMap f
    where
        f x | isAlphaNum x || x `elem` "-" = [x]
            | x == ' ' = "+"
            | otherwise = '%' : ['0'|length s == 1] ++ s
            where s = showHex (ord x) ""

--位操作

let w4 = (w32 `shiftR` 24) .&. 0xff
    w3 = (w32 `shiftR` 16) .&. 0xff
    w2 = (w32 `shiftR`  8) .&. 0xff
    w1 =  w32              .&. 0xff

return $! (w4 `shiftL` 24) .|.

          (w3 `shiftL` 16) .|.
          (w2 `shiftL`  8) .|.
          (w1)

--數組操作

   import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed.Mutable as M

replicateM n action = do
  mu <- M.unsafeNew n
  let go !i | i < n = action >>= M.unsafeWrite mu i >> go (i+1)
            | otherwise = G.unsafeFreeze mu
  go 0


--網絡編程

   import System.IO
import Network

main = do
   let a="λ"
   s <- connectTo "127.0.0.1"  (PortNumber 1234)
hSetEncoding s utf8
hSetEncoding  stdout utf8
   hPutStrLn s a
putStrLn a
hClose s

   -- create a write-only socket
    connectTo hostname (PortNumber port) = do
     proto <- getProtocolNumber "tcp"
     bracketOnError
        (socket AF_INET Stream proto)
        (sClose)  -- only done if there's an error
        (/sock -> do
       	  he <- getHostByName hostname
       	  connect sock (SockAddrInet port (hostAddress he))
          socketToHandle sock WriteMode
  	)

--C/S例子

{-# LANGUAGE OverloadedStrings #-}
module Main where

import Control.Concurrent (forkIO)
import Control.Concurrent.MVar

import Control.Monad (forever, liftM)

import Network (listenOn, withSocketsDo, PortID(..))

import Network.BSD (getProtocolNumber)
import Network.Socket (Family(..), SockAddr(..), SocketType(..), Socket(..),
accept, connect, inet_addr, socket, sClose)

import Network.Socket.ByteString

import Data.ByteString.Char8 ()  
import System.Environment (getArgs)    
import System.IO (stdout, hFlush)

port = 8080

main = do

 args <- getArgs 

 if length args < 1 || (head args /= "client" && head args /=
"server")

   then putStrLn "say client or server"    

   else withSocketsDo $ case head args of                 
               "client" -> client    

               "server" -> server   

client = do

putStrLn "Client mode"

 tcp <- getProtocolNumber "tcp"

   forever $ do sock <- socket AF_INET Stream tcp   

            localhost <- inet_addr "127.0.0.1"              
  putStr "Making a connection..."   

            connect sock (SockAddrInet port localhost)              
  send sock "a"    

            _ <- recv sock 1                
sClose sock   

            putStrLn " done client connection"

   

server = do              

    putStrLn "Server mode"   

sock <- listenOn (PortNumber port)

    count <- newMVar 0  

  forever $ do count' <- modifyMVar count (/c -> return (c+1,c+1))              
  putStr $ (show count') ++ " About to accept..."    

            (conn, _saddr) <- accept sock                
putStrLn " accepted."
          hFlush stdout                
forkIO $ handleServerConnection conn count'

           

handleServerConnection conn count = do

putStr $ (show count) ++ " Handling a server connection..."

   rd <- recv conn 1  

  send conn "a"                 

   sClose conn 

  putStrLn " done server connection."

   hFlush stdout

--使用狀態

import Control.Monad.State
import Test.QuickCheck

tThis = take 5 . show .  mybreak (>4000000) $ [1..10^7]
tPrel = take 5 . show .  prelbreak (>4000000) $ [1..10^7]

prelbreak p xs = (takeWhile (not . p) xs,dropWhile (not . p) xs) -- fast, more or less as implemented in prelude

mybreak p xs =  evalState (brk p) ([],xs) -- stateful, slow
brk p = do
      (notsat,remaining) <- get
      case remaining of
        [] -> return (notsat,remaining)
        (r:rs) -> if p r
                    then return (notsat,remaining)
                    else do put (notsat++[r],rs)
                            brk p

From http://blogold.chinaunix.net/u3/104903/showart_2074180.html