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 AbsoluteSeek i 
               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 AbsoluteSeek i 
                                       hGetChar h
                    return (readi h)
readfilei name = do h <- openFile name ReadMode
                    let readi i = do hSeek h AbsoluteSeek i
                                     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

Haskell - чистый язык[edit]

Что такое монада?[edit]

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

Нотация '>>=' и 'do'[edit]

Mutable data (references, arrays, hash tables...)[edit]

IO actions as values[edit]

Example: a list of IO actions[edit]

Example: returning an IO action as a result[edit]

Example: a memory allocator generator[edit]

Example: emulating OOP with record types[edit]

Dark side of IO monad[edit]

unsafePerformIO[edit]

inlinePerformIO[edit]

unsafeInterleaveIO[edit]

Welcome to the machine: the actual GHC implementation[edit]

The Yhc/nhc98 implementation[edit]

Further reading[edit]

To-do list[edit]