{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif
module TestKit
( Vrn(..)
, presentVrn
, parseVrn
, bumpVersion
, substVersion
, substVersion_
, readCurrentVersion
, Test(..)
, runTheTests
, checkThis
, checkThisWith
, convertMaybeTextList
, castInt
, packLBS
, test_pp
, include
, cmp
, dumpMacroTable
, sortImports
, groupSort
, groupSortBy
, read_file
, write_file
) where
import Control.Applicative
import Control.Exception
import qualified Control.Monad as M
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.List as L
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Prelude.Compat
import qualified Shelly as SH
import System.Directory
import System.Environment
import System.Exit
import System.IO
import Text.Printf
import Text.RE.Replace
import Text.RE.TDFA
import Text.RE.TestBench
import Text.RE.Tools.Grep
import Text.RE.Tools.Sed
Vrn and friends
data Vrn = Vrn { _vrn_a, _vrn_b, _vrn_c, _vrn_d :: Int }
deriving (Show,Eq,Ord)
presentVrn :: Vrn -> String
presentVrn Vrn{..} = printf "%d.%d.%d.%d" _vrn_a _vrn_b _vrn_c _vrn_d
parseVrn :: String -> Vrn
parseVrn vrn_s = case matched m of
True -> Vrn (p [cp|a|]) (p [cp|b|]) (p [cp|c|]) (p [cp|d|])
False -> error $ "not a valid version: " ++ vrn_s
where
p c = fromMaybe oops $ parseInteger $ m !$$ c
m = vrn_s ?=~ [re|^${a}(@{%nat})\.${b}(@{%nat})\.${c}(@{%nat})\.${d}(@{%nat})$|]
oops = error "parseVrn"
-- | register a new version of the package
bumpVersion :: String -> IO ()
bumpVersion vrn_s = do
vrn0 <- readCurrentVersion
rex' <- compileRegex $ printf "- \\[[xX]\\].*%d\\.%d\\.%d\\.%d" _vrn_a _vrn_b _vrn_c _vrn_d
nada <- null . linesMatched LinesMatched <$> grepLines rex' "lib/md/roadmap-incl.md"
M.when nada $
error $ vrn_s ++ ": not ticked off in the roadmap"
rex <- compileRegex $ printf "%d\\.%d\\.%d\\.%d" _vrn_a _vrn_b _vrn_c _vrn_d
nope <- null . linesMatched LinesMatched <$> grepLines rex "changelog"
M.when nope $
error $ vrn_s ++ ": not in the changelog"
case vrn > vrn0 of
True -> do
write_current_version vrn
substVersion "lib/hackage-template.svg" "docs/badges/hackage.svg"
False -> error $
printf "version not later ~(%s > %s)" vrn_s $ presentVrn vrn0
where
vrn@Vrn{..} = parseVrn vrn_s
substVersion :: FilePath -> FilePath -> IO ()
substVersion in_f out_f =
LBS.readFile in_f >>= substVersion_ >>= LBS.writeFile out_f
substVersion_ :: (IsRegex RE a,Replace a) => a -> IO a
substVersion_ txt =
flip replaceAll ms . packR . presentVrn <$> readCurrentVersion
where
ms = txt *=~ [re|<<\$version\$>>|]
readCurrentVersion :: IO Vrn
readCurrentVersion = parseVrn . T.unpack <$> T.readFile "lib/version.txt"
write_current_version :: Vrn -> IO ()
write_current_version = writeFile "lib/version.txt" . presentVrn
Test and friends
data Test =
Test
{ testLabel :: String
, testExpected :: String
, testResult :: String
, testPassed :: Bool
}
deriving (Show)
runTheTests :: [Test] -> IO ()
runTheTests tests = do
as <- getArgs
case as of
[] -> return ()
_ -> do
pn <- getProgName
putStrLn $ "usage:\n "++pn++" --help"
exitWith $ ExitFailure 1
case filter (not . testPassed) tests of
[] -> putStrLn $ "All "++show (length tests)++" tests passed."
fts -> do
mapM_ (putStr . present_test) fts
putStrLn $ show (length fts) ++ " tests failed."
exitWith $ ExitFailure 1
checkThis :: (Show a,Eq a) => String -> a -> a -> Test
checkThis = checkThisWith id
checkThisWith :: (Show a,Eq a) => (b->a) -> String -> b -> a -> Test
checkThisWith f lab ref0 val =
Test
{ testLabel = lab
, testExpected = show ref
, testResult = show val
, testPassed = ref == val
}
where
ref = f ref0
convertMaybeTextList :: [Maybe String] -> [Maybe T.Text]
convertMaybeTextList = map $ fmap T.pack
castInt :: Int -> Int
castInt = id
packLBS :: String -> LBS.ByteString
packLBS = LBS.pack
present_test :: Test -> String
present_test Test{..} = unlines
[ "test: " ++ testLabel
, " expected : " ++ testExpected
, " result : " ++ testResult
, " passed : " ++ (if testPassed then "passed" else "**FAILED**")
]
test_pp :: String
-> (FilePath->FilePath->IO())
-> FilePath
-> FilePath
-> IO ()
test_pp lab loop test_file gold_file = do
createDirectoryIfMissing False "tmp"
loop test_file tmp_pth
ok <- cmp (T.pack tmp_pth) (T.pack gold_file)
case ok of
True -> return ()
False -> do
putStrLn $ lab ++ ": mismatch with " ++ gold_file
exitWith $ ExitFailure 1
where
tmp_pth = "tmp/mod.lhs"
simple include processor
-- | this function looks for lines of the form
--
-- `%include <file> [exclude <RE>]`
--
-- and replaces them with the contents of the named file, optionally
-- excluding any lines that match the given RE.
include :: LBS.ByteString -> IO LBS.ByteString
include = sed' $ Select
[ Function [re|^%include ${file}(@{%string})$|] TOP incl
, Function [re|^%include ${file}(@{%string}) *exclude *${rex}(@{%string})$|] TOP incl
, Function [re|^.*$|] TOP nop
]
where
incl _ mtch _ _ = include' mtch
nop _ _ _ _ = return Nothing
-- | processes the match from a '%include' line, analyses the match,
-- fetches the file, optionally excludes lines specified by an RE,
-- returning the text to include.
include' :: Match LBS.ByteString -> IO (Maybe LBS.ByteString)
include' mtch = do
ftr <- case prs_s <$> mtch !$$? [cp|rex|] of
Nothing -> return id
Just re_lbs -> excl <$> makeRegex re_lbs
Just . ftr <$> LBS.readFile (prs_s $ mtch !$$ [cp|file|])
where
excl :: RE -> LBS.ByteString -> LBS.ByteString
excl rex =
LBS.unlines . map (matchesSource . getLineMatches)
. filter (not . anyMatches . getLineMatches)
. grepFilter rex
prs_s = maybe (error "include'") T.unpack . parseString
cmp
cmp :: T.Text -> T.Text -> IO Bool
cmp src dst = handle hdl $ do
_ <- SH.shelly $ SH.verbosely $
SH.run "cmp" [src,dst]
return True
where
hdl :: SomeException -> IO Bool
hdl se = do
hPutStrLn stderr $
"testing results against model answers failed: " ++ show se
return False
dumpMacroTable
-- | dump a MacroEnv into the docs directory
dumpMacroTable :: FilePath
-> FilePath
-> RegexType
-> MacroEnv
-> IO ()
dumpMacroTable fp_t fp_s rty m_env = do
writeFile fp_t $ formatMacroTable rty m_env
writeFile fp_s $ formatMacroSources rty ExclCaptures m_env
sortImports
sortImports :: LBS.ByteString -> LBS.ByteString
sortImports lbs =
LBS.unlines $ map (matchesSource . getLineMatches) $
hdr ++ L.sortBy cMp bdy
where
cMp ln1 ln2 = case (extr ln1,extr ln2) of
(Nothing,Nothing) -> EQ
(Nothing,Just _ ) -> GT
(Just _ ,Nothing) -> LT
(Just x ,Just y) -> compare x y
extr Line{..} = case allMatches getLineMatches of
mtch:_ -> mtch !$$? [cp|mod|]
_ -> Nothing
(hdr,bdy) = span (not . anyMatches . getLineMatches) lns
lns = grepFilter rex lbs
rex = [re|^import +(qualified| ) ${mod}([^ ].*)$|]
groupSort and groupSortBy
-- | Sort a list of elements with a stable sort, grouping together the
-- equal elements with the argument grouping function
groupSort :: (Ord a) => (a->[a]->b) -> [a] -> [b]
groupSort = groupSortBy compare
-- | Sort a list of elements with a stable sort, grouping together the
-- equal elements with the argument grouping function.
groupSortBy :: (a->a->Ordering)
-> (a->[a]->b)
-> [a]
-> [b]
groupSortBy comp grp = aggregate . L.sortBy comp
where
aggregate [] = []
aggregate (h:t) = seq g $ g : aggregate rst
where
g = grp h eqs
(eqs,rst) = span is_le t
is_le x = case comp x h of
LT -> True
EQ -> True
GT -> False
read_file and write_file
read_file :: FilePath -> IO LBS.ByteString
read_file "-" = LBS.getContents
read_file fp = LBS.readFile fp
write_file :: FilePath -> LBS.ByteString ->IO ()
write_file "-" = LBS.putStr
write_file fp = LBS.writeFile fp