Sudoku parser in Haskell

sudoku-parser.hs

#!/usr/bin/env stack
{-
stack script
    --resolver lts-11.9
    --package array
-}
-- Not really required, but make some stuff more concise to write
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}

import Control.Applicative
import Control.Monad (forM_, void, when)
import qualified Data.Array as A
import Data.Array (Array, (!), bounds, listArray, range)

-- | Wrap a digit.
newtype Digit =
  MkDigit Char
  deriving (Eq, Ord, Show)

-- | A 'Sudoku' is a quadratic array of digits and holes.
-- The first dimension of the indices ranges over the rows.
newtype Sudoku =
  MkSudoku (Array (Int, Int) (Maybe Digit))

-- | A 'Parser' consumes part of a character stream and returns the result
-- and the leftover stream.
-- Parsing may fail. If that happens, no characters are consumed.
newtype Parser a = MkParser
  { runParser :: String -> Maybe (a, String)
  }

instance Functor Parser where
  fmap f p =
    MkParser $ \str ->
      case runParser p str of
        Nothing -> Nothing
        Just (a, leftover) -> Just (f a, leftover)

instance Applicative Parser where
  -- Return 'a' and consume nothing.
  pure a = MkParser $ Just . (a, )
  fP <*> p =
    MkParser $ \str -> do
      (f, afterFp) <- runParser fP str
      (a, afterP) <- runParser p afterFp
      return (f a, afterP)

instance Alternative Parser where
  empty = MkParser (const Nothing)
  -- Utilize the 'Applicative' instance of 'Maybe'
  p1 <|> p2 = MkParser $ \str -> runParser p1 str <|> runParser p2 str

-- | Returns the first character of a string if it matches the given predicate.
satisfies :: (Char -> Bool) -> Parser Char
satisfies pred =
  MkParser $ \case
    (c:cs)
      | pred c -> Just (c, cs)
    _ -> Nothing

-- | Consume the specified character from the beginning of the string.
char :: Char -> Parser ()
char c = void $ satisfies (== c)

-- | Consume the first character of a string if it is one of the specified ones.
oneOf :: [Char] -> Parser Char
oneOf cs = satisfies (`elem` cs)

-- | @times n p@ parses @p@ exactly @n@ times.
-- It operates recursively and is probably not efficient for large @n@.
times :: Int -> Parser a -> Parser [a]
times 0 _ = pure []
times n p = (:) <$> p <*> times (n - 1) p

-- | Parse a single digit.
digitParser :: Parser (Maybe Digit)
digitParser = char '0' *> pure Nothing <|> Just . MkDigit <$> oneOf ['1' .. '9']

-- | Parse a single row of a sudoku field, optionally preceded by newlines.
rowParser :: Parser [Maybe Digit]
rowParser = many (char '\n') *> times 9 digitParser

-- | Parses a full sudoku, which is composed of nine rows.
sudokuParser :: Parser Sudoku
sudokuParser =
  MkSudoku . listArray ((0, 0), (8, 8)) . concat <$> times 9 rowParser

{- | Feed it something like this:
> 123456789
> 456789123
> 789123456
> 234567891
> 567891234
> 891234567
> 345678912
> 678912345
> 912345678
-}
main :: IO ()
main = do
  maybeSudoku <- runParser sudokuParser <$> getContents
  case maybeSudoku of
    Nothing -> putStrLn "No parse"

    Just (MkSudoku sudoku, _leftover) -> do
      let bs@(_height, width) = snd (bounds sudoku)

      forM_ (range ((0, 0), bs)) $ \pos@(_, x) -> do
        putStr " "
        case sudoku ! pos of
          Nothing -> putChar ' '
          Just (MkDigit c) -> putChar c
        when (x == width) $ putChar '\n'