
   0 | module Idrall.TestHelper
   1 | 
   2 | import Idrall.Error
   3 | import Idrall.IOEither
   4 | import Idrall.APIv1
   5 | import Idrall.Value
   6 | 
   7 | import System
   8 | import System.Directory
   9 | import System.Path
  10 | import System.Directory.Tree
  11 | 
  12 | import Data.List
  13 | import Data.String
  14 | import Data.String.Extra
  15 | 
  16 | import Text.PrettyPrint.Prettyprinter.Util
  17 | import Text.PrettyPrint.Prettyprinter.Doc
  18 | import Text.PrettyPrint.Prettyprinter.Render.String
  19 | 
  20 | public export
  21 | record Result where
  22 |   constructor MkResult
  23 |   pass : Nat
  24 |   fail : Nat
  25 | 
  26 | record ResultFail where
  27 |   constructor MkResultFail
  28 |   shouldFail : Nat
  29 |   passedButShouldNot : Nat
  30 | 
  31 | public export
  32 | Show Result where
  33 |   show (MkResult pass fail) = "Result: " ++ "\n" ++
  34 |                               "Pass: " ++ show pass ++ "\n" ++
  35 |                               "Fail: " ++ show fail
  36 | 
  37 | public export
  38 | Semigroup Result where
  39 |   (<+>) (MkResult pass fail) (MkResult pass' fail') = MkResult (pass + pass') (fail + fail')
  40 | 
  41 | public export
  42 | Monoid Result where
  43 |   neutral = MkResult 0 0
  44 | 
  45 | -- TODO open idris2 PR?
  46 | foldlMapM : (Foldable g, Monoid b, Applicative m) => (a -> m b) -> g a -> m b
  47 | foldlMapM f = foldr f' (pure neutral)
  48 |   where
  49 |   f' : a -> m b -> m b
  50 |   f' x y = liftA2 (<+>) (f x) y
  51 | 
  52 | mkres : Pretty a
  53 |       => IOEither Error a
  54 |       -> IO Result
  55 | mkres (MkIOEither x) = do
  56 |   x' <- x
  57 |   case x' of
  58 |        (Left e) => do
  59 |          putStrLn $ !(fancyError e)
  60 |          pure (MkResult 0 1)
  61 |        (Right y) => do
  62 |          pure (MkResult 1 0)
  63 | 
  64 | mkresFail : Show a
  65 |       => IOEither Error a
  66 |       -> IO Result
  67 | mkresFail (MkIOEither x) = do
  68 |   x' <- x
  69 |   case x' of
  70 |        (Left y) => do
  71 |          pure (MkResult 0 1)
  72 |        (Right y) => do
  73 |          putStrLn $ show y
  74 |          pure (MkResult 1 0)
  75 | 
  76 | flipRes : Result -> Result
  77 | flipRes (MkResult pass fail) = MkResult fail pass
  78 | 
  79 | data TestPair
  80 |   = MkTestPair String String
  81 | 
  82 | Show TestPair where
  83 |   show (MkTestPair a b) = a ++ " : " ++ b
  84 | 
  85 | fileNameAB : {root : _} -> FileName root -> TestPair
  86 | fileNameAB a =
  87 |   let fileA = show $ toFilePath a
  88 |       fileB = aToB fileA
  89 |   in do
  90 |     MkTestPair fileA fileB
  91 |   where
  92 |     aToB : String -> String
  93 |     aToB a = (dropLast 7 a) ++ "B.dhall" -- 7 chars in "A.dhall"
  94 | 
  95 | -- filters
  96 | matchFiles : {root : _} -> List String -> FileName root -> Bool
  97 | matchFiles [] n = False
  98 | matchFiles (x :: xs) n =
  99 |   case isInfixOf x (fileName n) of
 100 |        False => matchFiles xs n
 101 |        True => True
 102 | 
 103 | defaultFilters : List ({root : _} -> FileName root -> Bool)
 104 | defaultFilters = [findAFiles]
 105 |   where
 106 |     findAFiles : {root : _} -> FileName root -> Bool
 107 |     findAFiles x =
 108 |       let fileNameStr = fileName x in
 109 |         isSuffixOf "A.dhall" fileNameStr
 110 | 
 111 | doFilter : {root : _}
 112 |          -> List ({root : _} -> FileName root -> Bool)
 113 |          -> Tree root
 114 |          -> Tree root
 115 | doFilter [] x = x
 116 | doFilter (f :: xs) x =
 117 |   doFilter xs (System.Directory.Tree.filter f (\_ => True) x)
 118 | 
 119 | -- running tests
 120 | runTests' : Pretty a
 121 |           => (path : String)
 122 |           -> (String -> String -> IOEither Error a)
 123 |           -> (filters : List ({root : _} -> FileName root -> Bool))
 124 |           -> IO Result
 125 | runTests' path f filters =
 126 |   let dir = explore $ parse path
 127 |       testFiles = doFilter filters !dir
 128 |   in do
 129 |     res <- depthFirst doTest (sort testFiles) $ pure neutral
 130 |     pure res
 131 |     where
 132 |     runTestPair : Pretty a
 133 |                 => TestPair
 134 |                 -> (String -> String -> IOEither Error a)
 135 |                 -> IOEither Error a
 136 |     runTestPair (MkTestPair a b) f = f a b
 137 |     doTest : {root : _} -> FileName root -> Lazy (IO Result) -> IO Result
 138 |     doTest x next = do
 139 |       putStrLn $ "Testing: \{show $ toFilePath x}"
 140 |       res <- mkres $ runTestPair (fileNameAB x) f
 141 |       pure $ res <+> !next
 142 | 
 143 | public export
 144 | runTests : Pretty a => (path : String) -> (String -> String -> IOEither Error a) -> IO Result
 145 | runTests path f = runTests' path f defaultFilters
 146 | 
 147 | public export
 148 | runTestsOnly : Pretty a => (onlyList : List String) -> (path : String) -> (String -> String -> IOEither Error a) -> IO Result
 149 | runTestsOnly onlyList path f = runTests' path f ((matchFiles onlyList) :: defaultFilters)
 150 | 
 151 | runTestFail' : Show a => (path : String)
 152 |              -> (String -> IOEither Error a)
 153 |              -> (filters : List ({root : _} -> FileName root -> Bool))
 154 |              -> IO Result
 155 | runTestFail' path f filters =
 156 |   let dir = explore $ parse path
 157 |       testFiles = doFilter filters !dir
 158 |   in do
 159 |     res <- depthFirst doTest (sort testFiles) $ pure neutral
 160 |     pure $ res
 161 |   where
 162 |     doTest : {root : _} -> FileName root -> Lazy (IO Result) -> IO Result
 163 |     doTest x next = do
 164 |       putStrLn $ "Testing: \{show $ toFilePath x}"
 165 |       res <- mkresFail $ f (fileName x)
 166 |       pure $ res <+> !next
 167 | 
 168 | public export
 169 | runTestFail : Show a
 170 |             => (path : String)
 171 |             -> (String -> IOEither Error a)
 172 |             -> IO Result
 173 | runTestFail path f = runTestFail' path f []
 174 | 
 175 | -- printing results
 176 | public export
 177 | ppResult : Result -> String
 178 | ppResult (MkResult pass fail) =
 179 |   """
 180 |   Result:
 181 |   Pass: \{show pass}
 182 |   Fail: \{show fail}
 183 |   """
 184 | 
 185 | public export
 186 | ppResultFail : Result -> String
 187 | ppResultFail (MkResult pass fail) =
 188 |   """
 189 |   Result:
 190 |   Failed as intended: \{show fail}
 191 |   Passed but shouldn't: \{show pass}
 192 |   """
 193 |