diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright Evan Laforge 2011 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Evan Laforge nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,71 @@ +Some time before 2008 I needed to write tests for Haskell, specifically for +what became . At the time, I think HUnit +existed, but it did stuff I didn't think I needed, such as manually arranging +tests into a hierarchy, and didn't have stuff I thought I did, such as +automatic test discovery, diffs, filename:linenumber for failed tests, etc. +So I wrote my own. + +Over the years some features became obsolete (e.g. ghc now supports +filename:linenumber natively via call stacks), but I got used to this style +of tests, so I decided to try to extract it for use in cabal projects. + +Here's what I like: + +- Automatic test discovery. Tests are any functions named `test_*` in a +module named `*_test.hs`. In Karya, I use shake to collect the tests, but +in this cabal version, I borrowed the -pgmF technique from `hspec`. + +- Automatic test hierarchy. Tests are named by their module name, so you can +run subsets by pattern matching on the name. You don't have to collect them +into suites, and when running them you don't have to dig through the files to +see what they named their suites. + +- Low syntax overhead tests. A test is any standalone function that calls +test functions (like `equal`): + + ``` + module M_test where + import EL.Test.Global + import qualified M + + test_something = do + let f = M.something + equal (f 10) 20 + equal (f 20) 30 + ``` + + Tests don't abort on failure, so you can put a bunch together with local + definitions. There's no need to name each test case, the error message + will tell you module and line number. Since `test_something` is a normal + `IO ()` function you can run it in ghci, which is how I mainly work. + +- Doesn't mess with stdout. A check, like the `equal` function, is any +function that prints to stdout. A line starting with `__->` is a failure. +This was originally the simplest stupidest thing that could work, but over +the last 10 years there was never a reason to change it, and it turns out to +be convenient. Since test output is integrated into the stdout stream, it's +in the right context with any debugging or logging. + +- Colored formatted diffs. When values don't match, they are pretty printed +and differing parts highlighted. + +- Various other ad-hoc conveniences: `equalFmt` attaches a formatter so you +can get higher level diffs, `stringsLike` for matching strings with patterns, +`equalf` and `ApproxEq` typeclass for floating point, and `quickcheck` for +quickcheck properties with formatted diffs. + +### how to use + +See `example`, but the short version is: + +- Install library and `test-karya-generate` binary with `cabal install`. + +- Make a test module like `M_test` above. + +- Make `RunTests.hs` with `{-# OPTIONS_GHC -F -pgmF test-karya-generate #-}` + +- Make a `test-suite` like in `example`. + +- `cabal test`. You can rerun the tests with `dist/build/test/test`, run +only `M_test` with `dist/build/test/test M_test` or pass `--help` for more +options, including running tests in parallel. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,51 @@ +* subprocess communication is getting stuck + . But why? I think this should be the same code as karya's version, which + doesn't do that. + . There's definitely something fishy going on in both cases though, since + karya's version sometimes fails on travis. + . dist/build/test/test --clear-dirs --output=dist/test-output . + +How to run GenerateRunTests? + - use physical CPUs instead of getNumCapabilities + . The cpuinfo package is meant to do this but it's linux only: + https://github.com/TravisWhitaker/cpuinfo/issues/1 + * There should be a standard set of "run from cabal" flags: + --clear-dir --output=dist/test-output --check-output . + / Makefile to update when out of date, cabal Setup hooks to run make. + / Like Makefile, but a shell script that does the same thing. + / Use Setup hooks directly. Does cabal know how to only rebuild when + necessary? + * HSpec uses a -pgmF program to generate the module. But I think it runs + every single time you build tests. Of course, maybe that's actually pretty + fast. + . pgmF args: OrigSourceName.hs input.hs output.hs + +* remove the ioHuman and interactive stuff +/ argv0 is wrong, so parallelization probably doesn't work + . Use Environment.getExecutablePath +* fix tmpBaseDir + . Surely cabal has some way to pass in a tmp dir? + . Haha, it's cabal of course not. Use CPP then. + . Well, it would have to come from the testee config, which means putting it + in Testing.Config. Too much bother, just hardcode to dist/build/tmp-test + +Interpret the output + . I need the equivalent of test/run_tests. + . Can I embed that logic in RunTest itself? The problem is I want to write + to stdout, and then check that stdout. It's hard to do that when cabal is + redirecting stdout. + . Does cabal have any more flexible way to run tests? + Looks like no, just 'detailed', which is even less flexible, since it + requires the tests to be some cabal data structure. + . I would like a runner that runs the test binary, then runs something else + with access to the log. + . Can I redirect stdout to a file temporarily? I could do + withStdout (open "output") $ runTests ... + check "output" + . I can have tests write to a file via 'success' and 'failure'. The problem + is that then debugging isn't interleaved. But I could write to both the + output file and stdout. Or write everything to sdout, only errors to + stderr. + . Or use the parallelization feature, run as a subprocess. + . How this works is you call with --outputs. Then RunTests can have a flag + to check the outputs afterwards. diff --git a/example/example.cabal b/example/example.cabal new file mode 100644 --- /dev/null +++ b/example/example.cabal @@ -0,0 +1,22 @@ +name: example +version: 0.0.1 +cabal-version: >= 1.9 +build-type: Simple +synopsis: test testing tests +description: Test testing test-karya test framework. + +library + hs-source-dirs: src + exposed-modules: + A + build-depends: base + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: src + main-is: RunTests.hs + other-modules: + A, A_test + build-depends: + base + , test-karya diff --git a/example/src/A.hs b/example/src/A.hs new file mode 100644 --- /dev/null +++ b/example/src/A.hs @@ -0,0 +1,4 @@ +module A where + +f :: Int -> Int +f x = x * 2 diff --git a/example/src/A_test.hs b/example/src/A_test.hs new file mode 100644 --- /dev/null +++ b/example/src/A_test.hs @@ -0,0 +1,9 @@ +module A_test where +import EL.Test.Global +import qualified A + + +test_f = do + let f = A.f + equal (f 4) 8 + equal (f 4) 9 diff --git a/example/src/RunTests.hs b/example/src/RunTests.hs new file mode 100644 --- /dev/null +++ b/example/src/RunTests.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF test-karya-generate #-} diff --git a/src/EL/Private/ExtractHs.hs b/src/EL/Private/ExtractHs.hs new file mode 100644 --- /dev/null +++ b/src/EL/Private/ExtractHs.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | A library to collect definitions from haskell source and collect them +-- into an output source file. +module EL.Private.ExtractHs where +import qualified Data.Char as Char +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO + +import qualified System.Directory as Directory +import qualified System.Environment +import qualified System.Exit +import qualified System.FilePath as FilePath +import qualified System.IO as IO + +import Global + + +type Error = Text +type Warning = Text + +process :: [String] -> (Text -> a) + -> (FilePath -> Map FilePath a -> ([Warning], Text)) + -> IO () +process args extract generate = do + progName <- System.Environment.getProgName + (outFname, inputs) <- case args of + outFname : inputs -> return (outFname, inputs) + _ -> die $ "usage: " <> txt progName + <> " output.hs input1.hs input2.hs ..." + extracted <- extractFiles extract inputs + case generate outFname extracted of + (warnings, output) -> do + mapM_ (Text.IO.hPutStrLn IO.stderr) warnings + Directory.createDirectoryIfMissing True $ + FilePath.takeDirectory outFname + Text.IO.writeFile outFname $ header progName <> output + +header :: String -> Text +header program = "-- automatically generated by " <> txt program <> "\n" + +extractFiles :: (Text -> a) -> [FilePath] -> IO (Map FilePath a) +extractFiles extract = + fmap Map.fromList . mapM (\fn -> (,) fn . extract <$> Text.IO.readFile fn) + +-- * extract + +typeDeclarations :: Text -> [(Int, (Text, Text))] +typeDeclarations = mapMaybe parse . zip [1..] . Text.lines + where + parse (lineno, line) + | line == "" || Char.isSpace (Text.head line) = Nothing + | otherwise = case Text.words line of + name : "::" : rest -> Just (lineno, (name, Text.unwords rest)) + _ -> Nothing + +-- | This will be fooled by a {- or -} inside a string. I don't strip -- +-- comments because the extract functions look for left justified text. +stripComments :: Text -> Text +stripComments = mconcat . go (0 :: Int) + where + go nesting text + | Text.null post = [text] + | "{-" `Text.isPrefixOf` post = (if nesting > 0 then id else (pre:)) + (go (nesting+1) (Text.drop 2 post)) + | otherwise = (if nesting == 0 then (pre <> Text.take 2 post :) else id) + (go (max 0 (nesting-1)) (Text.drop 2 post)) + where (pre, post) = breakOnFirst "{-" "-}" text + +-- | Like 'Text.breakOn', but break on two things. +breakOnFirst :: Text -> Text -> Text -> (Text, Text) +breakOnFirst a b text + | Text.length aPre <= Text.length bPre = (aPre, aPost) + | otherwise = (bPre, bPost) + where + (aPre, aPost) = Text.breakOn a text + (bPre, bPost) = Text.breakOn b text + +-- * generate + +moduleDeclaration :: FilePath -> Text +moduleDeclaration fname = "module " <> pathToModule fname <> " where" + +makeImport :: FilePath -> Text +makeImport fname = "import qualified " <> pathToModule fname + +pathToModule :: FilePath -> Text +pathToModule = + Text.map dot . txt . FilePath.dropExtension . FilePath.normalise + where dot c = if c == '/' then '.' else c + +-- * util + +die :: Text -> IO a +die msg = do + Text.IO.hPutStrLn IO.stderr msg + System.Exit.exitFailure diff --git a/src/EL/Private/File.hs b/src/EL/Private/File.hs new file mode 100644 --- /dev/null +++ b/src/EL/Private/File.hs @@ -0,0 +1,54 @@ +-- Copyright 2013 Evan Laforge +-- This program is distributed under the terms of the GNU General Public +-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt + +{-# LANGUAGE ScopedTypeVariables #-} +{- | Do things with files. +-} +module EL.Private.File where +import qualified Control.Exception as Exception +import Control.Monad (guard) +import Data.Text (Text) +import qualified Data.Text.IO as Text.IO +import qualified System.Directory as Directory +import System.FilePath (()) +import qualified System.IO as IO +import qualified System.IO.Error as IO.Error + + +-- | Like 'Directory.getDirectoryContents' except don't return dotfiles and +-- it prepends the directory. +list :: FilePath -> IO [FilePath] +list dir = do + fns <- Directory.getDirectoryContents dir + return $ map (strip . (dir )) $ filter ((/=".") . take 1) fns + where + strip ('.' : '/' : path) = path + strip path = path + +writeLines :: FilePath -> [Text] -> IO () +writeLines fname lines = IO.withFile fname IO.WriteMode $ \hdl -> + mapM_ (Text.IO.hPutStrLn hdl) lines + +-- * IO errors + +-- | If @op@ raised ENOENT, return Nothing. +ignoreEnoent :: IO a -> IO (Maybe a) +ignoreEnoent = ignoreError IO.Error.isDoesNotExistError + +ignoreEOF :: IO a -> IO (Maybe a) +ignoreEOF = ignoreError IO.Error.isEOFError + +-- | Ignore all IO errors. This is useful when you want to see if a file +-- exists, because some-file/x will not give ENOENT, but ENOTDIR, which is +-- probably isIllegalOperation. +ignoreIOError :: IO a -> IO (Maybe a) +ignoreIOError = ignoreError (\(_ :: IO.Error.IOError) -> True) + +ignoreError :: Exception.Exception e => (e -> Bool) -> IO a -> IO (Maybe a) +ignoreError ignore action = Exception.handleJust (guard . ignore) + (const (return Nothing)) (fmap Just action) + +-- | 'Exception.try' specialized to IOError. +tryIO :: IO a -> IO (Either IO.Error.IOError a) +tryIO = Exception.try diff --git a/src/EL/Private/Map.hs b/src/EL/Private/Map.hs new file mode 100644 --- /dev/null +++ b/src/EL/Private/Map.hs @@ -0,0 +1,10 @@ +-- | Extra utils for "Data.Map". +module EL.Private.Map where +import qualified Data.Map as Map + +import qualified EL.Private.Seq as Seq + + +-- | Pair up elements from each map with equal keys. +pairs :: Ord k => Map.Map k v1 -> Map.Map k v2 -> [(k, Seq.Paired v1 v2)] +pairs map1 map2 = Seq.pair_sorted (Map.toAscList map1) (Map.toAscList map2) diff --git a/src/EL/Private/PPrint.hs b/src/EL/Private/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/EL/Private/PPrint.hs @@ -0,0 +1,92 @@ +{- | This is based on gleb.alexeev\@gmail.com's ipprint package on hackage. + + I'm not just using it directly because I want to pass custom formatting + flags because my terminal is 80 chars wide, not the 137-whatever default. +-} +module EL.Private.PPrint ( + pprint, pshow + , format, format_str +) where +import qualified Data.Char as Char +import qualified Data.Maybe as Maybe +import qualified Language.Haskell.Parser as Parser +import qualified Language.Haskell.Pretty as Pretty +import Language.Haskell.Syntax + +import qualified Text.PrettyPrint as PrettyPrint + + +-- * showable + +pprint :: Show a => a -> IO () +pprint = putStr . pshow + +-- | Pretty show. +pshow :: Show a => a -> String +pshow = format . show + +-- * String + +-- | Pretty up a string containing a parseable haskell value. +format :: String -> String +format = parse format_parsed + +-- | Pretty up haskell value, unless it's a string, in which case return it +-- directly. +-- +-- Previously I needed this in the REPL since it didn't have a way to say text +-- should be unformatted. I don't need it any more, but it doesn't seem to be +-- hurting so I'll leave it here for now. +format_str :: String -> String +format_str = parse format_nonstr + where + format_nonstr m = Maybe.fromMaybe (format_parsed m) (is_str m) + is_str (HsModule _ _ _ _ [HsPatBind _ _ (HsUnGuardedRhs rhs) _]) = + case rhs of + HsLit (HsString s) -> Just s + _ -> Nothing + is_str _ = Nothing + + +-- * implementation + +parse :: (HsModule -> String) -> String -> String +parse format s = case Parser.parseModule ("value = " ++ s) of + Parser.ParseOk m -> format m + -- The formatted version appends a newline, so the unformatted one should + -- too. + Parser.ParseFailed _ _ -> s ++ "\n" + +format_parsed :: HsModule -> String +format_parsed = strip_boilerplate . pprint_mode + +strip_boilerplate :: String -> String +strip_boilerplate = dedent . (" "++) . strip_match "value=" + . dropWhile (/='\n') -- Strip module line and "value =". + -- Prefix 4 spaces since this is how much will have been stripped from + -- the first line, namely " = ", and make this line up vertically with the + -- following lines. If it fit on one line, it'll be "value = " which is + -- not 4 characters but it doesn't matter because there's no following + -- line. + +strip_match :: String -> String -> String +strip_match pattern str = go pattern str + where + go "" s = strip s + go _ "" = "" + go (p:ps) s = case strip s of + c : cs | p == c -> go ps cs + _ -> str + strip = dropWhile Char.isSpace + +pprint_mode :: Pretty.Pretty a => a -> String +pprint_mode = Pretty.prettyPrintStyleMode pp_style Pretty.defaultMode + where + pp_style = PrettyPrint.style + { PrettyPrint.ribbonsPerLine = 1, PrettyPrint.lineLength = 80 } + +dedent :: String -> String +dedent s = unlines $ map (drop indent) slines + where + indent = minimum $ 80 : map (length . takeWhile Char.isSpace) slines + slines = lines s diff --git a/src/EL/Private/Process.hs b/src/EL/Private/Process.hs new file mode 100644 --- /dev/null +++ b/src/EL/Private/Process.hs @@ -0,0 +1,68 @@ +-- Copyright 2013 Evan Laforge +-- This program is distributed under the terms of the GNU General Public +-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Utilities to deal with processes. +module EL.Private.Process where +import qualified Control.Concurrent as Concurrent +import qualified Control.Concurrent.Async as Async +import qualified Control.Concurrent.Chan as Chan +import Control.Monad (forever, void) + +import qualified Data.String as String +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO + +import qualified EL.Private.File as File +import Global +import qualified System.Exit +import qualified System.IO as IO +import qualified System.Process as Process + + +data TalkOut = Stdout !Text | Stderr !Text + -- | This always terminates the conversation, and effectively marks the + -- channel closed. + | Exit !Int + deriving (Eq, Show) +data TalkIn = Text !Text | EOF + deriving (Eq, Show) + +instance String.IsString TalkIn where + fromString = Text . Text.pack + +-- | Have a conversation with a subprocess. This doesn't use ptys, so this +-- will only work if the subprocess explicitly doesn't use block buffering. +conversation :: FilePath -> [String] -> Maybe [(String, String)] + -> Chan.Chan TalkIn -> IO (Chan.Chan TalkOut) +conversation cmd args env input = do + output <- Chan.newChan + Concurrent.forkIO $ Process.withCreateProcess proc $ + \(Just stdin) (Just stdout) (Just stderr) pid -> do + IO.hSetBuffering stdout IO.LineBuffering + IO.hSetBuffering stderr IO.LineBuffering + outThread <- Async.async $ void $ File.ignoreEOF $ forever $ + Chan.writeChan output . Stdout =<< Text.IO.hGetLine stdout + errThread <- Async.async $ void $ File.ignoreEOF $ forever $ + Chan.writeChan output . Stderr =<< Text.IO.hGetLine stderr + Concurrent.forkIO $ forever $ Chan.readChan input >>= \case + Text t -> Text.IO.hPutStrLn stdin t >> IO.hFlush stdin + EOF -> IO.hClose stdin + -- Ensure both stdout and stderr are flushed before exit. + Async.waitBoth outThread errThread + code <- Process.waitForProcess pid + Chan.writeChan output $ Exit $ case code of + System.Exit.ExitFailure code -> code + System.Exit.ExitSuccess -> 0 + return output + where + proc = (Process.proc cmd args) + { Process.std_in = Process.CreatePipe + , Process.std_out = Process.CreatePipe + , Process.std_err = Process.CreatePipe + , Process.close_fds = True + , Process.env = env + } diff --git a/src/EL/Private/Ranges.hs b/src/EL/Private/Ranges.hs new file mode 100644 --- /dev/null +++ b/src/EL/Private/Ranges.hs @@ -0,0 +1,10 @@ +module EL.Private.Ranges where + + +merge_sorted :: Ord n => [(n, n)] -> [(n, n)] +merge_sorted [] = [] +merge_sorted [x] = [x] +merge_sorted ((s1, e1) : (s2, e2) : rest) + | e1 >= e2 = merge_sorted ((s1, e1) : rest) + | e1 >= s2 = merge_sorted ((s1, e2) : rest) + | otherwise = (s1, e1) : merge_sorted ((s2, e2) : rest) diff --git a/src/EL/Private/Regex.hs b/src/EL/Private/Regex.hs new file mode 100644 --- /dev/null +++ b/src/EL/Private/Regex.hs @@ -0,0 +1,94 @@ +-- | More user friendly regex api for PCRE regexes. +module EL.Private.Regex ( + Regex + -- * compile + , Option(..) + , compile, compileOptions, compileUnsafe, compileOptionsUnsafe + + -- * matching + , matches, groups, groupRanges + -- * substitute + , substitute, substituteGroups + + -- * misc + , escape +) where +import qualified Data.ByteString as ByteString +import qualified Data.Text as Text +import Data.Text (Text) +import qualified Data.Text.Encoding as Encoding + +import GHC.Stack (HasCallStack) +import qualified Text.Regex.PCRE.Heavy as PCRE +import Text.Regex.PCRE.Heavy (Regex) +import qualified Text.Regex.PCRE.Light as PCRE + + +-- * compile + +fromText :: Text -> ByteString.ByteString +fromText = Encoding.encodeUtf8 + +data Option = CaseInsensitive | DotAll | Multiline + deriving (Ord, Eq, Show) + +compile :: String -> Either String Regex +compile = compileOptions [] + +compileOptions :: [Option] -> String -> Either String Regex +compileOptions options text = + case PCRE.compileM (fromText (Text.pack text)) (convertOptions options) of + Left msg -> Left $ "compiling regex " ++ show text ++ ": " ++ msg + Right regex -> Right regex + +convertOptions :: [Option] -> [PCRE.PCREOption] +convertOptions = (options++) . map convert + where + convert opt = case opt of + CaseInsensitive -> PCRE.caseless + DotAll -> PCRE.dotall + Multiline -> PCRE.multiline + options = [PCRE.utf8, PCRE.no_utf8_check] + +-- | Will throw a runtime error if the regex has an error! +compileUnsafe :: HasCallStack => String -> Regex +compileUnsafe = compileOptionsUnsafe [] + +-- | Will throw a runtime error if the regex has an error! +compileOptionsUnsafe :: HasCallStack => [Option] -> String -> Regex +compileOptionsUnsafe options = either error id . compileOptions options + +-- * match + +matches :: Regex -> Text -> Bool +matches = flip (PCRE.=~) + +-- | Return (complete_match, [group_match]). +groups :: Regex -> Text -> [(Text, [Text])] +groups = PCRE.scan + +-- | Half-open ranges of where the regex matches. +groupRanges :: Regex -> Text -> [((Int, Int), [(Int, Int)])] + -- ^ (entire, [group]) +groupRanges = PCRE.scanRanges + +-- * substitute + +-- | TODO this is not the usual thing where it replaces \1 \2 etc., but +-- it replaces the entire match. +substitute :: Regex -> Text -> Text -> Text +substitute regex sub = PCRE.gsub regex sub + +substituteGroups :: Regex -> (Text -> [Text] -> Text) + -- ^ (complete_match -> groups -> replacement) + -> Text -> Text +substituteGroups = PCRE.gsub + +-- * misc + +-- | Escape a string so the regex matches it literally. +escape :: String -> String +escape "" = "" +escape (c : cs) + | c `elem` ("\\^$.[|()?*+{" :: [Char]) = '\\' : c : escape cs + | otherwise = c : escape cs diff --git a/src/EL/Private/Seq.hs b/src/EL/Private/Seq.hs new file mode 100644 --- /dev/null +++ b/src/EL/Private/Seq.hs @@ -0,0 +1,779 @@ +module EL.Private.Seq where +import Prelude hiding (head, last, tail) +import qualified Control.Arrow as Arrow +import qualified Data.Char as Char +import qualified Data.Either as Either +import Data.Function +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.Ordered as Ordered +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Data.Monoid ((<>)) +import qualified Data.Ord as Ord +import qualified Data.Set as Set + +import qualified EL.Private.Then as Then + + +-- | This is just a list, but is documentation that a return value will never +-- be null, or an argument should never be null. This is for cases where +-- 'NonEmpty' is too annoying to work with. +type NonNull a = [a] + +-- * enumeration + +enumerate :: [a] -> [(Int, a)] +enumerate = zip [0..] + +-- | Enumerate an inclusive range. Uses multiplication instead of successive +-- addition to avoid loss of precision. +-- +-- Also it doesn't require an Enum instance. +range :: (Num a, Ord a) => a -> a -> a -> [a] +range start end step = go 0 + where + go i + | step >= 0 && val > end = [] + | step < 0 && val < end = [] + | otherwise = val : go (i+1) + where val = start + (i*step) +{-# INLINEABLE range #-} +{-# SPECIALIZE range :: Int -> Int -> Int -> [Int] #-} + +-- | Enumerate a half-open range. +range' :: (Num a, Ord a) => a -> a -> a -> [a] +range' start end step = go 0 + where + go i + | step >= 0 && val >= end = [] + | step < 0 && val <= end = [] + | otherwise = val : go (i+1) + where val = start + (i*step) +{-# INLINEABLE range' #-} +{-# SPECIALIZE range' :: Int -> Int -> Int -> [Int] #-} + +-- | Like 'range', but always includes the end, even if it doesn't line up on +-- a step. +range_end :: (Num a, Ord a) => a -> a -> a -> [a] +range_end start end step = go 0 + where + go i + | step >= 0 && val >= end = [end] + | step < 0 && val <= end = [end] + | otherwise = val : go (i+1) + where val = start + (i*step) +{-# INLINEABLE range_end #-} +{-# SPECIALIZE range_end :: Int -> Int -> Int -> [Int] #-} + +-- | Infinite range. +range_ :: Num a => a -> a -> [a] +range_ start step = go 0 + where go i = start + (i*step) : go (i+1) +{-# INLINEABLE range_ #-} +{-# SPECIALIZE range_ :: Int -> Int -> [Int] #-} + +-- * transformation + +key_on :: (a -> k) -> [a] -> [(k, a)] +key_on f xs = zip (map f xs) xs + +key_on_snd :: (a -> k) -> [a] -> [(a, k)] +key_on_snd f xs = zip xs (map f xs) + +key_on_just :: (a -> Maybe k) -> [a] -> [(k, a)] +key_on_just f xs = [(k, a) | (Just k, a) <- key_on f xs] + +-- | Apply a function to the first and last elements. Middle elements are +-- unchanged. A null or singleton list is also unchanged. +first_last :: (a -> a) -> (a -> a) -> [a] -> [a] +first_last start end xs = case xs of + [] -> [] + [x] -> [x] + x : xs -> start x : go xs + where + go [] = [] + go [x] = [end x] + go (x:xs) = x : go xs + +-- | Filter on the fst values returning Just. +map_maybe_fst :: (a -> Maybe a2) -> [(a, b)] -> [(a2, b)] +map_maybe_fst f xs = [(a, b) | (Just a, b) <- map (Arrow.first f) xs] + +-- | Filter on the snd values returning Just. +map_maybe_snd :: (b -> Maybe b2) -> [(a, b)] -> [(a, b2)] +map_maybe_snd f xs = [(a, b) | (a, Just b) <- map (Arrow.second f) xs] + +map_head :: (a -> a) -> [a] -> [a] +map_head _ [] = [] +map_head f (x:xs) = f x : xs + +map_tail :: (a -> a) -> [a] -> [a] +map_tail f (x:xs) = x : map f xs +map_tail _ [] = [] + +map_init :: (a -> a) -> [a] -> [a] +map_init _ [] = [] +map_init _ [x] = [x] +map_init f (x:xs) = f x : map_init f xs + +map_last :: (a -> a) -> [a] -> [a] +map_last _ [] = [] +map_last f [x] = [f x] +map_last f (x:xs) = x : map_last f xs + + +-- * permutations + +-- | The cartesian product of a list of lists. E.g. +-- @[[1, 2], [3, 4]]@ -> @[[1, 3], [1, 4], [2, 3], [2, 4]]@. +cartesian :: [[a]] -> [[a]] +cartesian [] = [] +cartesian [xs] = [[x] | x <- xs] +cartesian (xs:rest) = [x:ps | x <- xs, ps <- cartesian rest] + +-- * indexing lists + +-- | Get @xs !! n@, but return Nothing if the index is out of range. +{-# SPECIALIZE at :: [a] -> Int -> Maybe a #-} +at :: (Num i, Ord i) => [a] -> i -> Maybe a +at xs n + | n < 0 = Nothing + | otherwise = _at xs n + where + _at [] _ = Nothing + _at (x:_) 0 = Just x + _at (_:xs) n = at xs (n-1) + +-- | Insert @x@ into @xs@ at index @i@. If @i@ is out of range, insert at the +-- beginning or end of the list. +insert_at :: Int -> a -> [a] -> [a] +insert_at i x xs = let (pre, post) = splitAt i xs in pre ++ (x : post) + +-- | Remove the element at the given index. Do nothing if the index is out +-- of range. +remove_at :: Int -> [a] -> [a] +remove_at i xs = let (pre, post) = splitAt i xs in pre ++ drop 1 post + +-- | Like 'remove_at' but return the removed element as well. +take_at :: Int -> [a] -> Maybe (a, [a]) +take_at i xs = case post of + v : vs -> Just (v, pre ++ vs) + [] -> Nothing + where (pre, post) = splitAt i xs + +-- | Modify element at an index by applying a function to it. If the index is +-- out of range, nothing happens. +modify_at :: Int -> (a -> a) -> [a] -> [a] +modify_at i f xs = case post of + [] -> pre + elt : rest -> pre ++ f elt : rest + where (pre, post) = splitAt i xs + +-- | Find an element, then change it. Return Nothing if the element wasn't +-- found. +find_modify :: (a -> Bool) -> (a -> a) -> [a] -> Maybe [a] +find_modify match modify = go + where + go (x:xs) + | match x = Just $ modify x : xs + | otherwise = (x:) <$> go xs + go [] = Nothing + +-- | Similar to 'modify_at', but will insert an element for an out of range +-- positive index. The list will be extended with 'deflt', and the modify +-- function passed a Nothing. +update_at :: a -> Int -> (Maybe a -> a) -> [a] -> [a] +update_at deflt i f xs + | i < 0 = error $ "Seq.update_at: negative index " ++ show i + | otherwise = go i xs + where + go 0 [] = [f Nothing] + go 0 (x:xs) = f (Just x) : xs + go i [] = deflt : go (i-1) [] + go i (x:xs) = x : go (i-1) xs + +-- | Move an element from one index to another, or Nothing if the @from@ +-- index was out of range. +move :: Int -> Int -> [a] -> Maybe [a] +move from to xs = do + (x, dropped) <- take_at from xs + return $ insert_at to x dropped + + +-- * min / max + +min_on :: Ord k => (a -> k) -> a -> a -> a +min_on key x y = if key x <= key y then x else y + +max_on :: Ord k => (a -> k) -> a -> a -> a +max_on key x y = if key x >= key y then x else y + +minimum_on :: Ord k => (a -> k) -> [a] -> Maybe a +minimum_on _ [] = Nothing +minimum_on key xs = Just (List.foldl1' f xs) + where f low x = if key x < key low then x else low + +maximum_on :: Ord k => (a -> k) -> [a] -> Maybe a +maximum_on _ [] = Nothing +maximum_on key xs = Just (List.foldl1' f xs) + where f high x = if key x > key high then x else high + +minimum :: Ord a => [a] -> Maybe a +minimum [] = Nothing +minimum xs = Just (List.minimum xs) + +maximum :: Ord a => [a] -> Maybe a +maximum [] = Nothing +maximum xs = Just (List.maximum xs) + +ne_minimum :: Ord a => NonEmpty a -> a +ne_minimum (x :| xs) = List.minimum (x : xs) + +ne_maximum :: Ord a => NonEmpty a -> a +ne_maximum (x :| xs) = List.maximum (x : xs) + +-- * ordered lists + +insert_on :: Ord k => (a -> k) -> a -> [a] -> [a] +insert_on key = List.insertBy (\a b -> compare (key a) (key b)) + +-- | Stable sort on a cheap key function. +sort_on :: Ord k => (a -> k) -> [a] -> [a] +sort_on = Ordered.sortOn' + +-- | Like 'sort_on', but sort highest-to-lowest. +reverse_sort_on :: Ord b => (a -> b) -> [a] -> [a] +reverse_sort_on f = List.sortBy $ \a b -> Ord.comparing f b a + +-- | Merge sorted lists. If two elements compare equal, the one from the left +-- list comes first. +merge :: Ord a => [a] -> [a] -> [a] +merge = merge_on id + +merge_by :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +merge_by = Ordered.mergeBy + +merge_on :: Ord k => (a -> k) -> [a] -> [a] -> [a] +merge_on key = Ordered.mergeBy (Ord.comparing key) + +merge_lists :: Ord k => (a -> k) -> [[a]] -> [a] +merge_lists key = foldr (merge_on key) [] + +-- | If the heads of the sublists are also sorted I can be lazy in the list of +-- sublists too. This version is optimized for minimal overlap. +merge_asc_lists :: Ord k => (a -> k) -> [[a]] -> [a] +merge_asc_lists key = foldr go [] + where + go [] ys = ys + go (x:xs) ys = x : merge_on key xs ys + +-- * grouping + +-- ** adjacent + +-- Adjacent groups only group adjacent elements, just like 'List.group'. + +-- | This is just 'List.groupBy' except with a key function. +group_adjacent :: Eq key => (a -> key) -> [a] -> [NonNull a] +group_adjacent key = List.groupBy ((==) `on` key) + +-- | Like 'group_adjacent', but include the key. +keyed_group_adjacent :: Eq key => (a -> key) -> [a] -> [(key, NonNull a)] +keyed_group_adjacent key = + key_on (key . List.head) . List.groupBy ((==) `on` key) + +-- ** sort + +-- Sort groups sort the input by the group key as a side-effect of grouping. + +-- | Group the unsorted list into @(key x, xs)@ where all @xs@ compare equal +-- after @key@ is applied to them. +keyed_group_sort :: Ord key => (a -> key) -> [a] -> [(key, NonNull a)] + -- ^ Sorted by key. The NonNull group is in the same order as the input. +keyed_group_sort key = Map.toAscList . foldr go Map.empty + where go x = Map.alter (Just . maybe [x] (x:)) (key x) + +-- | Similar to 'keyed_group_sort', but key on the fst element, and strip the +-- key out of the groups. +group_fst :: Ord a => [(a, b)] -> [(a, NonNull b)] +group_fst xs = [(key, map snd group) | (key, group) <- keyed_group_sort fst xs] + +-- | Like 'group_fst', but group on the snd element. +group_snd :: Ord b => [(a, b)] -> [(NonNull a, b)] +group_snd xs = [(map fst group, key) | (key, group) <- keyed_group_sort snd xs] + +-- | Like 'groupBy', but the list doesn't need to be sorted, and use a key +-- function instead of equality. The list is sorted by the key, and the groups +-- appear in their original order in the input list. +group_sort :: Ord key => (a -> key) -> [a] -> [NonNull a] +group_sort key = map snd . keyed_group_sort key + +-- ** stable + +-- Stable groups preserve the original input order, in both the heads of the +-- groups, and within the groups themselves. + +-- | Group each element with all the other elements that compare equal to it. +-- The heads of the groups appear in their original order. +group_stable_with :: (a -> a -> Bool) -> [a] -> [NonEmpty a] +group_stable_with is_equal = go + where + go [] = [] + go (x:xs) = (x :| equal) : go inequal + where (equal, inequal) = List.partition (is_equal x) xs + +-- | 'group_stable_with' but with a key function. +group_stable :: Eq key => (a -> key) -> [a] -> [NonEmpty a] +group_stable key = group_stable_with (\x y -> key x == key y) + +keyed_group_stable :: Eq key => (a -> key) -> [a] -> [(key, [a])] +keyed_group_stable key = map (\(g :| gs) -> (key g, g:gs)) . group_stable key + +-- * zipping + +-- | Pair each element with the following element. The last element is paired +-- with Nothing. Like @zip xs (drop 1 xs ++ f (last xs))@ but only traverses +-- @xs@ once. +zip_next :: [a] -> [(a, Maybe a)] +zip_next [] = [] +zip_next [x] = [(x, Nothing)] +zip_next (x : xs@(y:_)) = (x, Just y) : zip_next xs + +zip_nexts :: [a] -> [(a, [a])] +zip_nexts xs = zip xs (drop 1 (List.tails xs)) + +zip_prev :: [a] -> [(Maybe a, a)] +zip_prev xs = zip (Nothing : map Just xs) xs + +-- | Like 'zip_next' but with both preceding and following elements. +zip_neighbors :: [a] -> [(Maybe a, a, Maybe a)] +zip_neighbors [] = [] +zip_neighbors (x:xs) = (Nothing, x, head xs) : go x xs + where + go _ [] = [] + go prev [x] = [(Just prev, x, Nothing)] + go prev (x : xs@(y:_)) = (Just prev, x, Just y) : go x xs + +-- | This is like 'zip', but it returns the remainder of the longer argument +-- instead of discarding it. +zip_remainder :: [a] -> [b] -> ([(a, b)], Either [a] [b]) +zip_remainder (x:xs) (y:ys) = Arrow.first ((x, y) :) (zip_remainder xs ys) +zip_remainder [] ys = ([], Right ys) +zip_remainder xs [] = ([], Left xs) + +data Paired a b = First !a | Second !b | Both !a !b + deriving (Show, Eq) + +paired_second :: Paired a b -> Maybe b +paired_second (First _) = Nothing +paired_second (Second b) = Just b +paired_second (Both _ b) = Just b + +paired_first :: Paired a b -> Maybe a +paired_first (First a) = Just a +paired_first (Second _) = Nothing +paired_first (Both a _) = Just a + +partition_paired :: [Paired a b] -> ([a], [b]) +partition_paired (pair : pairs) = case pair of + Both a b -> (a : as, b : bs) + First a -> (a : as, bs) + Second b -> (as, b : bs) + where (as, bs) = partition_paired pairs +partition_paired [] = ([], []) + +-- | Like 'zip', but emit 'First's or 'Second's if the list lengths are +-- unequal. +zip_padded :: [a] -> [b] -> [Paired a b] +zip_padded [] [] = [] +zip_padded [] bs = map Second bs +zip_padded as [] = map First as +zip_padded (a:as) (b:bs) = Both a b : zip_padded as bs + +-- | Like 'zip', but the second list is padded with Nothings. +zip_padded_snd :: [a] -> [b] -> [(a, Maybe b)] +zip_padded_snd [] _ = [] +zip_padded_snd (x:xs) (y:ys) = (x, Just y) : zip_padded_snd xs ys +zip_padded_snd (x:xs) [] = [(x, Nothing) | x <- x : xs] + +-- | Return the reversed inits paired with the tails. This is like a zipper +-- moving focus along the input list. +zipper :: [a] -> [a] -> [([a], [a])] +zipper prev [] = [(prev, [])] +zipper prev lst@(x:xs) = (prev, lst) : zipper (x:prev) xs + +-- | Pair @a@ elements up with @b@ elements. If they are equal according to +-- the function, they'll both be Both in the result. If an @a@ is deleted +-- going from @a@ to @b@, it will be First, and Second for @b@. +-- +-- Kind of like an edit distance, or a diff. +equal_pairs :: (a -> b -> Bool) -> [a] -> [b] -> [Paired a b] +equal_pairs _ [] ys = map Second ys +equal_pairs _ xs [] = map First xs +equal_pairs eq (x:xs) (y:ys) + | x `eq` y = Both x y : equal_pairs eq xs ys + | any (eq x) ys = Second y : equal_pairs eq (x:xs) ys + | otherwise = First x : equal_pairs eq xs (y:ys) + +-- | This is like 'equal_pairs', except that the index of each pair in the +-- /right/ list is included. In other words, given @(i, Second y)@, +-- @i@ is the position of @y@ in the @b@ list. Given @(i, First x)@, +-- @i@ is where @x@ was deleted from the @b@ list. +indexed_pairs :: (a -> b -> Bool) -> [a] -> [b] -> [(Int, Paired a b)] +indexed_pairs eq xs ys = zip (indexed pairs) pairs + where + pairs = equal_pairs eq xs ys + indexed = scanl f 0 + where + f i (First _) = i + f i _ = i+1 + +indexed_pairs_on :: Eq k => (a -> k) -> [a] -> [a] -> [(Int, Paired a a)] +indexed_pairs_on key = indexed_pairs (\a b -> key a == key b) + +-- | Pair up two lists of sorted pairs by their first element. +pair_sorted :: Ord k => [(k, a)] -> [(k, b)] -> [(k, Paired a b)] +pair_sorted xs [] = [(k, First v) | (k, v) <- xs] +pair_sorted [] ys = [(k, Second v) | (k, v) <- ys] +pair_sorted x@((k0, v0) : xs) y@((k1, v1) : ys) + | k0 == k1 = (k0, Both v0 v1) : pair_sorted xs ys + | k0 < k1 = (k0, First v0) : pair_sorted xs y + | otherwise = (k1, Second v1) : pair_sorted x ys + +-- | Like 'pair_sorted', but use a key function, and omit the extracted key. +pair_sorted_on :: Ord k => (a -> k) -> [a] -> [a] -> [Paired a a] +pair_sorted_on key xs ys = + map snd $ pair_sorted (key_on key xs) (key_on key ys) + +-- | Sort the lists on with the key functions, then pair them up. +pair_on :: Ord k => (a -> k) -> (b -> k) -> [a] -> [b] -> [Paired a b] +pair_on k1 k2 xs ys = map snd $ + pair_sorted (sort_on fst (key_on k1 xs)) (sort_on fst (key_on k2 ys)) + +-- | Like 'pair_on', but when the lists have the same type. +pair_on1 :: Ord k => (a -> k) -> [a] -> [a] -> [Paired a a] +pair_on1 k = pair_on k k + +-- | Left if the val was in the left list but not the right, Right for the +-- converse. +diff :: (a -> b -> Bool) -> [a] -> [b] -> [Either a b] +diff eq xs ys = Maybe.mapMaybe f (equal_pairs eq xs ys) + where + f (First a) = Just (Left a) + f (Second a) = Just (Right a) + f _ = Nothing + +-- * partition + +-- | Like 'List.partition', but partition by two functions consecutively. +partition2 :: (a -> Bool) -> (a -> Bool) -> [a] -> ([a], [a], [a]) +partition2 f1 f2 xs = (as, bs, xs3) + where + (as, xs2) = List.partition f1 xs + (bs, xs3) = List.partition f2 xs2 + +partition_on :: (a -> Maybe b) -> [a] -> ([b], [a]) +partition_on f = go + where + go [] = ([], []) + go (x:xs) = case f x of + Just b -> (b:bs, as) + Nothing -> (bs, x:as) + where (bs, as) = go xs + +-- * sublists + +-- | Split into groups of a certain size. +chunked :: Int -> [a] -> [[a]] +chunked n xs = case splitAt n xs of + ([], []) -> [] + (pre, []) -> [pre] + (pre, post) -> pre : chunked n post + +-- | Take a list of rows to a list of columns. This is like a zip except +-- for variable-length lists. Similar to zip, the result is trimmed to the +-- length of the shortest row. +rotate :: [[a]] -> [[a]] +rotate [] = [] +rotate xs = maybe [] (: rotate (map List.tail xs)) (mapM head xs) + +-- | Similar to 'rotate', except that the result is the length of the longest +-- row and missing columns are Nothing. Analogous to 'zip_padded'. +rotate2 :: [[a]] -> [[Maybe a]] +rotate2 xs + | all Maybe.isNothing heads = [] + | otherwise = heads : rotate2 (map tl xs) + where + heads = map head xs + tl [] = [] + tl (_:xs) = xs + + +-- ** extracting sublists + +-- | Total variants of unsafe list operations. +head, last :: [a] -> Maybe a +head [] = Nothing +head (x:_) = Just x +last [] = Nothing +last xs = Just (List.last xs) + +tail :: [a] -> Maybe [a] +tail [] = Nothing +tail (_:xs) = Just xs + +-- | Drop adjacent elts if they are equal after applying the key function. +-- The first elt is kept. +drop_dups :: Eq k => (a -> k) -> [a] -> [a] +drop_dups _ [] = [] +drop_dups key (x:xs) = x : map snd (filter (not . equal) (zip (x:xs) xs)) + where equal (x, y) = key x == key y + +-- | Filter out elts when the predicate is true for adjacent elts. The first +-- elt is kept, and the later ones are dropped. This is like 'drop_dups' +-- except it can compare two elements. E.g. @drop_with (>=)@ will ensure the +-- sequence is increasing. +drop_with :: (a -> a -> Bool) -> [a] -> [a] +drop_with _ [] = [] +drop_with _ [x] = [x] +drop_with f (x:y:xs) + | f x y = drop_with f (x:xs) + | otherwise = x : drop_with f (y:xs) + +-- | Like 'drop_dups', but return the dropped values. +partition_dups :: Ord k => (a -> k) -> [a] -> ([a], [(a, NonNull a)]) + -- ^ ([unique], [(used_for_unique, [dups])]) +partition_dups key xs = + Either.partitionEithers $ concatMap extract (group_sort key xs) + where + extract [] = [] + extract [x] = [Left x] + extract (x:xs) = [Left x, Right (x, xs)] + +-- | Like 'drop_dups', but keep the last adjacent equal elt instead of the +-- first. +drop_initial_dups :: Eq k => (a -> k) -> [a] -> [a] +drop_initial_dups _ [] = [] +drop_initial_dups _ [x] = [x] +drop_initial_dups key (x:xs@(next:_)) + | key x == key next = rest + | otherwise = x:rest + where rest = drop_initial_dups key xs + +unique :: Ord a => [a] -> [a] +unique = unique_on id + +-- | This is like 'drop_dups', except that it's not limited to just adjacent +-- elts. The output list is in the same order as the input. +unique_on :: Ord k => (a -> k) -> [a] -> [a] +unique_on f xs = go Set.empty xs + where + go _set [] = [] + go set (x:xs) + | k `Set.member` set = go set xs + | otherwise = x : go (Set.insert k set) xs + where k = f x + +-- | Like 'unique', but sort the list, and should be more efficient. +unique_sort :: Ord a => [a] -> [a] +unique_sort = Set.toList . Set.fromList + +rtake :: Int -> [a] -> [a] +rtake n = snd . foldr go (n, []) + where + go x (n, xs) + | n <= 0 = (0, xs) + | otherwise = (n - 1, x : xs) + +rtake_while :: (a -> Bool) -> [a] -> [a] +rtake_while f = either id (const []) . foldr go (Right []) + where + -- Left means I'm done taking. + go _ (Left xs) = Left xs + go x (Right xs) + | f x = Right (x:xs) + | otherwise = Left xs + +rdrop :: Int -> [a] -> [a] +rdrop n = either id (const []) . foldr f (Right n) + where + f x (Right n) + | n <= 0 = Left [x] + | otherwise = Right (n-1) + f x (Left xs) = Left (x:xs) + +rdrop_while :: (a -> Bool) -> [a] -> [a] +rdrop_while f = foldr (\x xs -> if null xs && f x then [] else x:xs) [] + +lstrip, rstrip, strip :: String -> String +lstrip = dropWhile Char.isSpace +rstrip = rdrop_while Char.isSpace +strip = rstrip . lstrip + +-- | If the list doesn't have the given prefix, return the original list and +-- False. Otherwise, strip it off and return True. +drop_prefix :: Eq a => [a] -> [a] -> ([a], Bool) +drop_prefix pref list = go pref list + where + go [] xs = (xs, True) + go _ [] = (list, False) + go (p:ps) (x:xs) + | p == x = go ps xs + | otherwise = (list, False) + +drop_suffix :: Eq a => [a] -> [a] -> ([a], Bool) +drop_suffix suffix list + | post == suffix = (pre, True) + | otherwise = (list, False) + where (pre, post) = splitAt (length list - length suffix) list + +-- ** span and break + +-- | Like 'break', but the called function has access to the entire tail. +break_tails :: ([a] -> Bool) -> [a] -> ([a], [a]) +break_tails _ [] = ([], []) +break_tails f lst@(x:xs) + | f lst = ([], lst) + | otherwise = let (pre, post) = break_tails f xs in (x:pre, post) + +-- | 'List.span' from the end of the list. +span_end :: (a -> Bool) -> [a] -> ([a], [a]) +span_end f xs = (reverse post, reverse pre) + where (pre, post) = span f (reverse xs) + +-- | Like 'span', but it can transform the spanned sublist. +span_while :: (a -> Maybe b) -> [a] -> ([b], [a]) +span_while f = go + where + go [] = ([], []) + go (a:as) = case f a of + Just b -> Arrow.first (b:) (go as) + Nothing -> ([], a : as) + +-- | 'span_while' from the end of the list. +span_end_while :: (a -> Maybe b) -> [a] -> ([a], [b]) +span_end_while f xs = (reverse post, reverse pre) + where (pre, post) = span_while f (reverse xs) + +-- | List initial and final element, if any. +viewr :: [a] -> Maybe ([a], a) +viewr [] = Nothing +viewr (x:xs) = Just $ go x xs + where + go x [] = ([], x) + go x (x':xs) = let (pre, post) = go x' xs in (x:pre, post) + +ne_viewr :: NonEmpty a -> ([a], a) +ne_viewr (x :| xs) = + Maybe.fromMaybe (error "ne_viewr: not reached") (viewr (x : xs)) + +-- ** split and join + +-- | Split before places where the function matches. +-- +-- > > split_before (==1) [1,2,1] +-- > [[], [1, 2], [1]] +split_before :: (a -> Bool) -> [a] -> [[a]] +split_before f = go + where + go [] = [] + go xs = pre : case post of + x : xs -> cons1 x (go xs) + [] -> [] + where (pre, post) = break f xs + cons1 x [] = [[x]] + cons1 x (g:gs) = (x:g) : gs + +-- | Split after places where the function matches. +split_after :: (a -> Bool) -> [a] -> [[a]] +split_after f = go + where + go [] = [] + go xs = pre : go post + where (pre, post) = Then.break1 f xs + +-- | Split 'xs' on 'sep', dropping 'sep' from the result. +split :: Eq a => NonNull a -> [a] -> NonNull [a] +split [] _ = error "Util.Seq.split: empty separator" +split sep xs = go sep xs + where + go sep xs + | null post = [pre] + | otherwise = pre : split sep (drop (length sep) post) + where (pre, post) = break_tails (sep `List.isPrefixOf`) xs + +-- | Like 'split', but it returns [] if the input was null. +split_null :: Eq a => NonNull a -> [a] -> [[a]] +split_null _ [] = [] +split_null sep xs = split sep xs + +-- | Like 'split', but only split once. +split1 :: Eq a => NonNull a -> [a] -> ([a], [a]) +split1 [] _ = error "Util.Seq.split1: empty seperator" +split1 sep xs = (pre, drop (length sep) post) + where (pre, post) = break_tails (sep `List.isPrefixOf`) xs + +-- | Interspense a separator and concat. +join :: Monoid a => a -> [a] -> a +join sep = mconcat . List.intersperse sep + +-- | Binary join, but the separator is only used if both joinees are non-empty. +join2 :: (Monoid a, Eq a) => a -> a -> a -> a +join2 sep x y + | y == mempty = x + | x == mempty = y + | otherwise = x <> sep <> y + +-- | Split the list on the points where the given function returns true. +-- +-- This is similar to 'groupBy', except this is defined to compare adjacent +-- elements. 'groupBy' actually compares to the first element of each group. +-- E.g. you can't group numeric runs with @groupBy (\a b -> b > a+1)@. +split_between :: (a -> a -> Bool) -> [a] -> [[a]] +split_between _ [] = [] +split_between f xs = pre : split_between f post + where (pre, post) = break_between f xs + +break_between :: (a -> a -> Bool) -> [a] -> ([a], [a]) +break_between f (x1 : xs@(x2:_)) + | f x1 x2 = ([x1], xs) + | otherwise = let (pre, post) = break_between f xs in (x1 : pre, post) +break_between _ xs = (xs, []) + + +-- * replace + +-- | Replace sublist @from@ with @to@ in the given list. +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace from to = go + where + len = length from + go [] = [] + go lst@(x:xs) + | from `List.isPrefixOf` lst = to ++ go (drop len lst) + | otherwise = x : go xs + +-- | Replace occurrances of an element with zero or more other elements. +replace1 :: Eq a => a -> [a] -> [a] -> [a] +replace1 from to = concatMap (\v -> if v == from then to else [v]) + + +-- * search + +count :: Foldable t => (a -> Bool) -> t a -> Int +count f = List.foldl' (\n c -> if f c then n + 1 else n) 0 + + +-- * monadic + +-- | Like 'List.mapAccumL', but monadic. +mapAccumLM :: Monad m => (state -> x -> m (state, y)) -> state -> [x] + -> m (state, [y]) +mapAccumLM f state xs = go state xs + where + go state [] = return (state, []) + go state (x:xs) = do + (state, y) <- f state x + (state, ys) <- go state xs + return (state, y : ys) diff --git a/src/EL/Private/Then.hs b/src/EL/Private/Then.hs new file mode 100644 --- /dev/null +++ b/src/EL/Private/Then.hs @@ -0,0 +1,68 @@ +-- Copyright 2013 Evan Laforge +-- This program is distributed under the terms of the GNU General Public +-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt + +-- | List functions with continuations. This allows you to chain them and +-- easily express things like 'take until f then take one more'. +module EL.Private.Then where +import Prelude hiding (break, span, take, takeWhile, mapM) +import qualified Data.List as List + + +takeWhile :: (a -> Bool) -> ([a] -> [a]) -> [a] -> [a] +takeWhile _ cont [] = cont [] +takeWhile f cont (x:xs) + | f x = x : takeWhile f cont xs + | otherwise = cont (x:xs) + +-- | takeWhile plus one extra +takeWhile1 :: (a -> Bool) -> [a] -> [a] +takeWhile1 f = takeWhile f (List.take 1) + +take :: Int -> ([a] -> [a]) -> [a] -> [a] +take _ cont [] = cont [] +take n cont (x:xs) + | n <= 0 = cont (x:xs) + | otherwise = x : take (n-1) cont xs + +filter :: (a -> Bool) -> (a -> Bool) -> ([a] -> [a]) -> [a] -> [a] +filter f done cont = go + where + go [] = [] + go (x:xs) + | done x = cont (x:xs) + | f x = x : go xs + | otherwise = go xs + +-- | Like 'List.mapAccumL', except that you can do something with the final +-- state and append that to the list. +mapAccumL :: (acc -> x -> (acc, y)) -> acc -> (acc -> [y]) -> [x] -> [y] +mapAccumL f acc cont = go acc + where + go acc [] = cont acc + go acc (x:xs) = y : go acc2 xs + where (acc2, y) = f acc x + +break :: (a -> Bool) -> ([a] -> ([a], rest)) + -- ^ Given the list after the break, return (pre, post), where pre will + -- be appended to the end of the first list. + -> [a] -> ([a], rest) +break f cont (x:xs) + | f x = cont (x:xs) + | otherwise = let (pre, post) = break f cont xs in (x:pre, post) +break _ cont [] = cont [] + +span :: (a -> Bool) -> ([a] -> ([a], rest)) -> [a] -> ([a], rest) +span f = break (not . f) + +-- | Break right after the function returns True. +break1 :: (a -> Bool) -> [a] -> ([a], [a]) +break1 f = break f (splitAt 1) + +mapM :: Monad m => (a -> m b) -> m [b] -> [a] -> m [b] +mapM f cont = go + where + go [] = cont + go (a:as) = do + b <- f a + (b:) <$> go as diff --git a/src/EL/Test/ApproxEq.hs b/src/EL/Test/ApproxEq.hs new file mode 100644 --- /dev/null +++ b/src/EL/Test/ApproxEq.hs @@ -0,0 +1,67 @@ +-- Copyright 2013 Evan Laforge +-- This program is distributed under the terms of the GNU General Public +-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt + +{-# LANGUAGE MagicHash #-} +-- | ApproxEq class for comparing floating point numbers. +module EL.Test.ApproxEq (ApproxEq(eq), compare) where +import Prelude hiding (compare) +import qualified Data.Text as Text +import qualified GHC.Prim as Prim +import qualified GHC.Types as Types + + +compare :: (ApproxEq a, Ord a) => Double -> a -> a -> Ordering +compare eta a b + | eq eta a b = EQ + | a > b = GT + | otherwise = LT + +class ApproxEq a where + eq :: Double -> a -> a -> Bool + +instance ApproxEq Float where + eq eta x y = abs (x - y) <= d2f eta +instance ApproxEq Double where + eq eta x y = abs (x - y) <= eta + +-- * prelude types + +instance ApproxEq Char where eq _ = (==) +instance ApproxEq Int where eq _ = (==) +instance ApproxEq Integer where eq _ = (==) +instance ApproxEq Bool where eq _ = (==) + +instance ApproxEq a => ApproxEq [a] where + eq eta = go + where + go [] [] = True + go [] _ = False + go _ [] = False + go (x:xs) (y:ys) = eq eta x y && go xs ys + +instance ApproxEq a => ApproxEq (Maybe a) where + eq eta (Just x) (Just y) = eq eta x y + eq _ _ _ = False + +instance (ApproxEq a, ApproxEq b) => ApproxEq (Either a b) where + eq eta (Right x) (Right y) = eq eta x y + eq eta (Left x) (Left y) = eq eta x y + eq _ _ _ = False + +instance (ApproxEq a, ApproxEq b) => ApproxEq (a, b) where + eq eta (a, b) (a', b') = eq eta a a' && eq eta b b' +instance (ApproxEq a, ApproxEq b, ApproxEq c) => ApproxEq (a, b, c) where + eq eta (a, b, c) (a', b', c') = eq eta a a' && eq eta b b' && eq eta c c' +instance (ApproxEq a, ApproxEq b, ApproxEq c, ApproxEq d) => + ApproxEq (a, b, c, d) where + eq eta (a, b, c, d) (a', b', c', d') = + eq eta a a' && eq eta b b' && eq eta c c' && eq eta d d' + +-- * hackage types + +instance ApproxEq Text.Text where eq _ = (==) + + +d2f :: Double -> Float +d2f (Types.D# d) = Types.F# (Prim.double2Float# d) diff --git a/src/EL/Test/Global.hs b/src/EL/Test/Global.hs new file mode 100644 --- /dev/null +++ b/src/EL/Test/Global.hs @@ -0,0 +1,7 @@ +-- | Exports from "EL.Test.Testing". This is meant to be imported +-- unqualified. +module EL.Test.Global (module EL.Test.Testing) where +import EL.Test.Testing + (ModuleMeta(ModuleMeta), check, checkVal, equal, equalFmt, rightEqual, + notEqual, equalf, stringsLike, leftLike, match, throws, ioEqual, + success, failure, expectRight, quickcheck, qcEqual, pprint) diff --git a/src/EL/Test/RunTests.hs b/src/EL/Test/RunTests.hs new file mode 100644 --- /dev/null +++ b/src/EL/Test/RunTests.hs @@ -0,0 +1,351 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Run tests. This is meant to be invoked via a main module generated by +-- "EL.Test.GenerateRunTests". +module EL.Test.RunTests where +import qualified Control.Concurrent as Concurrent +import qualified Control.Concurrent.Async as Async +import qualified Control.Concurrent.Chan as Chan +import qualified Control.Concurrent.MVar as MVar +import qualified Control.Exception as Exception +import qualified Control.Monad.Fix as Fix + +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Text.Lazy.IO as Text.Lazy.IO + +import qualified Numeric +import qualified System.CPUTime as CPUTime +import qualified System.Console.GetOpt as GetOpt +import qualified System.Directory as Directory +import qualified System.Environment as Environment +import qualified System.Environment +import qualified System.Exit +import System.FilePath (()) +import qualified System.IO as IO +import qualified System.Process as Process + +import qualified Text.Read as Read + +import qualified EL.Private.File as File +import qualified EL.Private.Process as EL.Process +import qualified EL.Private.Regex as Regex +import qualified EL.Private.Seq as Seq +import qualified EL.Test.Testing as Testing + +import Global + + +data Test = Test { + -- | Name of the test function. + testSymName :: Text + -- | Run the test. + , testRun :: IO () + -- | Test module filename. + , testFilename :: FilePath + -- | Line of the test function declaration. + , testLine :: Int + -- | Module-level metadata, declared as @meta@ in the test module toplevel. + , testModuleMeta_ :: Maybe Testing.ModuleMeta + } + +testModuleMeta :: Test -> Testing.ModuleMeta +testModuleMeta = Maybe.fromMaybe Testing.moduleMeta . testModuleMeta_ + +testName :: Test -> Text +testName test = Text.intercalate "," tags <> "-" <> testSymName test + where + tags = if null tags_ then ["normal"] else tags_ + tags_ = Seq.unique_sort $ map (Text.toLower . showt) $ + Testing.tags (testModuleMeta test) + +-- Prefix for lines with test metadata. +metaPrefix :: Text +metaPrefix = "===>" + +data Flag = + CheckOutput + | ClearDirs + | Jobs !Jobs + | List + | Output !FilePath + | Subprocess + deriving (Eq, Show) + +data Jobs = Auto | NJobs !Int deriving (Eq, Show) + +options :: [GetOpt.OptDescr Flag] +options = + [ GetOpt.Option [] ["check-output"] (GetOpt.NoArg CheckOutput) + "Check output for failures after running. Only valid with --output." + , GetOpt.Option [] ["clear-dirs"] (GetOpt.NoArg ClearDirs) + "Remove everything in the test tmp dir and --output.\ + \ This is probably just for cabal, which can't wrap tests in a shell\ + \ script." + , GetOpt.Option [] ["jobs"] (GetOpt.ReqArg (Jobs . parseJobs) "1") + "Number of parallel jobs, or 'auto' for Concurrent.getNumCapabilities." + , GetOpt.Option [] ["list"] (GetOpt.NoArg List) "display but don't run" + , GetOpt.Option [] ["output"] (GetOpt.ReqArg Output "path") + "Path to a directory to put output logs, if not given output goes to\ + \ stdout." + , GetOpt.Option [] ["subprocess"] (GetOpt.NoArg Subprocess) + "Read test names on stdin. This is meant to be run as a subprocess\ + \ by --jobs." + ] + where + parseJobs s + | s == "auto" = Auto + | Just n <- Read.readMaybe s = NJobs n + | otherwise = error $ "jobs should be auto or a number, was: " <> show s + +-- | Called by the generated main function. +run :: [String] -> [Test] -> IO () +run defaultArgs allTests = do + IO.hSetBuffering IO.stdout IO.LineBuffering + args <- System.Environment.getArgs + args <- return $ if null args then defaultArgs else args + (flags, args) <- case GetOpt.getOpt GetOpt.Permute options args of + (opts, n, []) -> return (opts, n) + (_, _, errors) -> quitWithUsage defaultArgs errors + ok <- runTests allTests flags args + if ok then System.Exit.exitSuccess else System.Exit.exitFailure + +quitWithUsage :: [String] -> [String] -> IO a +quitWithUsage defaultArgs errors = do + progName <- System.Environment.getProgName + putStrLn $ "usage: " <> progName <> " [ flags ] regex regex ..." + putStr $ GetOpt.usageInfo "Run tests that match any regex." options + unless (null defaultArgs) $ + putStrLn $ "\ndefault args provided by generator:\n" + <> unwords defaultArgs + unless (null errors) $ + putStr $ "\nerrors:\n" <> unlines errors + System.Exit.exitFailure + +runTests :: [Test] -> [Flag] -> [String] -> IO Bool +runTests allTests flags regexes = do + when (mbOutputDir == Nothing && CheckOutput `elem` flags) $ + quitWithUsage [] ["--check-output requires --output"] + when (ClearDirs `elem` flags) $ do + Directory.createDirectoryIfMissing True Testing.tmpBaseDir + clearDirectory Testing.tmpBaseDir + whenJust mbOutputDir clearDirectory + if | List `elem` flags -> do + mapM_ Text.IO.putStrLn $ List.sort $ map testName $ + if null regexes then allTests else matches + return True + | Subprocess `elem` flags -> subprocess allTests >> return True + | Just outputDir <- mbOutputDir -> do + jobs <- getJobs $ + fromMaybe (NJobs 1) $ Seq.last [n | Jobs n <- flags] + runOutput outputDir jobs matches (CheckOutput `elem` flags) + | otherwise -> mapM_ runTest matches >> return True + where + mbOutputDir = Seq.last [d | Output d <- flags] + matches = matchingTests regexes allTests + +getJobs :: Jobs -> IO Int +getJobs (NJobs n) = return n +getJobs Auto = Concurrent.getNumCapabilities + +runOutput :: FilePath -> Int -> [Test] -> Bool -> IO Bool +runOutput outputDir jobs tests check = do + Directory.createDirectoryIfMissing True outputDir + let outputs = [outputDir "out" <> show n <> ".stdout" | n <- [1..jobs]] + runParallel outputs tests + if check + then checkOutputs outputs + else return True + -- TODO run hpc? + +-- | Isolate the test by running it in a subprocess. I'm not sure if this is +-- necessary, but I believe at the time GUI-using tests would crash each other +-- without it. Presumably they left some GUI state around that process exit +-- will clean up. +runInSubprocess :: Test -> IO () +runInSubprocess test = do + argv0 <- System.Environment.getExecutablePath + putStrLn $ "subprocess: " ++ show argv0 ++ " " ++ show [testName test] + val <- Process.rawSystem argv0 [untxt (testName test)] + case val of + System.Exit.ExitFailure code -> Testing.withTestName (testName test) $ + void $ Testing.failure $ + "test returned " <> showt code <> ": " <> testName test + _ -> return () + +-- * parallel jobs + +-- | Run tests in parallel, redirecting stdout and stderr to each output. +runParallel :: [FilePath] -> [Test] -> IO () +runParallel _ [] = return () +runParallel outputs tests = do + let byModule = Seq.keyed_group_adjacent testFilename tests + queue <- newQueue [(txt name, tests) | (name, tests) <- byModule] + Async.forConcurrently_ (map fst (zip outputs byModule)) $ + \output -> jobThread output queue + +-- | Pull tests off the queue and feed them to a single subprocess. +jobThread :: FilePath -> Queue (Text, [Test]) -> IO () +jobThread output queue = + Exception.bracket (IO.openFile output IO.AppendMode) IO.hClose $ \hdl -> do + to <- Chan.newChan + env <- Environment.getEnvironment + argv0 <- System.Environment.getExecutablePath + -- Give each subprocess its own .tix, or they will stomp on each other + -- and crash. + from <- EL.Process.conversation argv0 ["--subprocess"] + (Just (("HPCTIXFILE", output <> ".tix") : env)) to + whileJust (takeQueue queue) $ \(name, tests) -> do + put $ untxt name + Chan.writeChan to $ EL.Process.Text $ + Text.unwords (map testName tests) <> "\n" + Fix.fix $ \loop -> Chan.readChan from >>= \case + EL.Process.Stdout line + | line == testsCompleteLine -> return () + | otherwise -> Text.IO.hPutStrLn hdl line >> loop + EL.Process.Stderr line -> Text.IO.hPutStrLn hdl line >> loop + EL.Process.Exit n -> put $ "completed early: " <> show n + Chan.writeChan to EL.Process.EOF + final <- Chan.readChan from + case final of + EL.Process.Exit n + | n == 0 -> return () + | otherwise -> put $ "completed " <> show n + _ -> put $ "expected Exit, but got " <> show final + where + put = putStr . ((output <> ": ")<>) . (<>"\n") + +subprocess :: [Test] -> IO () +subprocess allTests = void $ File.ignoreEOF $ forever $ do + testNames <- Set.fromList . Text.words <$> Text.IO.getLine + -- For some reason, I get an extra "" from getLine when the parent process + -- closes the pipe. From the documentation I think it should throw EOF. + unless (Set.null testNames) $ do + let tests = filter ((`Set.member` testNames) . testName) allTests + mapM_ runTest tests + `Exception.finally` Text.IO.hPutStrLn IO.stdout testsCompleteLine + -- I previously wrote this on stderr, but it turns out it then + -- gets nondeterministically interleaved with stdout. + +-- | Signal to the caller that the current batch of tests are done. +testsCompleteLine :: Text +testsCompleteLine = "•complete•" + +-- * run tests + +-- | Match all tests whose names match any regex, or if a test is an exact +-- match, just that test. +matchingTests :: [String] -> [Test] -> [Test] +matchingTests regexes tests = concatMap match regexes + where + match reg = case List.find ((== txt reg) . testName) tests of + Just test -> [test] + Nothing -> filter (Regex.matches (Regex.compileUnsafe reg) . testName) + tests + +runTest :: Test -> IO () +runTest test = Testing.withTestName name $ isolate $ do + Text.IO.putStrLn $ Text.unwords [metaPrefix, "run-test", testName test] + start <- CPUTime.getCPUTime + Testing.initialize (testModuleMeta test) $ + catch (testSymName test) (testRun test) + end <- CPUTime.getCPUTime + -- CPUTime is in picoseconds. + let secs = fromIntegral (end - start) / 10^12 + -- Grep for timing to make a histogram. + Text.IO.putStrLn $ Text.unwords [metaPrefix, "timing", testName test, + txt $ Numeric.showFFloat (Just 3) secs ""] + return () + where name = last (Text.split (=='.') (testName test)) + +-- | Try to save and restore any process level state in case the test messes +-- with it. Currently this just restores CWD, but probably there is more than +-- that. For actual isolation probably a subprocess is necessary. +isolate :: IO a -> IO a +isolate = Directory.withCurrentDirectory "." + +catch :: Text -> IO a -> IO () +catch name action = do + result <- Exception.try action + case result of + Left (exc :: Exception.SomeException) -> do + void $ Testing.failure $ name <> " threw exception: " <> showt exc + -- Die on async exception, otherwise it will try to continue + -- after ^C or out of memory. + case Exception.fromException exc of + Just (exc :: Exception.AsyncException) -> Exception.throwIO exc + Nothing -> return () + Right _ -> return () + +-- * queue + +-- | This is a simple channel which is written to once, and read from until +-- empty. +newtype Queue a = Queue (MVar.MVar [a]) + +newQueue :: [a] -> IO (Queue a) +newQueue = fmap Queue . MVar.newMVar + +takeQueue :: Queue a -> IO (Maybe a) +takeQueue (Queue mvar) = MVar.modifyMVar mvar $ \as -> return $ case as of + [] -> ([], Nothing) + a : as -> (as, Just a) + +whileJust :: Monad m => m (Maybe a) -> (a -> m ()) -> m () +whileJust get action = Fix.fix $ \loop -> get >>= \case + Nothing -> return () + Just a -> action a >> loop + +-- * check output + +-- | Empty the directory, but don't remove it entirely, in case it's /tmp or +-- something. +clearDirectory :: FilePath -> IO () +clearDirectory dir = mapM_ rm =<< File.list dir + where + -- Let's not go all the way to Directory.removePathForcibly. + rm fn = Directory.doesDirectoryExist fn >>= \isDir -> if isDir + then Directory.removeDirectoryRecursive fn + else Directory.removeFile fn + +checkOutputs :: [FilePath] -> IO Bool +checkOutputs outputs = do + (failureContext, failures, checks, tests) <- + extractStats <$> concatMapM readFileEmpty outputs + unless (null failureContext) $ putStrLn "\n*** FAILURES:" + mapM_ Text.IO.putStrLn failureContext + Text.IO.putStrLn $ showt failures <> " failed / " + <> showt checks <> " checks / " <> showt tests <> " tests" + return $ failures == 0 + +readFileEmpty :: FilePath -> IO Text.Lazy.Text +readFileEmpty = fmap (fromMaybe "") . File.ignoreEnoent . Text.Lazy.IO.readFile + +extractStats :: Text.Lazy.Text -> ([Text], Int, Int, Int) +extractStats = collect . drop 1 . Seq.split_before isTest . Text.Lazy.lines + where + collect tests = (failures, length failures, length extracted, length tests) + where + failures = Maybe.catMaybes extracted + extracted = concatMap extractFailures tests + isTest = ((Text.Lazy.fromStrict (metaPrefix <> " run-test")) + `Text.Lazy.isPrefixOf`) + +-- | Collect lines before each failure for context. +extractFailures :: [Text.Lazy.Text] -> [Maybe Text] +extractFailures = + mapMaybe fmt . Seq.split_after (\x -> isFailure x || isSuccess x) + where + fmt lines + | maybe False isFailure (Seq.last lines) = + Just $ Just $ Text.Lazy.toStrict (Text.Lazy.unlines lines) + | maybe False isSuccess (Seq.last lines) = Just Nothing + | otherwise = Nothing + isFailure = ("__-> " `Text.Lazy.isPrefixOf`) + isSuccess = ("++-> " `Text.Lazy.isPrefixOf`) diff --git a/src/EL/Test/TestKaryaGenerate.hs b/src/EL/Test/TestKaryaGenerate.hs new file mode 100644 --- /dev/null +++ b/src/EL/Test/TestKaryaGenerate.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | Collect tests from the given modules and generate a haskell module that + calls the tests. Test functions are any function starting with @test_@ or + @profile_@ and immediately followed by @=@ (implying the function has no + arguments). This module doesn't distinguish between tests and profiles, + but they should presumably be compiled separately since they require + different flags. + + If a module has a function called @initialize@, it will be called as + @IO ()@ prior to the tests. +-} +module EL.Test.TestKaryaGenerate (main) where +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO + +import qualified System.Directory as Directory +import qualified System.Environment +import qualified System.FilePath as FilePath +import qualified System.IO as IO + +import qualified EL.Private.ExtractHs as ExtractHs +import qualified EL.Private.Regex as Regex +import Global + + +-- pgmF args: OrigSourceName.hs input.hs output.hs +main :: IO () +main = do + args <- System.Environment.getArgs + (baseDir, outputFile, defaultArgs) <- case args of + origFile : _inputFile : outputFile : defaultArgs -> return + ( FilePath.takeDirectory origFile + , outputFile + , if null defaultArgs then defaultDefaultArgs else defaultArgs + ) + _ -> error "expected: origFile inputFile outputFile" + inputFiles <- find (Char.isUpper . head) ("_test.hs" `List.isSuffixOf`) + baseDir + extracted <- ExtractHs.extractFiles extract inputFiles + let (warnings, output) = generate defaultArgs $ + Map.mapKeys (stripPrefix baseDir) extracted + mapM_ (Text.IO.hPutStrLn IO.stderr) warnings + progName <- System.Environment.getProgName + Text.IO.writeFile outputFile $ header progName <> output + +defaultDefaultArgs :: [String] +defaultDefaultArgs = + [ "--jobs=auto" + , "--clear-dir" + , "--output=dist/test-output" + , "--check-output" + , "." + ] + +header :: String -> Text +header program = Text.unlines + [ "-- automatically generated by " <> txt program + , "{-# LANGUAGE OverloadedStrings #-}" + ] + +-- | Recursively find files below a directory. +find :: (FilePath -> Bool) -> (FilePath -> Bool) -> FilePath -> IO [FilePath] +find wantDir wantFile = fmap concat . go + where + go dir = do + (dirs, fns) <- partitionM Directory.doesDirectoryExist =<< list dir + rest <- mapM go (filter (wantDir . FilePath.takeFileName) dirs) + return $ filter wantFile fns : concat rest + +list :: FilePath -> IO [FilePath] +list dir = map (dir FilePath.) <$> Directory.listDirectory dir + +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM fp = go + where + go (x:xs) = fp x >>= \b -> case b of + True -> (\(as, bs) -> (x:as, bs)) <$> go xs + False -> (\(as, bs) -> (as, x:bs)) <$> go xs + go [] = return ([], []) + +stripPrefix :: FilePath -> FilePath -> FilePath +stripPrefix prefix fname = dropWhile (=='/') $ + if prefix `List.isPrefixOf` fname + then drop (length prefix) fname else fname + + +-- * generate + +type Warning = Text + +generate :: [String] -> Map FilePath ([Test], HasMeta) -> ([Warning], Text) +generate defaultArgs extracted = (,) warnings $ + testTemplate + (Text.unlines $ map ExtractHs.makeImport (Map.keys fnameTests)) + (Text.intercalate "\n , " $ makeTests fnameTests) + defaultArgs + where + (empty, fnameTests) = Map.partition (null . fst) extracted + warnings = map (("Warning: no (test|profile)_* defs in " <>) . txt) + (Map.keys empty) + +testTemplate :: Text -> Text -> [String] -> Text +testTemplate imports allTests defaultArgs = + "import qualified EL.Test.RunTests as RunTests\n\ + \import EL.Test.RunTests (Test(..))\n\ + \\n" + <> imports <> "\n\ + \\n\ + \tests :: [Test]\n\ + \tests = \n\ + \ [ " <> allTests <> "\n\ + \ ]\n\ + \\n\ + \main :: IO ()\n\ + \main = RunTests.run " <> showt defaultArgs <> " tests\n" + +data Test = Test { + testLineNumber :: !LineNumber + , testName :: !Text + } deriving (Show) +type LineNumber = Int + + +-- * extract + +type HasMeta = Maybe Text + +-- | Extract test functions and possible metadata from the file. +extract :: Text -> ([Test], HasMeta) +extract content = (extractTests content, hasMeta content) + +hasMeta :: Text -> HasMeta +hasMeta = + (\b -> if b then Just "meta" else Nothing) . Regex.matches reg + where reg = Regex.compileOptionsUnsafe [Regex.Multiline] "^meta\\b" + +extractTests :: Text -> [Test] +extractTests = go . zip [1..] . Text.lines + where + go ((i, line) : lines) + | Just def <- hasTestFunction line = Test + { testLineNumber = i + , testName = def + } : go rest + | otherwise = go lines + where + rest = dropWhile (isIndented . snd) lines + -- TODO does this get fooled by empty lines? + isIndented t = " " `Text.isPrefixOf` t || t == "\n" + go [] = [] + +hasTestFunction :: Text -> Maybe Text +hasTestFunction line + | Regex.matches reg line = Just $ head (Text.words line) + | otherwise = Nothing + where + reg = Regex.compileUnsafe "^(?:test|profile)_[a-zA-Z0-9_]+ \\=" + +-- * make + +makeTests :: Map.Map FilePath ([Test], HasMeta) -> [Text] +makeTests fnameTests = + [ makeTestLine fname test meta + | (fname, (tests, meta)) <- Map.toList fnameTests, test <- tests + ] + +makeTestLine :: FilePath -> Test -> HasMeta -> Text +makeTestLine fname test meta = Text.unwords + [ "Test", showt name, "(" <> name <> " >> return ())" + , showt fname, showt (testLineNumber test) + , case meta of + Nothing -> "Nothing" + Just fn -> "(Just " <> ExtractHs.pathToModule fname <> "." <> fn <> ")" + ] + where name = ExtractHs.pathToModule fname <> "." <> testName test diff --git a/src/EL/Test/Testing.hs b/src/EL/Test/Testing.hs new file mode 100644 --- /dev/null +++ b/src/EL/Test/Testing.hs @@ -0,0 +1,498 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns, DisambiguateRecordFields #-} +-- | Basic testing utilities. +module EL.Test.Testing ( + Config(..), modifyTestConfig, withTestName + -- * metadata + , ModuleMeta(..), moduleMeta, Tag(..) + -- * assertions + , check, checkVal + , equal, equalFmt, rightEqual, notEqual, equalf, stringsLike + , leftLike, match + , Pattern + -- ** exception assertions + , throws + + -- ** io assertions + , ioEqual + + -- ** low level + , success, failure + + -- * extracting + , expectRight + + -- * QuickCheck + , quickcheck + , qcEqual + + -- * pretty printing + , pprint + + -- * filesystem + , uniqueTmpDir, inTmpDir, tmpBaseDir + + -- * util + , force +) where +import qualified Control.DeepSeq as DeepSeq +import qualified Control.Exception as Exception +import Control.Monad (unless) + +import qualified Data.Algorithm.Diff as Diff +import qualified Data.IORef as IORef +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.Text (Text) +import qualified Data.Text.IO as Text.IO + +import qualified GHC.Stack as Stack +import GHC.Stack (HasCallStack) +import qualified System.Directory as Directory +import System.FilePath (()) +import qualified System.IO.Unsafe as Unsafe +import qualified System.Posix.IO as IO +import qualified System.Posix.Temp as Temp +import qualified System.Posix.Terminal as Terminal + +import qualified Test.QuickCheck as QuickCheck + +import qualified EL.Private.Map as EL.Map +import qualified EL.Private.PPrint as PPrint +import qualified EL.Private.Ranges as Ranges +import qualified EL.Private.Regex as Regex +import qualified EL.Private.Seq as Seq +import qualified EL.Test.ApproxEq as ApproxEq + + +{-# NOINLINE testConfig #-} +testConfig :: IORef.IORef Config +testConfig = Unsafe.unsafePerformIO $ IORef.newIORef $ Config + { configTestName = "no-test" + } + +modifyTestConfig :: (Config -> Config) -> IO () +modifyTestConfig = IORef.modifyIORef testConfig + +-- | Set 'configTestName'. This is a grody hack, but I need it because GHC +-- call stack is off by one, so you get the caller line number, but the +-- callee's function name: https://ghc.haskell.org/trac/ghc/ticket/11686 +withTestName :: Text -> IO a -> IO a +withTestName name action = do + modifyTestConfig (\config -> config { configTestName = name }) + action + +data Config = Config { + -- | Keep the test name so I can report it in 'success' in 'failure'. + configTestName :: !Text + } deriving (Show) + +check :: HasCallStack => Text -> Bool -> IO Bool +check msg False = failure ("failed: " <> msg) +check msg True = success msg + +-- | Check against a function. Use like: +-- +-- > checkVal (f x) $ \case -> ... +checkVal :: Show a => HasCallStack => a -> (a -> Bool) -> IO Bool +checkVal val f + | f val = success $ "ok: " <> pshowt val + | otherwise = failure $ "failed:" <> pshowt val + +-- * metadata + +data ModuleMeta = ModuleMeta { + -- | Wrap each test with IO level setup and teardown. Sync exceptions are + -- caught from the test function, so this should only see async exceptions. + initialize :: IO () -> IO () + , tags :: [Tag] + } + +moduleMeta :: ModuleMeta +moduleMeta = ModuleMeta + { initialize = id + , tags = [] + } + +data Tag = Large -- ^ Especially expensive to run. + deriving (Eq, Show) + +-- * equal and diff + +equal :: (HasCallStack, Show a, Eq a) => a -> a -> IO Bool +equal a b + | a == b = success $ cmp True + | otherwise = failure $ cmp False + where cmp = prettyCompare "==" "/=" True a b + +equalFmt :: (HasCallStack, Eq a, Show a) => (a -> Text) -> a -> a -> IO Bool +equalFmt fmt a b = do + ok <- equal a b + let (pa, pb) = (fmt a, fmt b) + unless (ok || Text.null pa && Text.null pb) $ + Text.IO.putStrLn $ showDiff pa pb + return ok + where + showDiff prettyA prettyB = fmtLines "/=" + (Text.lines $ highlightLines color diffA prettyA) + (Text.lines $ highlightLines color diffB prettyB) + where + color = failureColor + (diffA, diffB) = diffRanges prettyA prettyB + +notEqual :: (HasCallStack, Show a, Eq a) => a -> a -> IO Bool +notEqual a b + | a == b = failure $ cmp True + | otherwise = success $ cmp False + where cmp = prettyCompare "==" "/=" False a b + +rightEqual :: (HasCallStack, Show err, Show a, Eq a) => Either err a -> a + -> IO Bool +rightEqual (Right a) b = equal a b +rightEqual (Left err) _ = failure $ "Left: " <> pshowt err + +-- | Show the values nicely, whether they are equal or not. +prettyCompare :: Show a => + Text -- ^ equal operator + -> Text -- ^ inequal operator + -> Bool -- ^ If True then equal is expected so inequal will be highlighted + -- red. Otherwise, inequal is expected and highlighted green. + -> a -> a -> Bool -- ^ True if as are equal + -> Text +prettyCompare equal inequal expectEqual a b isEqual + | isEqual = equal <> " " <> ellipse (showt a) + | otherwise = fmtLines inequal + (Text.lines $ highlightLines color diffA prettyA) + (Text.lines $ highlightLines color diffB prettyB) + where + color = if expectEqual then failureColor else successColor + (diffA, diffB) = diffRanges prettyA prettyB + prettyA = Text.strip $ pshowt a + prettyB = Text.strip $ pshowt b + -- Equal values are usually not interesting, so abbreviate if they're too + -- long. + ellipse s + | len > maxlen = Text.take maxlen s <> "... {" <> showt len <> "}" + | otherwise = s + where len = Text.length s + maxlen = 200 + +-- | Apply color ranges as produced by 'diffRanges'. +highlightLines :: ColorCode -> IntMap.IntMap [CharRange] -> Text -> Text +highlightLines color nums = Text.unlines . zipWith hi [0..] . Text.lines + where + hi i line = case IntMap.lookup i nums of + Just ranges -> highlightRanges color ranges line + Nothing -> line + +highlightRanges :: ColorCode -> [CharRange] -> Text -> Text +highlightRanges color ranges = mconcat . map hi . splitRanges ranges + where hi (outside, inside) = outside <> highlight color inside + +splitRanges :: [(Int, Int)] -> Text -> [(Text, Text)] -- ^ (out, in) pairs +splitRanges ranges = go 0 ranges + where + go _ [] text + | Text.null text = [] + | otherwise = [(text, mempty)] + go prev ((s, e) : ranges) text = (pre, within) : go e ranges post + where + (pre, rest) = Text.splitAt (s-prev) text + (within, post) = Text.splitAt (e - s) rest + +type CharRange = (Int, Int) + +diffRanges :: Text -> Text + -> (IntMap.IntMap [CharRange], IntMap.IntMap [CharRange]) +diffRanges first second = + toMap $ Seq.partition_paired $ map diffLine $ + EL.Map.pairs firstByLine secondByLine + where + toMap (as, bs) = (IntMap.fromList as, IntMap.fromList bs) + diffLine (num, d) = case d of + Seq.Both line1 line2 -> Seq.Both (num, d1) (num, d2) + where (d1, d2) = charDiff line1 line2 + Seq.First line1 -> Seq.First (num, [(0, Text.length line1)]) + Seq.Second line2 -> Seq.Second (num, [(0, Text.length line2)]) + firstByLine = Map.fromList + [(n, text) | Diff.First (Numbered n text) <- diffs] + secondByLine = Map.fromList + [(n, text) | Diff.Second (Numbered n text) <- diffs] + diffs = numberedDiff (==) (Text.lines first) (Text.lines second) + +charDiff :: Text -> Text -> ([CharRange], [CharRange]) +charDiff first second + | tooDifferent firstCs || tooDifferent secondCs = + ([(0, Text.length first)], [(0, Text.length second)]) + | otherwise = (firstCs, secondCs) + where + firstCs = toRanges [n | Diff.First (Numbered n _) <- diffs] + secondCs = toRanges [n | Diff.Second (Numbered n _) <- diffs] + diffs = numberedDiff (==) (Text.unpack first) (Text.unpack second) + -- If there are too many diff ranges let's just mark the whole thing + -- different. Perhaps I should ignore spaces that are the same, but let's + -- see how this work first. + tooDifferent ranges = length ranges > 2 + +toRanges :: [Int] -> [(Int, Int)] +toRanges xs = Ranges.merge_sorted [(n, n+1) | n <- xs] + +numberedDiff :: (a -> a -> Bool) -> [a] -> [a] -> [Diff.Diff (Numbered a)] +numberedDiff equal a b = + Diff.getDiffBy (\a b -> _numberedVal a `equal` _numberedVal b) + (number a) (number b) + where number = zipWith Numbered [0..] + +data Numbered a = Numbered { + _numbered :: !Int + , _numberedVal :: !a + } deriving (Show) + +-- * approximately equal + +equalf :: (HasCallStack, Show a, ApproxEq.ApproxEq a) => Double -> a -> a + -> IO Bool +equalf eta a b + | ApproxEq.eq eta a b = success $ pretty True + | otherwise = failure $ pretty False + where pretty = prettyCompare "~~" "/~" True a b + +-- * other assertions + +class Show a => TextLike a where toText :: a -> Text +instance TextLike String where toText = Text.pack +instance TextLike Text where toText = id + +-- | Strings in the first list match patterns in the second list, using +-- 'patternMatches'. +stringsLike :: forall txt. (HasCallStack, TextLike txt) => [txt] -> [Pattern] + -> IO Bool +stringsLike gotten_ expected + | all isBoth diffs = success $ fmtLines "=~" gotten expected + | otherwise = failure $ fmtLines "/~" + (map (fmtLine (Set.fromList [_numbered a | Diff.Second a <- diffs])) + (zip [0..] gotten)) + (map (fmtLine (Set.fromList [_numbered a | Diff.First a <- diffs])) + (zip [0..] expected)) + where + fmtLine failures (n, line) + | Set.member n failures = highlight failureColor line + | otherwise = line + gotten = map toText gotten_ + diffs = numberedDiff patternMatches expected gotten + isBoth (Diff.Both {}) = True + isBoth _ = False + +-- | Format multiple lines with an operator between them, on a single line if +-- they fit. +fmtLines :: Text -> [Text] -> [Text] -> Text +fmtLines operator [x] [y] | Text.length x + Text.length y <= 70 = + x <> " " <> operator <> " " <> y +fmtLines operator [] [y] = " " <> operator <> " " <> y +fmtLines operator [x] [] = x <> " " <> operator <> " " +fmtLines operator xs ys = ("\n"<>) $ Text.stripEnd $ + Text.unlines $ xs <> [" " <> operator] <> ys + +-- | It's common for Left to be an error msg, or be something that can be +-- converted to one. +leftLike :: (HasCallStack, Show a, TextLike txt) => Either txt a -> Pattern + -> IO Bool +leftLike gotten expected = case gotten of + Left msg + | patternMatches expected msg -> success $ + "Left " <> toText msg <> " =~ Left " <> toText expected + | otherwise -> + failure $ "Left " <> toText msg <> " !~ Left " <> toText expected + Right a -> + failure $ "Right (" <> showt a <> ") !~ Left " <> toText expected + +match :: (HasCallStack, TextLike txt) => txt -> Pattern -> IO Bool +match gotten pattern = + (if matches then success else failure) $ + fmtLines (if matches then "=~" else "!~") + (Text.lines (toText gotten)) (Text.lines pattern) + where + matches = patternMatches pattern gotten + +-- | Pattern as matched by 'patternMatches'. +type Pattern = Text + +-- | This is a simplified pattern that only has the @*@ operator, which is +-- equivalent to regex's @.*?@. This reduces the amount of quoting you have +-- to write. You can escape @*@ with a backslash. +patternMatches :: TextLike txt => Pattern -> txt -> Bool +patternMatches pattern = not . null . Regex.groups (patternToRegex pattern) + . toText + +patternToRegex :: HasCallStack => Text -> Regex.Regex +patternToRegex = + Regex.compileOptionsUnsafe [Regex.DotAll] . mkstar . Regex.escape + . Text.unpack + where + mkstar "" = "" + mkstar ('\\' : '\\' : '\\' : '*' : cs) = '\\' : '*' : mkstar cs + mkstar ('\\' : '*' : cs) = '.' : '*' : '?' : mkstar cs + mkstar (c : cs) = c : mkstar cs + +-- | The given pure value should throw an exception that matches the predicate. +throws :: (HasCallStack, Show a) => a -> Pattern -> IO Bool +throws val excPattern = + (Exception.evaluate val >> failure ("didn't throw: " <> showt val)) + `Exception.catch` \(exc :: Exception.SomeException) -> + if patternMatches excPattern (showt exc) + then success ("caught exc: " <> showt exc) + else failure $ "exception <" <> showt exc <> "> didn't match " + <> excPattern + +ioEqual :: (HasCallStack, Eq a, Show a) => IO a -> a -> IO Bool +ioEqual ioVal expected = do + val <- ioVal + equal val expected + +expectRight :: (HasCallStack, Show a) => Either a b -> b +expectRight (Left v) = error (pshow v) +expectRight (Right v) = v + +-- * QuickCheck + +-- | Run a quickcheck property. +quickcheck :: (HasCallStack, QuickCheck.Testable prop) => prop -> IO Bool +quickcheck prop = do + (ok, msg) <- fmtQuickCheckResult <$> + QuickCheck.quickCheckWithResult args prop + (if ok then success else failure) msg + where + args = QuickCheck.stdArgs { QuickCheck.chatty = False } + +fmtQuickCheckResult :: QuickCheck.Result -> (Bool, Text) +fmtQuickCheckResult result = fmap Text.strip $ case result of + QuickCheck.Success { output } -> (True, Text.pack output) + QuickCheck.GaveUp { output } -> (False, Text.pack output) + QuickCheck.Failure { output } -> (False, Text.pack output) + QuickCheck.NoExpectedFailure { output } -> (False, Text.pack output) + QuickCheck.InsufficientCoverage { output } -> (False, Text.pack output) + +-- | 'equal' for quickcheck. +qcEqual :: (Show a, Eq a) => a -> a -> QuickCheck.Property +qcEqual a b = QuickCheck.counterexample + (Text.unpack $ prettyCompare "==" "/=" True a b False) + (a == b) + +-- * util + +-- These used to write to stderr, but the rest of the diagnostic output goes to +-- stdout, and it's best these appear in context. + +-- | Print a msg with a special tag indicating a passing test. +success :: HasCallStack => Text -> IO Bool +success msg = do + printTestLine Stack.callStack successColor "++-> " msg + return True + +-- | Print a msg with a special tag indicating a failing test. +failure :: HasCallStack => Text -> IO Bool +failure msg = do + printTestLine Stack.callStack failureColor "__-> " msg + return False + +printTestLine :: Stack.CallStack -> ColorCode -> Text -> Text -> IO () +printTestLine stack color prefix msg = do + -- Make sure the output doesn't get mixed with trace debug msgs. + force msg + isatty <- Terminal.queryTerminal IO.stdOutput + testName <- configTestName <$> IORef.readIORef testConfig + -- If there is highlighting in the msg, then it's probably a diff so + -- most of it may be unhighlighted. So highlight the prefix to make + -- the line visible. + let fullPrefix = (if isHighlighted msg then highlight color else id) + (prefix <> showStack testName stack) + let fullMsg = fullPrefix <> " " <> msg + highlighted + -- I only want colors in tty output. + | not isatty = stripColors fullMsg + -- Don't put on a color if it already has some. + | isHighlighted fullMsg = fullMsg + | otherwise = highlight color fullMsg + Text.IO.putStrLn highlighted + where + isHighlighted = (vt100Prefix `Text.isInfixOf`) + +showStack :: Text -> Stack.CallStack -> Text +showStack testName = + maybe "" showFrame . Seq.last . Stack.getCallStack + where + showFrame (_, srcloc) = + Text.pack (Stack.srcLocFile srcloc) <> ":" + <> showt (Stack.srcLocStartLine srcloc) + <> if Text.null testName then "" else " [" <> testName <> "]" + +highlight :: ColorCode -> Text -> Text +highlight (ColorCode code) text + | Text.null text = text + | otherwise = code <> text <> vt100Normal + +-- | Remove vt100 color codes. +stripColors :: Text -> Text +stripColors = mconcat . Seq.map_tail (Text.drop 1 . Text.dropWhile (/='m')) + . Text.splitOn vt100Prefix + +newtype ColorCode = ColorCode Text deriving (Show) + +vt100Prefix :: Text +vt100Prefix = "\ESC[" + +vt100Normal :: Text +vt100Normal = "\ESC[m\ESC[m" + +-- | These codes should probably come from termcap, but I can't be bothered. +failureColor :: ColorCode +failureColor = ColorCode "\ESC[31m" -- red + +successColor :: ColorCode +successColor = ColorCode "\ESC[32m" -- green + +-- * pretty + +pprint :: Show a => a -> IO () +pprint = putStr . pshow + +showt :: Show a => a -> Text +showt = Text.pack . show + +pshowt :: Show a => a -> Text +pshowt = Text.pack . pshow + +-- | Strict pshow, so I don't get debug traces interleaved with printing. +pshow :: Show a => a -> String +pshow val = s `DeepSeq.deepseq` s + where s = PPrint.pshow val + +-- * filesystem + +-- | Get a tmp dir, which will be unique for each test run. +uniqueTmpDir :: String -> IO FilePath +uniqueTmpDir prefix = do + Directory.createDirectoryIfMissing True tmpBaseDir + Temp.mkdtemp $ tmpBaseDir prefix ++ "-" + +-- | Run the computation with cwd in a new tmp dir. +inTmpDir :: String -> IO a -> IO a +inTmpDir prefix action = do + dir <- uniqueTmpDir prefix + Directory.withCurrentDirectory dir action + +-- | All tmp files used by tests should go in this directory. +-- +-- TODO instead of being hardcoded this should be configured per-project. +tmpBaseDir :: FilePath +tmpBaseDir = "dist/test-tmp" + +-- * util + +force :: DeepSeq.NFData a => a -> IO () +force x = Exception.evaluate (DeepSeq.rnf x) diff --git a/src/Global.hs b/src/Global.hs new file mode 100644 --- /dev/null +++ b/src/Global.hs @@ -0,0 +1,27 @@ +module Global ( + when, forever, unless, void, Map, mapMaybe, fromMaybe + , Text, txt, untxt, showt + , whenJust, concatMapM +) where +import qualified Control.Monad as Monad +import Control.Monad (when, forever, unless, void) +import Data.Map (Map) +import Data.Maybe (mapMaybe, fromMaybe) +import qualified Data.Text as Text +import Data.Text (Text) + + +txt :: String -> Text +txt = Text.pack + +untxt :: Text -> String +untxt = Text.unpack + +showt :: Show a => a -> Text +showt = txt . show + +whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () +whenJust ma f = maybe (return ()) f ma + +concatMapM :: (Monad m, Monoid b) => (a -> m b) -> [a] -> m b +concatMapM f = Monad.liftM mconcat . mapM f diff --git a/test-karya.cabal b/test-karya.cabal new file mode 100644 --- /dev/null +++ b/test-karya.cabal @@ -0,0 +1,97 @@ +name: test-karya +version: 0.0.1 +cabal-version: >=1.10 +build-type: Simple +synopsis: Testing framework. +description: + This is Karya's test framework, extracted to be usable standalone. + +category: Haskell, Test +license: BSD3 +license-file: LICENSE +author: Evan Laforge +maintainer: Evan Laforge +stability: stable +tested-with: GHC>=8.0.2 +extra-source-files: + LICENSE + TODO + README.md + example/example.cabal + example/src/*.hs + +homepage: https://github.com/elaforge/test-karya +source-repository head + type: git + location: git://github.com/elaforge/test-karya.git + +library + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -Wall -Wno-name-shadowing -Wno-unused-do-bind -Wno-type-defaults + build-depends: + Diff + , QuickCheck + , base >= 4.9 && < 4.12 + , bytestring + , containers + , data-ordlist + , deepseq + , directory + , filepath + , ghc-prim + , pcre-heavy >=0.2 + , pcre-light >=0.4 + , text + , unix + + -- RunTests + , async + , process + + -- for pprint + , pretty, haskell-src + exposed-modules: + EL.Test.ApproxEq + EL.Test.Global + EL.Test.Testing + EL.Test.RunTests + -- Previously I had these in a local internal library, but cabal + -- would install only the internal library, and not the public one. + -- Now I just copy paste the dependencies between the library and the + -- executable as is traditional with cabal, and it seems to work. + other-modules: + EL.Private.ExtractHs + EL.Private.Map + EL.Private.PPrint + EL.Private.Ranges + EL.Private.Regex + EL.Private.Seq + EL.Private.Then + EL.Private.File + EL.Private.Process + Global + +executable test-karya-generate + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -Wall -Wno-name-shadowing -Wno-unused-do-bind -Wno-type-defaults + main-is: EL/Test/TestKaryaGenerate.hs + ghc-options: -main-is EL.Test.TestKaryaGenerate + build-depends: + test-karya + , base + , bytestring + , containers + , directory + , filepath + , text + , pcre-heavy >=0.2 + , pcre-light >=0.4 + + other-modules: + EL.Private.ExtractHs + EL.Private.Regex + Global