test-karya (empty) → 0.0.1

raw patch · 24 files changed

+2688/−0 lines, 24 filesdep +Diffdep +QuickCheckdep +asyncsetup-changed

Dependencies added: Diff, QuickCheck, async, base, bytestring, containers, data-ordlist, deepseq, directory, filepath, ghc-prim, haskell-src, pcre-heavy, pcre-light, pretty, process, test-karya, text, unix

Files

• LICENSE +31/−0
• README.md +71/−0
• Setup.hs +2/−0
• TODO +51/−0
• example/example.cabal +22/−0
• example/src/A.hs +4/−0
• example/src/A_test.hs +9/−0
• example/src/RunTests.hs +1/−0
• src/EL/Private/ExtractHs.hs +97/−0
• src/EL/Private/File.hs +54/−0
• src/EL/Private/Map.hs +10/−0
• src/EL/Private/PPrint.hs +92/−0
• src/EL/Private/Process.hs +68/−0
• src/EL/Private/Ranges.hs +10/−0
• src/EL/Private/Regex.hs +94/−0
• src/EL/Private/Seq.hs +779/−0
• src/EL/Private/Then.hs +68/−0
• src/EL/Test/ApproxEq.hs +67/−0
• src/EL/Test/Global.hs +7/−0
• src/EL/Test/RunTests.hs +351/−0
• src/EL/Test/TestKaryaGenerate.hs +178/−0
• src/EL/Test/Testing.hs +498/−0
• src/Global.hs +27/−0
• test-karya.cabal +97/−0

@@ -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.+

@@ -0,0 +1,71 @@+Some time before 2008 I needed to write tests for Haskell, specifically for+what became <https://github.com/elaforge/karya>.  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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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.

@@ -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

@@ -0,0 +1,4 @@+module A where++f :: Int -> Int+f x = x * 2

@@ -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

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF test-karya-generate #-}

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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+        }

@@ -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)

@@ -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

@@ -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)

@@ -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

@@ -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)

@@ -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)

@@ -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`)

@@ -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

@@ -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] = "<empty> " <> operator <> " " <> y+fmtLines operator [x] [] = x <> " " <> operator <> " <empty>"+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 "<empty-stack>" 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)

@@ -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

@@ -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 <qdunkan@gmail.com>+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