Ru/IO Inside

**монадах.**

getchar :: Char

get2chars = [getchar,getchar]

getchar :: Int -> Char

get2chars = [getchar 1, getchar 2]

getchar   :: Int -> Char
get2chars :: Int -> String

get2chars _ = [getchar 1, getchar 2]

getchar :: Int -> (Char, Int)

get2chars _ = [a,b]  where (a,i) = getchar 1
                           (b,_) = getchar i

get2chars i0 = [a,b]  where (a,i1) = getchar i0
                            (b,i2) = getchar i1

get4chars = [get2chars 1, get2chars 2]  -- порядок вызовов 'get2chars' не определён.

get2chars :: Int -> (String, Int)

get4chars i0 = (a++b)  where (a,i1) = get2chars i0
                             (b,i2) = get2chars i1

get2chars :: Int -> (String, Int)
get2chars i0 = ([a,b], i2)  where (a,i1) = getchar i0
                                  (b,i2) = getchar i1

main :: RealWorld -> ((), RealWorld)

type IO a  =  RealWorld -> (a, RealWorld)

getChar :: RealWorld -> (Char, RealWorld)

main :: RealWorld -> ((), RealWorld)
main world0 = let (a, world1) = getChar world0
                  (b, world2) = getChar world1
              in ((), world2)

main = do a <- ask "What is your name?"
          b <- ask "How old are you?"
          return ()

ask s = do putStr s
           readLn

when :: Bool -> IO () -> IO ()
when condition action world =
    if condition
      then action world
      else ((), world)

  main = do putStr "Hello!"

  main = putStr "Hello!"

main = do putStr "What is your name?"
          putStr "How old are you?"
          putStr "Nice day!"

main = (putStr "What is your name?")
       >> ( (putStr "How old are you?")
            >> (putStr "Nice day!")
          )

(>>) :: IO a -> IO b -> IO b
(action1 >> action2) world0 =
   let (a, world1) = action1 world0
       (b, world2) = action2 world1
   in (b, world2)

action1 >> action2 = action
  where
    action world0 = let (a, world1) = action1 world0
                        (b, world2) = action2 world1
                    in (b, world2)

main = do a <- readLn
          print a

main = readLn
       >>= (\a -> print a)

(>>=) :: IO a -> (a -> IO b) -> IO b
(action1 >>= action2) world0 =
   let (a, world1) = action1 world0
       (b, world2) = action2 a world1
   in (b, world2)

main = readLn >>= print

 do x <- action1
    action2

 action1 >>= (\x -> action2)

main = do putStr "What is your name?"
          a <- readLn
          putStr "How old are you?"
          b <- readLn
          print (a,b)

main = putStr "What is your name?"
       >> readLn
       >>= \a -> putStr "How old are you?"
       >> readLn
       >>= \b -> print (a,b)

return :: a -> IO a
return a world0  =  (a, world0)

main = do a <- readLn
          return (a*2)

main = do a <- readLn
          when (a>=0) $ do
              return ()
          print "a is negative"

main = do a <- readLn
          if (a>=0)
            then return ()
            else print "a is negative"

main = do a <- readLn
          if (a>=0) then return ()
            else do
          print "a is negative"
          ...

liftM :: (a -> b) -> (IO a -> IO b)

liftM f action = do x <- action
                    return (f x)

action >>= \x -> return (x+1)

do x <- action
                    return (x+1)

fmap (+1) action

main = do let a0 = readVariable varA
              _  = writeVariable varA 1
              a1 = readVariable varA
          print (a0, a1)

main = do varA <- newIORef 0  -- Create and initialize a new variable
          a0 <- readIORef varA
          writeIORef varA 1
          a1 <- readIORef varA
          print (a0, a1)

 import Data.Array.IO
 main = do arr <- newArray (1,10) 37 :: IO (IOArray Int Int)
           a <- readArray arr 1
           writeArray arr 1 64
           b <- readArray arr 1
           print (a, b)

rand :: IO Int

foreign import ccall
   sin :: Double -> Double

foreign import ccall
   tell :: Int -> IO Int

main world0 = let get2chars = getChar >> getChar
                  ((), world1) = putStr "Press two keys" world0
                  (answer, world2) = get2chars world1
              in ((), world2)

main = do let get2chars = getChar >> getChar
          putStr "Press two keys"
          get2chars
          return ()

ioActions :: [IO ()]
ioActions = [(print "Hello!"),
             (putStr "just kidding"),
             (getChar >> return ())
            ]

ioActions :: [RealWorld -> ((), RealWorld)]

main = do head ioActions
          ioActions !! 1
          last ioActions

sequence_ :: [IO a] -> IO ()
sequence_ [] = return ()
sequence_ (x:xs) = do x
                      sequence_ xs

main = sequence_ ioActions

while :: IO Bool -> IO ()
while action = ???

main = do let a = sequence ioActions
              b = when True getChar
              c = getChar >> getChar
          putStr "These 'let' statements are not executed!"

readi h i = do hSeek h i AbsoluteSeek
               hGetChar h

readfilei :: String -> IO (Integer -> IO Char)
readfilei name = do h <- openFile name ReadMode
                    return (readi h)

readfilei name = do h <- openFile name ReadMode
                    let readi h i = do hSeek h i AbsoluteSeek
                                       hGetChar h
                    return (readi h)

readfilei name = do h <- openFile name ReadMode
                    let readi i = do hSeek h i AbsoluteSeek
                                     hGetChar h
                    return readi

main = do myfile <- readfilei "test"
          a <- myfile 0
          b <- myfile 1
          print (a,b)

memoryAllocator :: Ptr a -> Int -> IO (Int -> IO (Ptr b),
                                       Ptr c -> IO ())

