Knuth's algorithm M that produces mixed-radix numbers
Below is a more idiomatic to Haskell version that still follows your original imperative logic. I know elsewhere on SO you have been shown how to do this efficiently and functionally. I did this to show what could be done if the design requirements remained in place.

This version is 52 lines long with all of the whitespace you see. The original was 84 lines after whitespace between the functions was added.

The entire takeInput design using State was not needed. As shown, map read . words is sufficient. If you are concerned about poor input then a version could quickly be put in place using reads but without State.

case replaces the if usage. This is more idiomatic in my experience and is still very readable. You get pattern matching along the way too.

Note that nowfill was replaced by newListArray and the entire CountList was discarded as unneeded. If it was valuable then fillArray could still use CountList without the need for nowfill. The entire function could be about two lines if Applicative style was used. But that would definitely veer pretty far from the straight forward imperative style.

visit was updated to move the putStrLn call outside of the recursion and uses a helper function instead of the old if/else style. Again, the same exact logic just using a more idiomatic layout.

The calls to uncurry could be removed if m5 and algorithmM0 took tuples instead of separated arguments. This does lend it a more functional flavor but I did not want to disturb the function types where possible.

There are no cute tricks in this code. It is pretty reasonable for even a beginner level Haskell developer to read and understand I think. A C coder unfamiliar with the language would have more difficulty following this version than the original I suspect.

import Data.Array.IO

type AlgoArray = IOArray Int Int -- allows for experimentation with IOUArray or others

lenarr :: AlgoArray -&gt; IO Int  -- simplified type
lenarr arr = getBounds arr &gt;&gt;= return . snd

fillArray :: [Int] -&gt; IO (AlgoArray, AlgoArray)
fillArray ns = do  -- could be Applicative style: (,) &lt;$&gt; newListArray &lt;*&gt; newArray
    x &lt;- newListArray (0, lcount) (2:ns)
    y &lt;- newArray (0, lcount) 0
    return (x, y)
    where
      lcount = length ns

visit :: AlgoArray -&gt; Int -&gt; IO ()
visit x i = lenarr x &gt;&gt;= visit' x i &gt;&gt; putStrLn ""
    where
      visit' x i c
        | i &gt; c     = return ()
        | otherwise = readArray x i &gt;&gt;= putStr . show &gt;&gt; visit' x (i + 1) c

maj :: AlgoArray -&gt; AlgoArray -&gt; Int -&gt; IO (AlgoArray, Int)
maj m a j = do
    valaj &lt;- readArray a j
    valmj &lt;- readArray m j
    maj' valaj valmj
    where
      maj' valaj valmj
        | valaj == (valmj - 1) = writeArray a j 0 &gt;&gt; maj m a (j - 1)
        | otherwise            = return (a, j)

m5 :: AlgoArray -&gt; Int -&gt; IO (AlgoArray, Int)
m5 a 0 = return (a, 0)
m5 a j = readArray a j &gt;&gt;= writeArray a j . (+1) &gt;&gt; return (a, j)

algorithmM0 :: AlgoArray -&gt; AlgoArray -&gt; IO ()
algorithmM0 m a = do
    visit a 1
    v &lt;- lenarr m &gt;&gt;= maj m a &gt;&gt;= uncurry m5
    case v of
      (_, 0)  -&gt; return ()
      (a', _) -&gt; algorithmM0 m a'

algorithmM :: IO ()
algorithmM = getLine &gt;&gt;= fillArray . takeInput &gt;&gt;= uncurry algorithmM0
    where
      takeInput = map read . words

main :: IO ()
main = algorithmM