Extract code blocks from Haddocks doc comments and compile them

CheckHaddocksPrograms.hs

#!/usr/bin/env stack
{-
    stack --resolver=lts-13.3 script
        --package Glob
        --package process
        --package temporary
-}

{-# OPTIONS_GHC -Wall -Werror #-}

module Main (main) where

import           Data.List (groupBy)
import           Data.Traversable (for)
import           System.Exit (exitFailure, exitSuccess)
import           System.FilePath.Glob (glob)
import           System.IO (hClose, hPutStr)
import           System.IO.Error (tryIOError)
import           System.IO.Temp (withSystemTempFile)
import           System.Process (callProcess)
import           Text.Printf (printf)

data Line = Code String | Ignore deriving Show

sourceDirs :: [FilePath]
sourceDirs = ["lib"]

packages :: [String]
packages = ["base", "containers", "oset"]

newtype AnsiColour = AnsiColour Int

ansiGreen :: AnsiColour
ansiGreen = AnsiColour 32

ansiYellow :: AnsiColour
ansiYellow = AnsiColour 33

ansiCyan :: AnsiColour
ansiCyan = AnsiColour 36

inColour :: AnsiColour -> String -> String
inColour (AnsiColour colour) message = printf "\x1b[%dm%s\x1b[0m" colour message

isCode :: Line -> Bool
isCode (Code _) = True
isCode _ = False

parseLine :: String -> Line
parseLine ">" = Code ""
parseLine ('>' : ' ' : rest) = Code rest
parseLine _ = Ignore

codeBlocks :: String -> [String]
codeBlocks s =
    map
        (\ls -> unlines (map (\(Code l) -> l) ls))
        (filter
            (\ls -> case ls of (Code _ : _) -> True; _ -> False)
            (groupBy
                (\x y -> isCode x == isCode y)
                (map parseLine (lines s))))

getCodeBlocks :: FilePath -> IO [String]
getCodeBlocks fileName = codeBlocks <$> readFile fileName

checkCodeBlock :: String -> IO Bool
checkCodeBlock codeBlock = withSystemTempFile "haddocks-program.hs" $ \path h -> do
    hPutStr h codeBlock
    hClose h
    let args =
                [ "ghc"
                , "--"
                , "-fno-code"
                , path
                , "-hide-all-packages"
                ] ++ concatMap (\p -> ["-package", p]) packages
    result <- tryIOError (callProcess "stack" args)
    case result of
        Left _ -> do
            putStrLn $ inColour ansiYellow "Offending code block\nvvvvv"
            putStrLn $ inColour ansiCyan codeBlock
            putStrLn $ inColour ansiYellow "^^^^^\nOffending code block"
            pure False
        Right _ -> do
            putStrLn $ inColour ansiGreen "Code block compiled successfully"
            pure True

main :: IO ()
main = do
    fileNames <- mconcat (map (glob . (++ "/**/*.hs")) sourceDirs)
    allCodeBlocks <- concat <$> sequence (map getCodeBlocks fileNames)
    results <- for allCodeBlocks checkCodeBlock
    if and results
        then exitSuccess
        else exitFailure