fizzbuzz in haskell using a simple control structure

fizzbuzz.hs

module Main where

main :: IO ()
main = print $ fb <$> [0..15]

fb :: Int -> String
fb n = fallthrough (show n) concat [ (n `mod` 3 == 0, "Fizz")
                                   , (n `mod` 5 == 0, "Buzz")
                                   ]

fallthrough :: b -> ([a] -> b) -> [(Bool, a)] -> b
fallthrough d f cas = let as = [a | (c, a) <- cas, c]
                      in if null as then d else f as

fizzbuzz_1.hs

module Main where

import Data.Maybe
import Data.Semigroup

main :: IO ()
main = print $ fb <$> [0 .. 15]

fb :: Int -> String
fb n = fallthrough (show n) [(n `mod` 3 == 0, "Fizz"), (n `mod` 5 == 0, "Buzz")]

fallthrough :: Semigroup a => a -> [(Bool, a)] -> a
fallthrough d cas =
  fromMaybe d $ foldr ((<>) . Just) Nothing [a | (c, a) <- cas, c]

fizzbuzz_2.hs

module Main where

main :: IO ()
main = print $ fb <$> [0..15]

fb :: Int -> String
fb n = useRules (show n) [(3, "Fizz"), (5, "Buzz")] where
  useRules d rs = fallthrough d concat [(n `mod` d == 0, s) | (d, s) <- rs]

fallthrough :: b -> ([a] -> b) -> [(Bool, a)] -> b
fallthrough d f cas = let as = [a | (c, a) <- cas, c]
                      in if null as then d else f as

fizzbuzz_3_monadic.hs

module Main where

import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer

main :: IO ()
main = print $ fb <$> [0..15]

fb :: Int -> String
fb n = execFb $ do
  conditionally (n `mod` 3 == 0) "fizz"
  conditionally (n `mod` 5 == 0) "buzz"
  defaultTo (show n)


type Fb = WriterT String (State Bool)

execFb :: Fb a -> String
execFb m = evalState (execWriterT m) False

conditionally :: Bool -> String -> Fb ()
conditionally True s = do tell s
                          lift $ put True
conditionally False _ = return ()

defaultTo :: String -> Fb ()
defaultTo s = do b <- lift get
                 when (not b) $
                   tell s

fizzbuzz_4_deep_dsl.hs

module Main where

main :: IO ()
main = print $ fb <$> [0..15]

fb :: Int -> String
fb n = useRules $ c 3 "Fizz"
                $ c 5 "Buzz"
                $ d (show n) where
  useRules = ($ False)
  c d s k b | n `mod` d == 0 = s ++ k True
            | otherwise      = k b
  d _ True  = ""
  d s False = s

fizzbuzz_5_monoidal.hs

module Main where

import Control.Monad
import Control.Monad.Trans.Cont
import Data.Functor.Identity

main :: IO ()
main = print $ fb <$> [0..15]

fb :: Int -> String
fb n = run [ conditionally (n `mod` 3 == 0) "fizz"
           , conditionally (n `mod` 5 == 0) "buzz"
           , whenBlank (show n)
           ]


newtype Fb = Fb { runFb :: Bool -> (Bool, String) }

instance Monoid Fb where
  mempty = Fb $ \b -> (b, "")
  Fb f1 `mappend` Fb f2 = Fb $ \b -> let (b', s1) = f1 b
                                         (b'', s2) = f2 (b || b')
                                     in  (b' || b'', s1 ++ s2)

run :: [Fb] -> String
run = snd . flip runFb False . mconcat

conditionally :: Bool -> String -> Fb
conditionally b s = Fb $ \_ -> (b, if b then s else "")

whenBlank :: String -> Fb
whenBlank s = Fb $ \b -> (True, if b then "" else s)

fizzbuzz_6_monoidal_optimized.hs

module Main where

import Control.Monad
import Control.Monad.Trans.Cont
import Data.Functor.Identity

main :: IO ()
main = print $ fb <$> [0..15]

fb :: Int -> String
fb n = run [ conditionally (n `mod` 3 == 0) "fizz"
           , conditionally (n `mod` 5 == 0) "buzz"
           , whenBlank (show n)
           ]


data S = S !Bool !String

newtype Fb = Fb { runFb :: Bool -> S }

instance Monoid Fb where
  {-# INLINE mempty #-}
  mempty = Fb $ \b -> S b ""

  {-# INLINE mappend #-}
  Fb f1 `mappend` Fb f2 = Fb $ \b -> let S b' s1 = f1 b
                                         S b'' s2 = f2 b'
                                     in  S b'' (s1 ++ s2)

{-# INLINE run #-}
run :: [Fb] -> String
run fbs = let S _ res = runFb (mconcat fbs) False
          in  res

{-# INLINE conditionally #-}
conditionally :: Bool -> String -> Fb
conditionally c s = Fb $ \b -> S (b || c) (if c then s else "")

{-# INLINE whenBlank #-}
whenBlank :: String -> Fb
whenBlank s = Fb $ \b -> S True (if b then "" else s)