\begin{code} {-# 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 \end{code} Vrn and friends --------------- \begin{code} 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 \end{code} Test and friends ---------------- \begin{code} 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**") ] \end{code} \begin{code} 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" \end{code} simple include processor ------------------------ \begin{code} -- | this function looks for lines of the form -- -- `%include [exclude ]` -- -- 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 \end{code} cmp --- \begin{code} 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 \end{code} dumpMacroTable -------------- \begin{code} -- | 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 \end{code} sortImports ----------- \begin{code} 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}([^ ].*)$|] \end{code} groupSort and groupSortBy ------------------------- \begin{code} -- | 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 \end{code} read_file and write_file ------------------------ \begin{code} 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 \end{code}