examples/TestKit.lhs

{-# 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
  , 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           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 <$> 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}([^ ].*)$|]

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