Original article
Haskell by Example

Hello World

1
main = putStrLn "hello world"
hello world

Values

1
2
3
4
5
6
7
8
main = do
    putStrLn $ "haskell " ++ "lang"
    putStrLn $ "1+1 = " ++ show (1+1)
    putStrLn $ "7.0/3.0 = " ++ show (7.0/3.0)

    print $ True && False
    print $ True || False
    print $ not True
haskell lang
1+1 = 2
7.0/3.0 = 2.3333333333333335
False
True
False

Variables

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
main = do
    let a = "initial"
    putStrLn a

    let b = 1
    let c = 2
    print b >> print c

    let d = True
    print d

    let e = undefined :: Int
    print e

    let f = "short"
    putStrLn f
initial
1
2
True
file_tempfile_62oDrL_rand-7865_pid-21741.hs: Prelude.undefined
CallStack (from HasCallStack):
  error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err
  undefined, called at /tmp/file_tempfile_62oDrL_rand-7865_pid-21741.hs:14:13 in main:Main

Constants

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
s :: String
s = "constant"

main = do
    putStrLn s

    let n = 500000000
    let d = 3e20 / n

    print d
    print $ sin n
constant
6.0e11
-0.28470407323754404
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
forM_ = flip mapM_

import Control.Monad.Cont

main = do
    forM_ [1..3] $ \i -> do
        print i

    forM_ [7..9] $ \j -> do
        print j

    withBreak $ \break ->
        forM_ [1..] $ \_ -> do
            p "loop"
            break ()

    where
    withBreak = (`runContT` return) . callCC
    p = liftIO . putStrLn

/tmp/file_tempfile_aTG70O_rand-23181_pid-26192.hs:5:1: error:
    parse error on input β€˜import’
  |
5 | import Control.Monad.Cont
  | ^^^^^^

If/Else

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
main = do
    if 7 `mod` 2 == 0
        then putStrLn "7 is even"
        else putStrLn "7 is odd"

    if 8 `mod` 4 == 0
        then putStrLn "8 is divisible by 4"
        else return ()

    let num = 9
    putStrLn $
        if num < 0
            then show num ++ " is negative"
            else if num < 10
                then show num ++ " has 1 digit"
                else show num ++ " has multiple digits"
7 is odd
8 is divisible by 4
9 has 1 digit

Switch

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
import Data.Time
import Data.Time.Calendar.WeekDate

main = do
    let i = 2
    putStr $ "write " ++ show i ++ " as "
    case i of
        1 -> putStrLn "one"
        2 -> putStrLn "two"
        3 -> putStrLn "three"

    now <- getCurrentTime
    let (_, _, week) = toWeekDate . utctDay $ now
    putStrLn $
        case week of
            6 -> "it's the weekend"
            7 -> "it's the weekend"
            _ -> "it's a weekday"

    localtime <- utcToLocalZonedTime now
    let hour = todHour . localTimeOfDay . zonedTimeToLocalTime $ localtime
    case hour of
        _
            | hour < 12 -> putStrLn "it's before noon"
            | otherwise -> putStrLn "it's after noon"
write 2 as two
it's a weekday
it's before noon

Arrays

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
import Data.Array

