language-puppet-1.3.14: tests/lexer.hs

{-# LANGUAGE LambdaCase #-}
module Main where

import           Control.Monad
import qualified Data.Text.IO                 as T
import           System.Environment
import           System.FilePath.Glob
import           System.IO
import           System.Posix.Terminal
import           System.Posix.Types
import           Text.Megaparsec              (eof, parse, parseErrorPretty)
import           Text.PrettyPrint.ANSI.Leijen

import           Puppet.Parser

allchecks :: IO ()
allchecks = do
    filelist <- globDir1 (compile "*.pp") "tests/lexer"
    testres <- mapM testparser filelist
    let isgood = all snd testres
    mapM_ (\(rr, t) -> unless t (putStrLn rr)) testres
    unless isgood (error "fail")

-- returns errors
testparser :: FilePath -> IO (String, Bool)
testparser fp =
    fmap (parse (puppetParser <* eof) fp) (T.readFile fp) >>= \case
        Right _ -> return ("PASS", True)
        Left rr -> return (parseErrorPretty rr, False)

check :: String -> IO ()
check fname = do
    putStr fname
    putStr ": "
    res <- fmap (parse puppetParser fname) (T.readFile fname)
    is <- queryTerminal (Fd 1)
    let rfunc = if is
                    then renderPretty 0.2 200
                    else renderCompact
    case res of
        Left rr -> putStrLn (parseErrorPretty rr)
        Right x -> do
            putStrLn ""
            displayIO stdout (rfunc (pretty (ppStatements x)))
            putStrLn ""

main :: IO ()
main = do
    args <- getArgs
    if null args
        then allchecks
        else mapM_ check args