memoryAllocator buf size = do ......
                              let alloc size = do ...
                                                  ...
                                  free ptr = do ...
                                                ...
                              return (alloc, free)

memoryAllocator buf size = do start <- newIORef buf
                              end <- newIORef (buf `plusPtr` size)
                              ...

      ...
      let alloc size = do addr <- readIORef start
                          writeIORef start (addr `plusPtr` size)
                          return addr
                          
      let free ptr = do writeIORef start ptr

main = do buf1 <- mallocBytes (2^16)
          buf2 <- mallocBytes (2^20)
          (alloc1, free1) <- memoryAllocator buf1 (2^16)
          (alloc2, free2) <- memoryAllocator buf2 (2^20)
          ptr11 <- alloc1 100
          ptr21 <- alloc2 1000
          free1 ptr11
          free2 ptr21
          ptr12 <- alloc1 100
          ptr22 <- alloc2 1000

data Figure = Figure { draw :: IO (),
                       move :: Displacement -> IO ()
                     }

type Displacement = (Int, Int)  -- horizontal and vertical displacement in points

circle    :: Point -> Radius -> IO Figure
rectangle :: Point -> Point -> IO Figure

type Point = (Int, Int)  -- point coordinates
type Radius = Int        -- circle radius in points

circle center radius = do
    let description = "  Circle at "++show center++" with radius "++show radius
    return $ Figure { draw = putStrLn description }

rectangle from to = do
    let description = "  Rectangle "++show from++"-"++show to)
    return $ Figure { draw = putStrLn description }

drawAll :: [Figure] -> IO ()
drawAll figures = do putStrLn "Drawing figures:"
                     mapM_ draw figures

main = do figures <- sequence [circle (10,10) 5,
                               circle (20,20) 3,
                               rectangle (10,10) (20,20),
                               rectangle (15,15) (40,40)]
          drawAll figures

circle center radius = do
    centerVar <- newIORef center
    
    let drawF = do center <- readIORef centerVar
                   putStrLn ("  Circle at "++show center
                             ++" with radius "++show radius)
                   
    let moveF (addX,addY) = do (x,y) <- readIORef centerVar
                               writeIORef centerVar (x+addX, y+addY)
                               
    return $ Figure { draw=drawF, move=moveF }

    
rectangle from to = do
    fromVar <- newIORef from
    toVar   <- newIORef to

    let drawF = do from <- readIORef fromVar
                   to   <- readIORef toVar
                   putStrLn ("  Rectangle "++show from++"-"++show to)
                   
    let moveF (addX,addY) = do (fromX,fromY) <- readIORef fromVar
                               (toX,toY)     <- readIORef toVar
                               writeIORef fromVar (fromX+addX, fromY+addY)
                               writeIORef toVar   (toX+addX, toY+addY)

    return $ Figure { draw=drawF, move=moveF }

main = do figures <- sequence [circle (10,10) 5,
                               rectangle (10,10) (20,20)]
          drawAll figures
          mapM_ (\fig -> move fig (10,10)) figures
          drawAll figures

data Figure = Figure { draw :: IO (),
                       move :: Displacement -> IO (),
                       area :: Double,
                       origin :: IORef Point
                     }

readContents :: Filename -> String

unsafePerformIO :: IO a -> a

unsafePerformIO :: (RealWorld -> (a, RealWorld)) -> a
unsafePerformIO action = let (a, world1) = action createNewWorld
                         in a

one :: Int
one = unsafePerformIO $ do var <- newIORef 0
                           modifyIORef var (+1)
                           readIORef var

unsafePerformIO action = let (a,world1) = action createNewWorld
                         in (world1 `seq` a)

-- | Just like unsafePerformIO, but we inline it. Big performance gains as
-- it exposes lots of things to further inlining
{-# INLINE inlinePerformIO #-}
inlinePerformIO action = let (a, world1) = action createNewWorld
                         in (world1 `seq` a)
#endif

write :: Int -> (Ptr Word8 -> IO ()) -> Put ()
write !n body = Put $ \c buf@(Buffer fp o u l) ->
  if n <= l
    then write' c fp o u l
    else write' (flushOld c n fp o u) (newBuffer c n) 0 0 0

  where {-# NOINLINE write' #-}
        write' c !fp !o !u !l =
          -- warning: this is a tad hardcore
          inlinePerformIO
            (withForeignPtr fp
              (\p -> body $! (p `plusPtr` (o+u))))
          `seq` c () (Buffer fp o (u+n) (l-n))

word8 w = write 1 (\p -> poke p w)

do let c = unsafePerformIO getChar
   do_proc c

do let s = [unsafePerformIO getChar, unsafePerformIO getChar, unsafePerformIO getChar]
   do_proc s

do str <- unsafeInterleaveIO myGetContents

myGetContents = do
   c <- getChar
   s <- unsafeInterleaveIO myGetContents
   return (c:s)

myGetContents = do
   c <- replicateM 512 getChar
   s <- unsafeInterleaveIO myGetContents
   return (c++s)

newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))

data World = World
newtype IO a = IO (World -> Either IOError a)

Ru/IO Inside

Contents

Haskell - чистый язык

Что такое монада?

Добро пожаловать в Реальный мир, детка :)

Нотация '>>=' и 'do'

Mutable data (references, arrays, hash tables...)

IO actions as values

Example: a list of IO actions

Example: returning an IO action as a result

Example: a memory allocator generator

Example: emulating OOP with record types

Dark side of IO monad

unsafePerformIO

inlinePerformIO

unsafeInterleaveIO

Welcome to the machine: the actual GHC implementation

The Yhc/nhc98 implementation

Further reading

To-do list

Navigation menu

Search