main = do
    let a = array (0, 4) [(i, 0) | i <- [0..4]]
    putStrLn $ "emp: " ++ show a

    let a' = a // [(4,100)]
    putStrLn $ "set: " ++ show a'
    putStrLn $ "get: " ++ show (a' ! 4)
    putStrLn $ "len: " ++ show ((+1) . snd . bounds $ a')

    let b = array (0, 4) [(i, i+1) | i <- [0..4]]
    putStrLn $ "dcl: " ++ show b

    let twoD = array ((0,0), (1, 2)) [((i, j), i + j) | i <- [0..1], j <- [0..2]]
    putStrLn $ "2d: " ++ show twoD
emp: array (0,4) [(0,0),(1,0),(2,0),(3,0),(4,0)]
set: array (0,4) [(0,0),(1,0),(2,0),(3,0),(4,100)]
get: 100
len: 5
dcl: array (0,4) [(0,1),(1,2),(2,3),(3,4),(4,5)]
2d: array ((0,0),(1,2)) [((0,0),0),((0,1),1),((0,2),2),((1,0),1),((1,1),2),((1,2),3)]

Slices

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
main = do
    let s = [] :: [String]
    putStrLn $ "emp: " ++ show s

    let s' = ["a", "b", "c"]
    putStrLn $ "set: " ++ show s'
    putStrLn $ "get: " ++ s' !! 2
    putStrLn $ "len: " ++ show (length s')

    let s2 = s' ++ ["d"]
    let s3 = s2 ++ ["d", "f"]
    putStrLn $ "apd: " ++ show s3

    let c = s3
    putStrLn $ "cpy: " ++ show c

    let l1 = drop 2 . take 5 $ s3
    putStrLn $ "sl1: " ++ show l1

    let l2 = take 5 s3
    putStrLn $ "sl2: " ++ show l2

    let l3 = drop 2 s3
    putStrLn $ "sl3: " ++ show l3

    let t = ["g", "h", "i"]
    putStrLn $ "dcl: " ++ show t

    let twoD = [[i + j | j <- [0..i]] | i <- [0..2]]
    putStrLn $ "2d: " ++ show twoD
emp: []
set: ["a","b","c"]
get: c
len: 3
apd: ["a","b","c","d","d","f"]
cpy: ["a","b","c","d","d","f"]
sl1: ["c","d","d"]
sl2: ["a","b","c","d","d"]
sl3: ["c","d","d","f"]
dcl: ["g","h","i"]
2d: [[0],[1,2],[2,3,4]]

Maps

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
import Data.Map (Map, (!))
import qualified Data.Map as Map

main = do
    let m0 = Map.empty
    let m1 = Map.insert "k1" 7 m0
    let m  = Map.insert "k2" 13 m1
    putStrLn $ "map: " ++ show m

    let v1 = m ! "k1"
    putStrLn $ "v1: " ++ show v1
    putStrLn $ "len: " ++ show (Map.size m)

    let m' = Map.delete "k2" m
    putStrLn $ "map: " ++ show m'

    let prs = Map.lookup "k2" m'
    putStrLn $ "prs: " ++ show prs

    let n = Map.fromList [("foo", 1), ("bar", 2)]
    putStrLn $ "map: " ++ show n
map: fromList [("k1",7),("k2",13)]
v1: 7
len: 2
map: fromList [("k1",7)]
prs: Nothing
map: fromList [("bar",2),("foo",1)]

Range

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map

main = do
    let nums = [2, 3, 4]
    putStrLn $ "sum: " ++ show (sum nums)

    mapM_ putStrLn ["index: " ++ show i | (i, num) <- zip [0..] nums, num == 3]

    let kvs = Map.fromList [("a", "apple"), ("b", "banana")]
    forM_ (Map.toList kvs) $ \(k, v) -> putStrLn $ k ++ " -> " ++ v

    mapM_ print $ zip [0..] "haskell"
sum: 9
index: 1
a -> apple
b -> banana
(0,'h')
(1,'a')
(2,'s')
(3,'k')
(4,'e')
(5,'l')
(6,'l')

Functions

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
plus :: Int -> Int -> Int
plus = (+)

plusPlus :: Int -> Int -> Int -> Int
plusPlus a b c = a + b + c

main = do
    let res = plus 1 2
    putStrLn $ "1+2 = " ++ show res

    let res = plusPlus 1 2 3
    putStrLn $ "1+2+3 = " ++ show res
1+2 = 3
1+2+3 = 6

Multiple return values

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
vals :: () -> (Int, Int)
vals () = (3, 7)

main = do
    let (a, b) = vals ()
    print a
    print b

    let (_, c) = vals ()
    print c
3
7
7

Variadic functions

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
sum' :: [Int] -> IO ()
sum' xs = do
    putStr $ show xs ++ " "
    print $ sum xs

main = do
    sum' [1, 2]
    sum' [1, 2, 3]

    let nums = [1, 2, 3, 4]
    sum' nums
[1,2] 3
[1,2,3] 6
[1,2,3,4] 10

Closures

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
import Data.IORef

intSeq :: IORef Int -> IO Int
intSeq ref = do
    modifyIORef ref (+1)
    readIORef ref

main = do
    ref <- newIORef 0
    let nextInt = intSeq ref

    print =<< nextInt
    print =<< nextInt
    print =<< nextInt

    ref' <- newIORef 0
    let newInts = intSeq ref'
    print =<< newInts
1
2
3
1

Recursion

1
2
3
4
5
fact :: Int -> Int
fact 0 = 1
fact n = n * fact (n-1)

main = print $ fact 7
5040

Structs

  • Structs are records in haskell
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
data Person = Person { name :: String
                     , age :: Int
                     } deriving Show

main = do
    print $ Person "Bob" 20
    print $ Person {name = "Alice", age = 30}
    -- print $ Person {name = "Fred"}
    print $ Person {name = "Ann", age = 40}

    let s = Person {name = "Sean", age = 50}
    putStrLn $ name s
    print $ age s

    let s' = s {age = 51}
    print $ age s'

Methods

Just use functions.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
data Rect = Rect Int Int

area :: Rect -> Int
area (Rect w h) = w * h

perim :: Rect -> Int
perim (Rect w h) = 2 * w + 2 * h

main = do
    let r = Rect 10 5
    putStrLn $ "area: " ++ show (area r)
    putStrLn $ "perim: " ++ show (perim r)

Interfaces

  • Use Type Classes and Class Methods.
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
class Geometry g where
    area :: g -> Double
    perim :: g -> Double

data Square = Square Double Double deriving Show
data Circle = Circle Double deriving Show

instance Geometry Square where
    area (Square w h)  = w * h
    perim (Square w h) = 2 * w + 2 * h

instance Geometry Circle where
    area (Circle r) = pi * r * r
    perim (Circle r) = 2 * pi * r

measure :: (Geometry a, Show a) => a -> IO ()
measure g = do
    print g
    print $ area g
    print $ perim g

main = do
    let s = Square 3 4
    let c = Circle 5

    measure s
    measure c

Errors

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
import Control.Monad

f1 :: Int -> Either String Int
f1 arg = if arg == 42
             then Left "can't work with 42"
             else Right (arg + 3)

data ArgError = ArgError Int String

instance Show ArgError where
    show (ArgError arg err) = show arg ++ " - " ++ err

f2 :: Int -> Either ArgError Int
f2 arg = if arg == 42
             then Left (ArgError arg "can't work with it")
             else Right (arg + 3)

main = do
    forM_ [7, 42] $ \i -> do
        case f1 i of
            Left error -> putStrLn $ "f1 failed: " ++ error
            Right value -> putStrLn $ "f1 worked: " ++ show value

    forM_ [7, 42] $ \i -> do
        case f2 i of
            Left err -> putStrLn $ "f2 failed: " ++ show err
            Right value -> putStrLn $ "f2 worked: " ++ show value
    case f2 42 of
        Left (ArgError arg err) -> do
            print arg
            putStrLn err
        _ -> return ()
f1 worked: 10
f1 failed: can't work with 42
f2 worked: 10
f2 failed: 42 - can't work with it
42
can't work with it

goroutines

  • Use forkIO. It is a common way to use concurrency in Haskell.
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
import Control.Monad
import Control.Concurrent

f :: String -> IO ()
f from = forM_ [0..2] (\i -> putStrLn $ from ++ ":" ++ show i)

main = do
    f "direct"
    forkIO $ f "forkIO"
    forkIO $ (\msg -> putStrLn msg) "going"

    getLine
    putStrLn "done"

asciinema recording

Channels

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
import Control.Concurrent
import Control.Concurrent.STM

main = do
    messages <- atomically newTQueue

    forkIO $ atomically $ writeTQueue messages "ping"

    msg <- atomically $ readTQueue messages
    putStrLn msg
ping

Channel Buffering

  • You can treat TQueue as an unbounded FIFO channel.
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
import Control.Concurrent.STM

main = do
    messages <- atomically $ do
        msg <- newTQueue
        writeTQueue msg "buffered"
        writeTQueue msg "queue"
        return msg

    putStrLn =<< (atomically . readTQueue) messages
    putStrLn =<< (atomically . readTQueue) messages
buffered
queue

Channel synchronisation

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
import Control.Concurrent
import Control.Concurrent.STM

worker :: TMVar Bool -> IO ()
worker done = do
    putStr "working..."
    threadDelay 1000000

    putStrLn "done"
    atomically $ putTMVar done True

main = do
    done <- atomically newEmptyTMVar
    forkIO $ worker done

    atomically $ takeTMVar done
    return ()
working...done

Channel directions

See also privileged-concurrency.

http://hackage.haskell.org/package/privileged-concurrency

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
import Control.Concurrent.STM

ping :: WriteOnly w => w String -> String -> IO ()
ping pings msg = write' pings msg

pong :: (ReadOnly r, WriteOnly w) => r String -> w String -> IO ()
pong pings pongs = do
    msg <- read' pings
    write' pongs msg

main = do
    pings <- atomically newTQueue
    pongs <- atomically newTQueue
    ping pings "passed message"
    pong pings pongs
    putStrLn =<< read' pongs

class ReadOnly f where
    read' :: f a -> IO a
instance ReadOnly TQueue where
    read' = atomically . readTQueue

class WriteOnly f where
    write' :: f a -> a ->  IO ()
instance WriteOnly TQueue where
    write' = (atomically.) . writeTQueue
passed message

Select

Actually, there is no select statement in Haskell. I implement a makeshift “select” in this example. If you have a better idea, please send a Pull Request to my repository!

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
{-# LANGUAGE GADTs #-}
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM

main = do
    c1 <- atomically newTQueue
    c2 <- atomically newTQueue

    forkIO $ do
        threadDelay (1 * 1000000)
        atomically $ writeTQueue c1 "one"

    forkIO $ do
        threadDelay (2 * 1000000)
        atomically $ writeTQueue c2 "two"

    forM_ [0..1] $ \i ->
        select [ Case c1 $ \msg1 -> putStrLn $ "received " ++ msg1
               , Case c2 $ \msg2 -> putStrLn $ "received " ++ msg2
               ]

class Selectable f where
    tryRead :: f a -> STM (Maybe a)

instance Selectable TQueue where
    tryRead = tryReadTQueue

data Select a where
    Default :: IO a -> Select a
    Case    :: Selectable s => s b -> (b -> IO a) -> Select a

select :: [Select a] -> IO a
select [] = error "select: empty list"
select ((Default x):_) = x
select (x@(Case v f):xs)  = do
    var <- atomically $ tryRead v
    case var of
        Just b  -> f b
        Nothing -> select (xs ++ [x])
received one
received two

Timeouts

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
{-# LANGUAGE GADTs #-}
import Control.Concurrent
import Control.Concurrent.STM

main = do
    c1 <- atomically $ newTQueue
    forkIO $ do
        threadDelay (2 * 1000000)
        atomically $ writeTQueue c1 "result 1"

    t1 <- newTimer (1 * 1000000)
    select [ Case c1 $ \res -> putStrLn res
           , Case t1 $ \_   -> putStrLn "timeout 1"]

    c2 <- atomically $ newTQueue
    forkIO $ do
        threadDelay (2 * 1000000)
        atomically $ writeTQueue c2 "result 2"

    t2 <- newTimer (3 * 1000000)
    select [ Case c2 $ \res -> putStrLn res
           , Case t2 $ \_   -> putStrLn "timeout 2"]

type Timer = TMVar ()

newTimer :: Int -> IO Timer
newTimer delay = do
    timer <- atomically newEmptyTMVar
    forkIO $ do
        threadDelay delay
        atomically $ putTMVar timer ()
    return timer

class Selectable f where
    tryRead :: f a -> STM (Maybe a)

instance Selectable TMVar where
    tryRead = tryReadTMVar

instance Selectable TQueue where
    tryRead = tryReadTQueue

data Select a where
    Default :: IO a -> Select a
    Case    :: Selectable s => s b -> (b -> IO a) -> Select a

select :: [Select a] -> IO a
select [] = error "select: empty list"
select ((Default x):_) = x
select (x@(Case v f):xs)  = do
    var <- atomically $ tryRead v
    case var of
        Just b  -> f b
        Nothing -> select (xs ++ [x])
timeout 1
result 2

Non-Blocking Channel Operations

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
{-# LANGUAGE GADTs #-}
import Control.Concurrent
import Control.Concurrent.STM

main = do
    messages <- atomically $ newEmptyTMVar :: IO (TMVar String)
    signals  <- atomically $ newEmptyTMVar :: IO (TMVar Bool)

    trymsg <- atomically $ tryReadTMVar messages
    case trymsg of
        Just m -> putStrLn $ "received message " ++ m
        Nothing -> putStrLn "no message received"

    let msg = "hi"
    success <- atomically $ tryPutTMVar messages msg
    if success
        then putStrLn $ "sent message " ++ msg
        else putStrLn "no message sent"

    select [ Case messages $ \msg -> putStrLn $ "received message " ++ msg
           , Case signals  $ \sig -> putStrLn $ "received signal " ++ show sig
           , Default $ putStrLn "no activiry"
           ]

class Selectable f where
    tryRead :: f a -> STM (Maybe a)

instance Selectable TMVar where
    tryRead = tryReadTMVar

data Select a where
    Default :: IO a -> Select a
    Case    :: Selectable s => s b -> (b -> IO a) -> Select a

select :: [Select a] -> IO a
select [] = error "select: empty list"
select ((Default x):_) = x
select (x@(Case v f):xs)  = do
    var <- atomically $ tryRead v
    case var of
        Just b  -> f b
        Nothing -> select (xs ++ [x])
no message received
sent message hi
received message hi

Timers

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
import Control.Concurrent
import Control.Concurrent.STM

main = do
    timer1 <- newTimer (2 * 1000000)
    waitTimer timer1
    putStrLn "Timer 1 expired"

    timer2 <- newTimer (1 * 1000000)
    forkIO $ do
        waitTimer timer2
        putStrLn "Timer 2 expired"
    stopTimer timer2
    putStrLn "Timer 2 stopped"

data State = Start | Stop
type Timer = (TVar State, TMVar ())

waitTimer :: Timer -> IO ()
waitTimer (_, timer) = atomically $ readTMVar timer

stopTimer :: Timer -> IO ()
stopTimer (state, _) = atomically $ writeTVar state Stop

newTimer :: Int -> IO Timer
newTimer n = do
    state <- atomically $ newTVar Start
    timer <- atomically $ newEmptyTMVar
    forkIO $ do
        threadDelay n
        atomically $ do
            runState <- readTVar state
            case runState of
                Start -> putTMVar timer ()
                Stop  -> return ()
    return (state, timer)
Timer 1 expired
Timer 2 stopped

Tickers

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
import Control.Concurrent
import Control.Monad.IO.Class
import Data.Time
import Data.IORef
import System.IO.Streams (InputStream, makeOutputStream, fromGenerator, connect)
import qualified System.IO.Streams as Streams

main = do
    ticker <- newTicker (500 * 1000)
    output <- makeOutputStream $ \m -> case m of
                  Just now -> print now
                  Nothing  -> return ()
    forkIO $ (snd ticker) `connect` output

    threadDelay (1500 * 1000)
    stopTicker ticker
    putStrLn "Ticker stopped"

data State  = Start | Stop
type Ticker = (IORef State, InputStream UTCTime)

newTicker :: Int -> IO Ticker
newTicker delay = do
    state  <- newIORef Start
    stream <- fromGenerator (gen state)
    return (state, stream)
    where
    gen state = do
        runState <- liftIO $ readIORef state
        case runState of
            Start -> do
                now <- liftIO getCurrentTime
                Streams.yield now
                liftIO $ threadDelay delay
                gen state
            Stop -> return ()

stopTicker :: Ticker -> IO ()
stopTicker (state, _) = writeIORef state Stop
2020-06-11 02:25:42.711083178 UTC
2020-06-11 02:25:43.213333594 UTC
2020-06-11 02:25:43.716132831 UTC
Ticker stopped

Worker pools

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM

worker :: Int -> TQueue Int -> TQueue Int -> MVar () -> IO ()
worker n jobs results lock = forever $ do
    j <- atomically $ readTQueue jobs
    withMVar lock $ \_ -> do
        putStrLn $ "worker " ++ show n ++ " processing job " ++ show j
    threadDelay (1 * 1000000)
    atomically $ writeTQueue results (2 * j)

main = do
    jobs <- atomically $ newTQueue
    results <- atomically $ newTQueue
    lock <- newMVar ()

    forM_ [1..3] $ \w -> do
        forkIO $ worker w jobs results lock

    forM_ [1..9] $ atomically . writeTQueue jobs
    forM_ [1..9] $ \_ -> atomically $ readTQueue results
worker 1 processing job 1
worker 2 processing job 2
worker 3 processing job 3
worker 1 processing job 4
worker 3 processing job 5
worker 2 processing job 6
worker 1 processing job 7
worker 3 processing job 8
worker 2 processing job 9

Rate limiting

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
import Data.Time
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM

main = do
    requests <- atomically $ do
        req <- newTQueue
        mapM_ (writeTQueue req) [1..5]
        return req

    limitter <- atomically $ newEmptyTMVar
    forkIO . forever $ do
        atomically $ putTMVar limitter ()
        threadDelay (200 * 1000)

    let loop1 = do
        req <- atomically $ do
            r <- readTQueue requests
            takeTMVar limitter
            return r
        now <- getCurrentTime
        putStrLn $ "request " ++ show req ++ " " ++ show now
        isEmpty <- atomically $ isEmptyTQueue requests
        if isEmpty
            then return ()
            else loop1
    loop1

    now <- getCurrentTime
    burstyLimitter <- atomically $ do
        limitter <- newTBQueue 3
        forM_ [0..2] $ \_ -> writeTBQueue limitter now
        return limitter

    forkIO . forever $ do
        now <- getCurrentTime
        atomically $ writeTBQueue burstyLimitter now
        threadDelay (200 * 1000)

    burstyRequests <- atomically $ do
        req <- newTQueue
        mapM_ (writeTQueue req) [1..5]
        return req

    let loop2 = do
        req <- atomically $ do
            r <- readTQueue burstyRequests
            readTBQueue burstyLimitter
            return r
        now <- getCurrentTime
        putStrLn $ "request " ++ show req ++ " " ++ show now
        isEmpty <- atomically $ isEmptyTQueue burstyRequests
        if isEmpty
            then return ()
            else loop2
    loop2
request 1 2020-06-11 02:26:25.24928217 UTC
request 2 2020-06-11 02:26:25.450402353 UTC
request 3 2020-06-11 02:26:25.65148357 UTC
request 4 2020-06-11 02:26:25.852578274 UTC
request 5 2020-06-11 02:26:26.052870473 UTC
request 1 2020-06-11 02:26:26.053095141 UTC
request 2 2020-06-11 02:26:26.053286259 UTC
request 3 2020-06-11 02:26:26.053388452 UTC
request 4 2020-06-11 02:26:26.053489202 UTC
request 5 2020-06-11 02:26:26.253451221 UTC

Atomic counter

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM

main = do
    ops <- atomically $ newTVar 0
    forM_ [0..49] $ \_ -> do
        forkIO . forever $ do
            atomically $ modifyTVar ops (+1)
            threadDelay 100

    threadDelay 1000000
    opsFinal <- atomically $ readTVar ops
    putStrLn $ "ops: " ++ show opsFinal
ops: 43673

Mutexes

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import Data.Maybe
import qualified Data.Map as Map
import System.Random

main = do
    state <- atomically $ newTVar Map.empty
    ops   <- atomically $ newTVar 0

    forM_ [0..99] $ \_ -> do
        total <- atomically $ newTVar 0
        forkIO . forever $ do
            key <- randomRIO (0, 4) :: IO Int
            atomically $ do
                s <- readTVar state
                writeTVar state s
                let v = maybe 0 id $ Map.lookup key s
                modifyTVar total (+v)
                modifyTVar ops (+1)

    forM_ [0..9] $ \_ -> do
        forkIO . forever $ do
            key <- randomRIO (0, 4) :: IO Int
            val <- randomRIO (0, 99) :: IO Int
            atomically $ do
                modifyTVar state (Map.insert key val)
                modifyTVar ops (+1)

    threadDelay 1000000
    opsFinal <- atomically $ readTVar ops
    putStrLn $ "ops: " ++ show opsFinal

    s <- atomically $ readTVar state
    putStrLn $ "state: " ++ show s
ops: 373344
state: fromList [(0,10),(1,64),(2,13),(3,46),(4,26)]

Stateful goroutines

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
{-# LANGUAGE GADTs #-}
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import System.Random
import Data.IORef
import qualified Data.Map as Map

data ReadOp = ReadOp { readKey  :: Int
                     , readResp :: MVar Int
                     }

data WriteOp = WriteOp { writeKey  :: Int
                       , writeVal  :: Int
                       , writeResp :: MVar Bool
                       }

main = do
    ops <- atomically $ newTVar 0

    reads  <- newEmptyMVar
    writes <- newEmptyMVar

    forkIO $ do
        state <- newIORef Map.empty
        forever $ do
            select [ Case reads  $ \read  -> do
                        s <- readIORef state
                        let val = maybe 0 id $ Map.lookup (readKey read) s
                        putMVar (readResp read) val
                   , Case writes $ \write -> do
                        modifyIORef state (Map.insert (writeKey write) (writeVal write))
                        putMVar (writeResp write) True
                   ]

    forM_ [0..99] $ \_ -> do
        forkIO . forever $ do
            key  <- randomRIO (0,4)
            resp <- newEmptyMVar
            let read = ReadOp { readKey = key, readResp = resp }
            putMVar reads read
            takeMVar resp

            atomically $ do
                x <- readTVar ops
                writeTVar ops (x + 1)

    forM_ [0..9] $ \_ -> do
        forkIO . forever $ do
            key  <- randomRIO (0,4)
            val  <- randomRIO (0,99)
            resp <- newEmptyMVar
            let write = WriteOp { writeKey = key, writeVal = val, writeResp = resp }
            putMVar writes write
            takeMVar resp

            atomically $ do
                x <- readTVar ops
                writeTVar ops (x + 1)

    threadDelay 1000000

    opsFinal <- atomically $ readTVar ops
    putStrLn $ "ops: " ++ show opsFinal

data Select a where
    Default :: IO a -> Select a
    Case    :: MVar b -> (b -> IO a) -> Select a

select :: [Select a] -> IO a
select [] = error "select: empty list"
select ((Default x):_) = x
select (x@(Case v f):xs)  = do
    var <- tryTakeMVar v
    case var of
        Just b  -> f b
        Nothing -> select (xs ++ [x])
ops: 6411

Sorting

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
import Data.List

main = do
    let strs = "cab"
    putStrLn $ "Strings: " ++ sort strs

    let ints = [7, 2, 4]
    putStrLn $ "Ints: " ++ show (sort ints)

    let s = ints == sort ints
    putStrLn $ "Sorted: " ++ show s
Strings: abc
Ints: [2,4,7]
Sorted: False

Sorting by function

1
2
3
4
5
6
import Data.List
import Data.Function

main = do
    let fruits = ["peach", "banana", "kiwi"]
    print $ sortBy (compare `on` length) fruits
["kiwi","peach","banana"]

Panic

1
main = error "a problem"
file_tempfile_9ssS58_rand-23749_pid-10383.hs: a problem
CallStack (from HasCallStack):
  error, called at /tmp/file_tempfile_9ssS58_rand-23749_pid-10383.hs:3:8 in main:Main

Defer

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
import Control.Exception
import System.IO
import System.IO.Error

main = bracket (createFile "/tmp/defer.txt") closeFile writeFile'

createFile :: FilePath -> IO Handle
createFile path = do
    putStrLn "creating"
    openFile path WriteMode `catch` (error . ioeGetErrorString)

writeFile' :: Handle -> IO ()
writeFile' handle = do
    putStrLn "writing"
    hPutStr handle "data"

closeFile :: Handle -> IO ()
closeFile handle = do
    putStrLn "closing"
    hClose handle
creating
writing
closing

Collection functions

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
import Data.List
import Data.Char

main = do
    let strs = ["peach", "apple", "pear", "plum"]

    print $ lookup "pear" (zip strs [0..])
    print $ elem "grape" strs
    print $ any (isPrefixOf "p") strs
    print $ all (isPrefixOf "p") strs
    print $ filter (elem 'e') strs
    print $ map (map toUpper) strs
Just 2
False
True
False
["peach","apple","pear"]
["PEACH","APPLE","PEAR","PLUM"]

String functions

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
import Data.List
import Data.Char

include :: String -> String -> Bool
include xs ys = or . map (isPrefixOf ys) . tails $ xs

joinWith :: [String] -> String -> String
joinWith xs sep = concat . init . concat $ [[x, sep] | x <- xs]

split :: String -> Char -> [String]
split "" _ = []
split xs c = let (ys, zs) = break (== c) xs
             in  if null zs then [ys] else ys : split (tail zs) c

main = do
    putStrLn $ "Contains:  " ++ show ("test" `include` "es")
    putStrLn $ "Count:     " ++ show (length . filter (=='t') $ "test")
    putStrLn $ "HasPrefix: " ++ show (isPrefixOf "te" "test")
    putStrLn $ "HasSuffix: " ++ show (isSuffixOf "st" "test")
    putStrLn $ "Index:     " ++ show (elemIndex 'e' "test")
    putStrLn $ "Join:      " ++ show (["a", "b"] `joinWith` "-")
    putStrLn $ "Repeat:    " ++ show (replicate 5 'a')
    putStrLn $ "Replace:   " ++ show (map (\x -> if x == 'o' then '0' else x) "foo")
    putStrLn $ "Split:     " ++ show (split "a-b-c-d-e" '-')
    putStrLn $ "ToLower:   " ++ map toLower "TEST"
    putStrLn $ "ToUpper:   " ++ map toUpper "test"
    putStrLn ""
    putStrLn $ "Len: " ++ show (length "hello")
    putStrLn $ "Char:" ++ show ("hello" !! 1)
Contains:  True
Count:     2
HasPrefix: True
HasSuffix: True
Index:     Just 1
Join:      "a-b"
Repeat:    "aaaaa"
Replace:   "f00"
Split:     ["a","b","c","d","e"]
ToLower:   test
ToUpper:   TEST

Len: 5
Char:'e'

String formatting

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
{-# LANGUAGE OverloadedStrings #-}
import Data.Char (chr)
import System.IO
import Formatting

data Point = Point { x :: Int
                   , y :: Int
                   } deriving Show

main = do
    let p = Point 1 2

    fprint (shown%"\n") p
    fprint (shown%"\n") True
    fprint (int%"\n") 123
    fprint (bin%"\n") 14
    fprint (char%"\n") $ chr 33
    fprint (hex%"\n") 456
    fprint (float%"\n") 78.9
    fprint ((expt 4)%"\n") 123400000.0
    fprint (text%"\n") "string"
    fprint (shown%"\n") "string"
    fprint ("|"%(left 6 ' ')%"|"%(left 6 ' ')%"|\n") (12 :: Int) (345 :: Int)
    fprint ("|"%(prec 5)%"|"%(prec 5)%"|\n") (1.2 :: Double) (3.45 :: Double)
    fprint ("|"%(left 6 ' ')%"|"%(left 6 ' ')%"|\n") ("foo" :: String) ("b" :: String)
    fprint ("|"%(right 6 ' ')%"|"%(right 6 ' ')%"|\n") ("foo" :: String) ("b" :: String)

    let s = format ("a "%string) "string"
    print s

    hPrint stderr $ format ("an "%string) "error"

/tmp/file_tempfile_vXFJVR_rand-15447_pid-17089.hs:22:14: error:
    β€’ Variable not in scope:
        expt :: Integer -> Format (IO ()) (Double -> IO a0)
    β€’ Perhaps you meant β€˜exp’ (imported from Prelude)
   |
22 |     fprint ((expt 4)%"\n") 123400000.0
   |              ^^^^

/tmp/file_tempfile_vXFJVR_rand-15447_pid-17089.hs:26:18: error:
    β€’ Variable not in scope:
        prec :: Integer -> Format r0 (Double -> Double -> IO a1)
    β€’ Perhaps you meant β€˜pred’ (imported from Prelude)
   |
26 |     fprint ("|"%(prec 5)%"|"%(prec 5)%"|\n") (1.2 :: Double) (3.45 :: Double)
   |                  ^^^^

/tmp/file_tempfile_vXFJVR_rand-15447_pid-17089.hs:26:31: error:
    β€’ Variable not in scope: prec :: Integer -> Format (IO ()) r0
    β€’ Perhaps you meant β€˜pred’ (imported from Prelude)
   |
26 |     fprint ("|"%(prec 5)%"|"%(prec 5)%"|\n") (1.2 :: Double) (3.45 :: Double)
   |                               ^^^^

Regular expressions

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
import Data.Array
import Text.Regex
import Text.Regex.Base

main = do
    let mch = matchTest (mkRegex "p([a-z]+)ch") "peach"
    print mch

    let r = mkRegex "p([a-z]+)ch"

    -- MatchString
    print $ matchTest r "peach"

    -- FindString
    putStrLn $ fst . (!0) . head $ matchAllText r "peach punch"

    -- FindStringIndex
    print $ snd . (!0) . head $ matchAllText r "peach punch"

    -- FindStringSubmatch
    print $ map fst . elems . head $ matchAllText r "peach punch"

    -- FindStringSubmatchIndex
    print $ map snd . elems . head $ matchAllText r "peach punch"

    -- FindAllString
    print $ map (fst . head . elems) $ matchAllText r "peach punch pinch"

    -- FindAllStringSubmatchIndex
    print $ map (map snd . elems) $ matchAllText r "peach punch pinch"

    -- FindAllString (2)
    print $ take 2 . map (fst . head . elems) $ matchAllText r "peach punch pinch"

    -- ReplaceAllString
    putStrLn $ subRegex r "a peach" "<fruit>"
True
True
peach
(0,5)
["peach","ea"]
[(0,5),(1,2)]
["peach","punch","pinch"]
[[(0,5),(1,2)],[(6,5),(7,2)],[(12,5),(13,2)]]
["peach","punch"]
a <fruit>

JSON

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
import GHC.Generics
import Control.Lens
import Data.Aeson
import Data.Aeson.Lens
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy.Char8 as BS

data Response1 = Response1 { page :: Int
                           , fruits :: [String]
                           } deriving (Show, Generic)
instance FromJSON Response1
instance ToJSON Response1

main = do
    BS.putStrLn $ encode True
    BS.putStrLn $ encode (1 :: Int)
    BS.putStrLn $ encode (2.34 :: Double)
    BS.putStrLn $ encode ("haskell" :: String)
    BS.putStrLn $ encode (["apple", "peach", "pear"] :: [String])
    BS.putStrLn $ encode $ Map.fromList ([("apple", 5), ("lettuce", 7)] :: [(String, Int)])
    BS.putStrLn $ encode $ Response1 {page = 1, fruits = ["apple", "peach", "pear"]}

    let byt = "{\"num\":6.13,\"strs\":[\"a\",\"b\"]}"
    let Just dat = decode byt :: Maybe Value
    print dat
    let Just num = dat ^? key "num"
    print num
    let Just str1 = dat ^? key "strs" . nth 0
    print str1

    let str = "{\"page\": 1, \"fruits\": [\"apple\", \"peach\"]}"
    let Just res = decode str :: Maybe Response1
    print res
    putStrLn $ (fruits res) !! 0
true
1
2.34
"haskell"
["apple","peach","pear"]
{"apple":5,"lettuce":7}
{"fruits":["apple","peach","pear"],"page":1}
Object (fromList [("num",Number 6.13),("strs",Array [String "a",String "b"])])
Number 6.13
String "a"
Response1 {page = 1, fruits = ["apple","peach"]}
apple

Time

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
import Data.Time
import Data.Time.Calendar.WeekDate

main = do
    now <- getCurrentTime
    print now

    let next = UTCTime { utctDay = fromGregorian 2009 11 17
                       , utctDayTime = timeOfDayToTime (TimeOfDay 20 34 58.651387237)
                       }
    print next

    let (year, month, day) = toGregorian . utctDay $ next
    print year
    print month
    print day
    let hour = todHour . timeToTimeOfDay . utctDayTime $ next
    let minute = todMin . timeToTimeOfDay . utctDayTime $ next
    let (second, nano) = properFraction . todSec . timeToTimeOfDay . utctDayTime $ next
    let (_, _, week) = toWeekDate . utctDay $ next
    print hour
    print minute
    print second
    print nano
    print week

    print $ next < now
    print $ next > now
    print $ next == now
2020-06-11 04:21:33.288764027 UTC
2009-11-17 20:34:58.651387237 UTC
2009
11
17
20
34
58
0.651387237000
2
True
False
False

Epoch

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
import Data.Time
import Data.Time.Calendar.WeekDate

main = do
    now <- getCurrentTime
    print now

    let next = UTCTime { utctDay = fromGregorian 2009 11 17
                       , utctDayTime = timeOfDayToTime (TimeOfDay 20 34 58.651387237)
                       }
    print next

    let (year, month, day) = toGregorian . utctDay $ next
    print year
    print month
    print day
    let hour = todHour . timeToTimeOfDay . utctDayTime $ next
    let minute = todMin . timeToTimeOfDay . utctDayTime $ next
    let (second, nano) = properFraction . todSec . timeToTimeOfDay . utctDayTime $ next
    let (_, _, week) = toWeekDate . utctDay $ next
    print hour
    print minute
    print second
    print nano
    print week

    print $ next < now
    print $ next > now
    print $ next == now
2020-06-11 04:21:45.171768283 UTC
2009-11-17 20:34:58.651387237 UTC
2009
11
17
20
34
58
0.651387237000
2
True
False
False

Time formatting / parsing

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
import Data.Time
import System.Locale

main = do
    let rfc3339like = "%FT%T%z"

    t <- getZonedTime
    putStrLn $ formatTime defaultTimeLocale rfc3339like t

    print $ (parseTime defaultTimeLocale rfc3339like "2012-11-01T22:08:41+00:00" :: Maybe ZonedTime)

    putStrLn $ formatTime defaultTimeLocale "%-l:%M%p" t
    putStrLn $ formatTime defaultTimeLocale "%a %b %-e %X %Y" t
    putStrLn $ formatTime defaultTimeLocale "%FT%T.%q%z" t

    let form = "%-l %M %p"
    print $ (parseTime defaultTimeLocale form "8 41 PM" :: Maybe UTCTime)

    let ansic = "%a %b %-e %X %Y"
    print $ (parseTime defaultTimeLocale form "8:41PM" :: Maybe UTCTime)

/tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:10:27: error:
    Ambiguous occurrence β€˜defaultTimeLocale’
    It could refer to either β€˜Data.Time.defaultTimeLocale’,
                             imported from β€˜Data.Time’ at /tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:3:1-16
                             (and originally defined in β€˜time-1.8.0.2:Data.Time.Format.Locale’)
                          or β€˜System.Locale.defaultTimeLocale’,
                             imported from β€˜System.Locale’ at /tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:4:1-20
   |
10 |     putStrLn $ formatTime defaultTimeLocale rfc3339like t
   |                           ^^^^^^^^^^^^^^^^^

/tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:12:24: error:
    Ambiguous occurrence β€˜defaultTimeLocale’
    It could refer to either β€˜Data.Time.defaultTimeLocale’,
                             imported from β€˜Data.Time’ at /tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:3:1-16
                             (and originally defined in β€˜time-1.8.0.2:Data.Time.Format.Locale’)
                          or β€˜System.Locale.defaultTimeLocale’,
                             imported from β€˜System.Locale’ at /tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:4:1-20
   |
12 |     print $ (parseTime defaultTimeLocale rfc3339like "2012-11-01T22:08:41+00:00" :: Maybe ZonedTime)
   |                        ^^^^^^^^^^^^^^^^^

/tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:14:27: error:
    Ambiguous occurrence β€˜defaultTimeLocale’
    It could refer to either β€˜Data.Time.defaultTimeLocale’,
                             imported from β€˜Data.Time’ at /tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:3:1-16
                             (and originally defined in β€˜time-1.8.0.2:Data.Time.Format.Locale’)
                          or β€˜System.Locale.defaultTimeLocale’,
                             imported from β€˜System.Locale’ at /tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:4:1-20
   |
14 |     putStrLn $ formatTime defaultTimeLocale "%-l:%M%p" t
   |                           ^^^^^^^^^^^^^^^^^

/tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:15:27: error:
    Ambiguous occurrence β€˜defaultTimeLocale’
    It could refer to either β€˜Data.Time.defaultTimeLocale’,
                             imported from β€˜Data.Time’ at /tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:3:1-16
                             (and originally defined in β€˜time-1.8.0.2:Data.Time.Format.Locale’)
                          or β€˜System.Locale.defaultTimeLocale’,
                             imported from β€˜System.Locale’ at /tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:4:1-20
   |
15 |     putStrLn $ formatTime defaultTimeLocale "%a %b %-e %X %Y" t
   |                           ^^^^^^^^^^^^^^^^^

/tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:16:27: error:
    Ambiguous occurrence β€˜defaultTimeLocale’
    It could refer to either β€˜Data.Time.defaultTimeLocale’,
                             imported from β€˜Data.Time’ at /tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:3:1-16
                             (and originally defined in β€˜time-1.8.0.2:Data.Time.Format.Locale’)
                          or β€˜System.Locale.defaultTimeLocale’,
                             imported from β€˜System.Locale’ at /tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:4:1-20
   |
16 |     putStrLn $ formatTime defaultTimeLocale "%FT%T.%q%z" t
   |                           ^^^^^^^^^^^^^^^^^

/tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:19:24: error:
    Ambiguous occurrence β€˜defaultTimeLocale’
    It could refer to either β€˜Data.Time.defaultTimeLocale’,
                             imported from β€˜Data.Time’ at /tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:3:1-16
                             (and originally defined in β€˜time-1.8.0.2:Data.Time.Format.Locale’)
                          or β€˜System.Locale.defaultTimeLocale’,
                             imported from β€˜System.Locale’ at /tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:4:1-20
   |
19 |     print $ (parseTime defaultTimeLocale form "8 41 PM" :: Maybe UTCTime)
   |                        ^^^^^^^^^^^^^^^^^

/tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:22:24: error:
    Ambiguous occurrence β€˜defaultTimeLocale’
    It could refer to either β€˜Data.Time.defaultTimeLocale’,
                             imported from β€˜Data.Time’ at /tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:3:1-16
                             (and originally defined in β€˜time-1.8.0.2:Data.Time.Format.Locale’)
                          or β€˜System.Locale.defaultTimeLocale’,
                             imported from β€˜System.Locale’ at /tmp/file_tempfile_HnZHXP_rand-32429_pid-2482.hs:4:1-20
   |
22 |     print $ (parseTime defaultTimeLocale form "8:41PM" :: Maybe UTCTime)
   |                        ^^^^^^^^^^^^^^^^^

Random numbers

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
import System.Random

main = do
    putStr . show =<< randomRIO (0, 100 :: Int)
    putStr ", "
    print         =<< randomRIO (0, 100 :: Int)

    print =<< (randomIO :: IO Float)

    f1 <- randomIO :: IO Float
    putStr $ show (f1 * 5 + 5) ++ ", "
    f2 <- randomIO :: IO Float
    print  $ f2 * 5 + 5

    let s1 = mkStdGen 42
    let (i1, s2) = randomR (0, 100 :: Int) s1
    let (i2,  _) = randomR (0, 100 :: Int) s2
    putStrLn $ show i1 ++ ", " ++ show i2

    let s3 = mkStdGen 42
    let (i3, s4) = randomR (0, 100 :: Int) s3
    let (i4,  _) = randomR (0, 100 :: Int) s4
    putStrLn $ show i3 ++ ", " ++ show i4
30, 54
0.3052525
8.599604, 8.112543
77, 38
77, 38

Number parsing

1
2
3
4
5
main = do
    print (read "1.234" :: Double)
    print (read "123"   :: Int)
    print (read "0x1c8" :: Int)
    print (read "wat"   :: Int)
1.234
123
456
file_tempfile_LEVelw_rand-14323_pid-2048.hs: Prelude.read: no parse

URL Parsing

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
import Network.URI

main = do
    let s = "postgres://user:pass@host.com:5432/path?k=v#f"
    case parseURI s of
        Nothing  -> error "no URI"
        Just uri -> do
            putStrLn $ uriScheme uri
            case uriAuthority uri of
                Nothing   -> error "no Authority"
                Just auth -> do
                    putStrLn $ uriUserInfo auth
                    putStrLn $ uriRegName auth
                    putStrLn $ uriPort auth
            putStrLn $ uriPath uri
            putStrLn $ uriFragment uri
            putStrLn $ uriQuery uri
postgres:
user:pass@
host.com
:5432
/path
#f
?k=v

SHA1 hashes

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
{-# LANGUAGE OverloadedStrings #-}
import Numeric (showHex)
import qualified Data.ByteString as BS
import qualified Crypto.Hash.SHA1 as SHA1

main = do
    let s = "sha1 this string"
    let bs = SHA1.hash s

    print s
    putStrLn $ concatMap (flip showHex "") $ BS.unpack bs

/tmp/file_tempfile_NQ9WzM_rand-7102_pid-30704.hs:10:14: error:
    Not in scope: β€˜SHA1.hash’
    Module β€˜Crypto.Hash.SHA1’ does not export β€˜hash’.
   |
10 |     let bs = SHA1.hash s
   |              ^^^^^^^^^

Base64 encoding

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
{-# LANGUAGE OverloadedStrings #-}
import Data.ByteString.Base64

main = do
    let dat = "abc123!?$*&()'-=@~"
    let sEnc = encode dat
    print sEnc

    let sDec = decode sEnc
    print sDec
"YWJjMTIzIT8kKiYoKSctPUB+"
Right "abc123!?$*&()'-=@~"

Reading files

1
2
echo "hello" > /tmp/dat
echo "haskell" >>   /tmp/dat
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
import System.IO

readAtLeast :: Handle -> Integer -> IO String
readAtLeast handle n
    | n <= 0 = return ""
    | otherwise = do
        eof <- hIsEOF handle
        if eof
            then return ""
            else do
              c <- hGetChar handle
              str <- readAtLeast handle (n-1)
              return (c:str)

main = do
    dat <- readFile "/tmp/dat"
    putStrLn dat

    handle <- openFile "/tmp/dat" ReadMode

    b1 <- readAtLeast handle 5
    putStrLn $ show (length b1) ++ " bytes: " ++ b1

    hSeek handle AbsoluteSeek 6
    at2 <- hTell handle
    b2  <- sequence . take 7 . repeat $ hGetChar handle
    putStrLn $ show (length b2) ++ " bytes @ " ++ show at2 ++  ": " ++ b2

    hSeek handle AbsoluteSeek 6
    at3 <- hTell handle
    b3  <- readAtLeast handle 7
    putStrLn $ show (length b3) ++ " bytes @ " ++ show at3 ++  ": " ++ b3

    hSeek handle AbsoluteSeek 0
    hSetBuffering handle (BlockBuffering Nothing) -- default
    b3 <- readAtLeast handle 5
    putStrLn $ show (length b3) ++ " bytes: " ++ b3

    hClose handle
hello
haskell

5 bytes: hello
7 bytes @ 6: haskell
7 bytes @ 6: haskell
5 bytes: hello

Writing files

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
import Foreign.Marshal.Array
import Control.Exception
import Data.Int
import System.IO

main = do
    let d1 = "hello\nhaskell\n"
    writeFile "/tmp/dat1" d1

    bracket (openBinaryFile "/tmp/dat2" WriteMode)
            (\handle -> hClose handle)
            $ \handle -> do
                let d2 = [115, 111, 109, 101, 10] :: [Int8]
                p <- newArray d2
                hPutBuf handle p (length d2)
                putStrLn $ "wrote " ++ show (length d2) ++ " bytes"

                hPutStr handle "writes\n"
                putStrLn "wrote 7 bytes"

                hSetBuffering handle (BlockBuffering Nothing) -- default
                hPutStr handle "buffered\n"
                putStrLn "wrote 9 bytes"
                hFlush handle
wrote 5 bytes
wrote 7 bytes
wrote 9 bytes
1
2
3
cat /tmp/dat1
echo
cat /tmp/dat2
hello
haskell

some
writes
buffered

Line filters

1
2
echo 'hello'
echo 'filter'

hello
filter
1
2
3
import Data.Char

main = interact $ fmap toUpper
HELLO
FILTER

Command-line arguments

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
import System.Environment

main = do
    args <- getArgs
    let arg = args !! 3

    print args
    putStrLn arg

    progName <- getProgName
    putStrLn progName
["/tmp/babel-ZVlBg0/generic-jKfEk7","a","b","c","d"]
c
file_tempfile_0cmjec_rand-27119_pid-24691.hs

Command-line flags

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
{-# LANGUAGE DataKinds #-}
import Options.Declarative
import Control.Monad.IO.Class (liftIO)

flags :: Flag "" '["word"] "\"foo\"" "a string"     (Def "foo" String)
      -> Flag "" '["numb"] "42"      "an int"       (Def "42" Int)
      -> Flag "" '["fork"] "false"   "a bool"       Bool
      -> Flag "" '["svar"] "\"bar\"" "a string var" (Def "bar" String)
      -> Arg "ARGS" [String]
      -> Cmd "Command-Line Flags" ()
flags word numb fork svar args = do
    liftIO . putStrLn $ "word:" ++ get word
    liftIO . putStrLn $ "numb:" ++ (show . get $ numb)
    liftIO . putStrLn $ "fork:" ++ (show . get $ fork)
    liftIO . putStrLn $ "svar:" ++ get svar
    liftIO . putStrLn $ "tail:" ++ (show . get $ args)

main :: IO ()
main = run_ flags

1
tf hs

/tmp/file_tempfile_qGaEZt_rand-19108_pid-28114.hs

1
babel-script $(cat) --word=opt --numb=7 --fork --svar=flag


/tmp/file_tempfile_xvzSpb_rand-32526_pid-31422.hs:4:1: error:
    Could not find module β€˜Options.Declarative’
    Use -v to see a list of the files searched for.
  |
4 | import Options.Declarative
  | ^^^^^^^^^^^^^^^^^^^^^^^^^^

1
babel-script $(cat) --word=opt


/tmp/file_tempfile_XqbRsl_rand-14068_pid-32525.hs:4:1: error:
    Could not find module β€˜Options.Declarative’
    Use -v to see a list of the files searched for.
  |
4 | import Options.Declarative
  | ^^^^^^^^^^^^^^^^^^^^^^^^^^