RecursiveDo.hs

{-# LANGUAGE RecursiveDo #-}
-- From https://ocharles.org.uk/blog/posts/2014-12-09-recursive-do.html

import Control.Monad.Fix

data RoseTree a = RoseTree a [RoseTree a]
  deriving (Show)

exampleTree :: RoseTree Int
exampleTree = RoseTree 5 [RoseTree 4 [], RoseTree 6 []]

pureMax :: Ord a => RoseTree a -> RoseTree (a, a)
pureMax tree =
  let (t, largest) = go largest tree
  in t
 where
  go :: Ord a => a -> RoseTree a -> (RoseTree (a, a), a)
  go biggest (RoseTree x []) = (RoseTree (x, biggest) [], x)
  go biggest (RoseTree x xs) =
      let sub = map (go biggest) xs
          (xs', largests) = unzip sub
      in (RoseTree (x, biggest) xs', max x (maximum largests))

t = pureMax exampleTree

-- ---------------------------------------------------------------------

impureMin :: (MonadFix m, Ord b) => (a -> m b) -> RoseTree a -> m (RoseTree (a, b))
impureMin f tree = do
  rec (t, largest) <- go largest tree
  return t
 where
  go smallest (RoseTree x []) = do
    b <- f x
    return (RoseTree (x, smallest) [], b)

  go smallest (RoseTree x xs) = do
    sub <- mapM (go smallest) xs
    b <- f x
    let (xs', bs) = unzip sub
    return (RoseTree (x, smallest) xs', min b (minimum bs))

budget :: String -> IO Int
budget "Ada"      = return 10 -- A struggling startup programmer
budget "Curry"    = return 50 -- A big-earner in finance
budget "Dijkstra" = return 20 -- Teaching is the real reward
budget "Howard"   = return 5  -- An frugile undergraduate!

inviteTree = RoseTree "Ada" [ RoseTree "Dijkstra" []
                            , RoseTree "Curry" [ RoseTree "Howard" []]
                            ]

ti = impureMin budget inviteTree