ghc/interpreter/test/exts/FixIO.lhs

   1 --!!! Testing IOExts.fixIO
   2
   3 > module FixIOTest where
   4 > import Monad
   5 > import Maybe
   6 > import IOExts( fixIO )
   7
   8 First a recursively-defined environment in the normal way:
   9
  10 > env = foldl (\env' (s,v) -> enter env' s v)
  11 >             empty
  12 >             [ ("f", (1, fst (fromJust (look env "g")))) ,
  13 >               ("g", (2, fst (fromJust (look env "f")))) ]
  14
  15 > env2 = let vF = (1, fst (fromJust (look env2 "g")))
  16 >            vG = (2, fst (fromJust (look env2 "f")))
  17 >        in enter (enter empty "f" vF) "g" vG
  18
  19 Which yields these correct evaluations:
  20   look env' "f"  ==>  (1,2)
  21   look env' "g"  ==>  (2,1)
  22
  23 Now let's add some IO to each "store action" and use foldM/fixIO to
  24 tie it all together:
  25
  26 > main =
  27 >   do env <- fixIO (\env -> do
  28 >               foldM (\env' (s,vM) -> do v <- vM
  29 >                                         return (enter env' s v))
  30 >                     empty
  31 >                     [ ("f", do putStrLn "storing f"
  32 >                                return (1, fst (fromJust (look env "g")))) ,
  33 >                       ("g", do putStrLn "storing g"
  34 >                                return (2, fst (fromJust (look env "f")))) ] )
  35 >      print (look env "f")
  36 >      print (look env "g")
  37 >      return ()
  38
  39 > main2 =
  40 >   do env <- fixIO (\env -> do
  41 >               let vF = (1,fst (fromJust (look env "g")))
  42 >                   vG = (2,fst (fromJust (look env "f")))
  43 >               putStrLn "storing f and g"
  44 >               return $ enter (enter empty "f" vF) "g" vG
  45 >               )
  46 >      putStrLn "Constructed environment"
  47 >      print env
  48 >      print (look env "f")
  49 >      print (look env "g")
  50 >      return ()
  51
  52 But this unfortunately dies a horrible death:
  53
  54 FixIOTest> main
  55 storing f
  56 storing g
  57 Just (1,
  58 Program error: {_Gc Black Hole}
  59
  60 If I comment out the "print" statements I get:
  61
  62 FixIOTest> main
  63 storing f
  64 storing g
  65
  66 and it terminates properly.
  67
  68 ----------------------------------------------------------------
  69 -- Environments
  70 ----------------------------------------------------------------
  71
  72 > empty  :: Table a
  73 > enter :: Table a -> String -> a -> Table a
  74 > look :: Table a -> String -> Maybe a
  75
  76 ----------------------------------------------------------------
  77 -- A very simple environment implemented as functions:
  78 ----------------------------------------------------------------
  79
  80 > {-
  81 > type Table a = String -> Maybe a
  82 > empty s = Nothing
  83 > enter t s1 x s2 | s1==s2    = Just x
  84 >                 | otherwise = look t s2
  85 > look t s = t s
  86 > -}
  87
  88 ----------------------------------------------------------------
  89 -- A very simple environment implemented using association lists:
  90 ----------------------------------------------------------------
  91
  92 > type Table a = [(String,a)]
  93 > empty = []
  94 > enter t s x = (s,x):t
  95 > look t s = lookup s t
  96
  97