packages feed

skeletest 0.3.2 → 0.3.3

raw patch · 13 files changed

+175/−32 lines, 13 filesdep −colour

Dependencies removed: colour

Files

CHANGELOG.md view
@@ -1,3 +1,14 @@+## v0.3.3++Configuration:+* Add `-optF=main:_` option for configuring the name of the main module/function ([#64](https://github.com/brandonchinn178/skeletest/issues/64))++API changes:+* Added `shouldReturn`++Runtime changes:+* Fix gray text output, using standard ANSI codes instead of a hardcoded RGB value+ ## v0.3.2  API changes:
README.md view
@@ -88,6 +88,8 @@       build-tool-depends: skeletest:skeletest-preprocessor     ``` +    Options may be specified as `-optF=<name>:<value>`. See [Options](#options).+ 1. Add `Main.hs`:      ```haskell@@ -190,6 +192,7 @@ * `shouldNotSatisfy` - equivalent to `shouldSatisfy` with `P.not` * `shouldBe` - equivalent to `shouldSatisfy` with `P.eq` * `shouldNotBe` - equivalent to `shouldNotSatisfy` with `P.eq`+* `shouldReturn` - equivalent to `shouldSatisfy` with `P.returns . P.eq`  `shouldSatisfy` is the most general function, but the others are provided for convenience. `shouldSatisfy` takes in the value being tested on the left, and a predicate on the right. Predicates should be imported from `Skeletest.Predicate`, qualified as `P`. @@ -427,6 +430,12 @@     ```haskell     MyFlag flagVal <- getFlag     ```++### Options++Skeletest accepts the following options, which may be added as `-optF=<name>:<value>`:++* `main`: Specify the main module/function, as either `OtherMain.otherMainFunc`, `OtherMain` (equivalent to `OtherMain.main`), or `otherMainFunc` (equivalent to `Main.otherMainFunc`). Generally only useful with the `-main-is` GHC option.  ### Hooks
skeletest.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0  name: skeletest-version: 0.3.2+version: 0.3.3 synopsis: Batteries-included, opinionated test framework description: Batteries-included, opinionated test framework. See README.md for more details. homepage: https://github.com/brandonchinn178/skeletest#readme@@ -81,7 +81,6 @@     , aeson     , aeson-pretty     , ansi-terminal >= 0.7.0-    , colour     , containers     , Diff >= 1.0     , directory
src/Skeletest.hs view
@@ -20,6 +20,7 @@   shouldNotBe,   shouldSatisfy,   shouldNotSatisfy,+  shouldReturn,   context,   failTest,   HasCallStack,
src/Skeletest/Assertions.hs view
@@ -7,6 +7,7 @@   shouldNotBe,   shouldSatisfy,   shouldNotSatisfy,+  shouldReturn,   context,   failTest,   AssertionFail (..),@@ -42,7 +43,7 @@   context = contextIO   throwFailure = throwIO -infix 1 `shouldBe`, `shouldNotBe`, `shouldSatisfy`, `shouldNotSatisfy`+infix 1 `shouldBe`, `shouldNotBe`, `shouldSatisfy`, `shouldNotSatisfy`, `shouldReturn`  -- | Assert that the given input should match the given value. -- Equivalent to @actual `shouldSatisfy` P.eq expected@@@ -65,6 +66,12 @@ -- | Assert that the given input should not satisfy the given predicate. shouldNotSatisfy :: (HasCallStack, Testable m) => a -> Predicate m a -> m () actual `shouldNotSatisfy` p = GHC.withFrozenCallStack $ actual `shouldSatisfy` P.not p++-- | Assert that the given input should return the given value.+-- Equivalent to @actual `shouldSatisfy` (P.returns . P.eq) expected@+-- @since 0.3.3+shouldReturn :: (HasCallStack, Testable m, Eq a) => m a -> a -> m ()+actual `shouldReturn` expected = GHC.withFrozenCallStack $ actual `shouldSatisfy` (P.returns . P.eq) expected  contextIO :: String -> IO a -> IO a contextIO msg =
src/Skeletest/Internal/GHC.hs view
@@ -102,8 +102,8 @@ -- | Our pure definition of PluginDef, agnostic of GHC version. data PluginDef = PluginDef   { isPure :: Bool-  , modifyParsed :: ModuleName -> ParsedModule -> ParsedModule-  , onRename :: Ctx -> ModuleName -> HsExpr GhcRn -> HsExpr GhcRn+  , modifyParsed :: [GHC.CommandLineOption] -> ModuleName -> ParsedModule -> ParsedModule+  , onRename :: [GHC.CommandLineOption] -> Ctx -> ModuleName -> HsExpr GhcRn -> HsExpr GhcRn   }  data Ctx = Ctx@@ -116,11 +116,11 @@ mkPlugin PluginDef{..} =   GHC.defaultPlugin     { GHC.pluginRecompile = if isPure then GHC.purePlugin else GHC.impurePlugin-    , GHC.parsedResultAction = \_ modInfo result -> do+    , GHC.parsedResultAction = \opts modInfo result -> do         let           moduleName = getModuleName $ GHC.ms_mod modInfo           parsedModule = initParsedModule . GHC.hpm_module . GHC.parsedResultModule $ result-          ParsedModule{moduleFuncs} = modifyParsed moduleName parsedModule+          ParsedModule{moduleFuncs} = modifyParsed opts moduleName parsedModule         newDecls <-           runCompilePs . fmap concat . sequence $             [ compileFunDef funName funDef@@ -129,7 +129,7 @@         pure           . (modifyParsedResultModule . modifyHpmModule . fmap . modifyModDecls) (newDecls <>)           $ result-    , GHC.renamedResultAction = \_ gblEnv group -> do+    , GHC.renamedResultAction = \opts gblEnv group -> do         nameCache <- GHC.hsc_NC . GHC.env_top <$> GHC.getEnv         let           moduleName = getModuleName $ GHC.tcg_mod gblEnv@@ -137,7 +137,7 @@             Ctx               { matchesName = matchesNameImpl nameCache               }-        group' <- runCompileRn $ modifyModuleExprs (onRename ctx moduleName) group+        group' <- runCompileRn $ modifyModuleExprs (onRename opts ctx moduleName) group         pure (gblEnv, group')     }  where
src/Skeletest/Internal/Plugin.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE ViewPatterns #-}@@ -15,6 +16,7 @@ import Skeletest.Internal.Error (skeletestPluginError) import Skeletest.Internal.GHC import Skeletest.Internal.Predicate qualified as P+import Skeletest.Internal.Preprocessor qualified as Preprocessor import Skeletest.Internal.Utils.HList (HList (..)) import Skeletest.Main qualified as Main import Skeletest.Plugin qualified as Plugin@@ -30,19 +32,28 @@   mkPlugin     PluginDef       { isPure = True-      , modifyParsed = \modName modl ->-          if modName == "Main"-            then transformMainModule modl-            else modl-      , onRename = \ctx modName expr ->+      , modifyParsed = \opts modName modl ->+          let options = decodeOptions opts+           in if modName == options.mainModuleName+                then transformMainModule options modl+                else modl+      , onRename = \_ ctx modName expr ->           if "Spec" `Text.isSuffixOf` modName             then transformTestModule ctx expr             else expr       }+ where+  decodeOptions =+    either (error . Text.unpack) id . \case+      [opts] -> Preprocessor.decodeOptions (Text.pack opts)+      _ -> Left ""  -- | Add 'main' function.-transformMainModule :: ParsedModule -> ParsedModule-transformMainModule modl = modl{moduleFuncs = (hsVarName "main", Just mainFun) : moduleFuncs modl}+transformMainModule :: Preprocessor.Options -> ParsedModule -> ParsedModule+transformMainModule options modl =+  modl+    { moduleFuncs = (hsVarName options.mainFuncName, Just mainFun) : moduleFuncs modl+    }  where   findVar name =     fmap hsExprVar . listToMaybe $
src/Skeletest/Internal/Preprocessor.hs view
@@ -1,7 +1,12 @@+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}  module Skeletest.Internal.Preprocessor (   processFile,+  Options (..),+  defaultOptions,+  decodeOptions, ) where  import Control.Monad (guard)@@ -14,12 +19,44 @@ import Skeletest.Internal.Error (SkeletestError (..)) import System.Directory (doesDirectoryExist, listDirectory) import System.FilePath (makeRelative, splitExtensions, takeDirectory, (</>))+import Text.Read (readMaybe) import UnliftIO.Exception (throwIO) +data Options = Options+  { mainModuleName :: Text+  , mainFuncName :: Text+  }+  deriving (Show, Read)++defaultOptions :: Options+defaultOptions =+  Options+    { mainModuleName = "Main"+    , mainFuncName = "main"+    }++encodeOptions :: Options -> Text+encodeOptions = Text.pack . show++decodeOptions :: Text -> Either Text Options+decodeOptions =+  maybe (Left "Could not decode skeletest-preprocessor options") Right+    . readMaybe+    . Text.unpack+    . unquote+ where+  unquote s =+    case Text.stripPrefix "\"" s >>= Text.stripSuffix "\"" of+      Just s' -> Text.replace "\\\"" "\"" s'+      Nothing -> s+ -- | Preprocess the given Haskell file. See Main.hs-processFile :: FilePath -> Text -> IO Text-processFile path file = do-  file' <- if isMain file then updateMainFile path file else pure file+processFile :: Options -> FilePath -> Text -> IO Text+processFile options path file = do+  file' <-+    if getModuleName file == options.mainModuleName+      then updateMainFile path file+      else pure file   pure     . addLine pluginPragma     . addLine linePragma@@ -28,22 +65,30 @@   addLine line f = line <> "\n" <> f   quoted s = "\"" <> s <> "\"" -  pluginPragma = "{-# OPTIONS_GHC -fplugin=Skeletest.Internal.Plugin #-}"+  pluginMod = "Skeletest.Internal.Plugin"+  quote s = "\"" <> Text.replace "\"" "\\\"" s <> "\""+  pluginPragma =+    Text.unwords+      [ "{-# OPTIONS_GHC"+      , "-fplugin=" <> pluginMod+      , "-fplugin-opt=" <> pluginMod <> ":" <> (quote . encodeOptions) options+      , "#-}"+      ]   linePragma =     -- this is needed to tell GHC to use original path in error messages     "{-# LINE 1 " <> quoted (Text.pack path) <> " #-}" -isMain :: Text -> Bool-isMain file =-  case mapMaybe getModuleName $ Text.lines file of+getModuleName :: Text -> Text+getModuleName file =+  case mapMaybe parseModuleLine $ Text.lines file of     -- there was a module line-    [name] -> name == "Main"-    -- there were no module lines, it's the main module-    [] -> True+    [name] -> name+    -- there were no module lines, it's the Main module+    [] -> "Main"     -- something else? just silently ignore it-    _ -> False+    _ -> ""  where-  getModuleName s =+  parseModuleLine s =     case Text.words s of       "module" : name : _ -> Just name       _ -> Nothing
src/Skeletest/Internal/Utils/Color.hs view
@@ -5,7 +5,6 @@   gray, ) where -import Data.Colour.Names qualified as Color import Data.Text (Text) import Data.Text qualified as Text import System.Console.ANSI qualified as ANSI@@ -23,4 +22,4 @@ yellow = withANSI [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Yellow]  gray :: Text -> Text-gray = withANSI [ANSI.SetRGBColor ANSI.Foreground Color.gray]+gray = withANSI [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Black]
src/Skeletest/Plugin.hs view
@@ -68,6 +68,7 @@ data Hooks = Hooks   { hookModifyFileSpecs :: [SpecTree] -> IO [SpecTree]   -- ^ Modify the specs in a file+  -- @since 0.3.2   , hookRunTest :: TestInfo -> IO TestResult -> IO TestResult   -- ^ Modify how a test is executed   }
src/bin/skeletest-preprocessor.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}  {-| A preprocessor that registers skeletest in a test suite. @@ -19,6 +20,8 @@ -} module Main where +import Data.Char (isUpper)+import Data.Foldable (foldlM) import Data.List (dropWhileEnd) import Data.Text.IO qualified as Text import GHC.IO.Encoding (setLocaleEncoding, utf8)@@ -27,8 +30,10 @@ import System.IO (hPutStrLn, stderr) import UnliftIO.Exception (displayException, handle) +import Data.Text qualified as Text import Skeletest.Internal.Error (SkeletestError) import Skeletest.Internal.Preprocessor (processFile)+import Skeletest.Internal.Preprocessor qualified as Preprocessor  main :: IO () main = handleErrors $ do@@ -37,8 +42,10 @@    getArgs >>= \case     -- https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/phases.html#options-affecting-a-haskell-pre-processor-    [fp, input, output] -> Text.readFile input >>= processFile fp >>= Text.writeFile output-    _ -> error "The skeletest preprocessor does not accept any additional arguments."+    fp : input : output : args -> do+      options <- either error pure $ foldlM parseOpts Preprocessor.defaultOptions args+      Text.readFile input >>= processFile options fp >>= Text.writeFile output+    _ -> error "The skeletest preprocessor expects at least three arguments."  -- | Output SkeletestError handleErrors :: IO a -> IO a@@ -49,3 +56,24 @@   normalizeLines     | __GLASGOW_HASKELL__ == (908 :: Int) = dropWhileEnd (== '\n')     | otherwise = id++parseOpts :: Preprocessor.Options -> String -> Either String Preprocessor.Options+parseOpts opts argStr+  | Just (mMainMod, mMainFunc) <- Text.stripPrefix "main:" arg >>= parseMain =+      Right+        . maybe id (\s o -> o{Preprocessor.mainModuleName = s}) mMainMod+        . maybe id (\s o -> o{Preprocessor.mainFuncName = s}) mMainFunc+        $ opts+  | otherwise = Left $ "Unknown option: " <> argStr+ where+  arg = Text.pack argStr+  parseMain s =+    case Text.splitOn "." s of+      [modName, modFunc] -> Just (Just modName, Just modFunc)+      [_] -> do+        (c, _) <- Text.uncons s+        Just $+          if isUpper c+            then (Just s, Nothing)+            else (Nothing, Just s)+      _ -> Nothing
test/Skeletest/AssertionsSpec.hs view
@@ -86,6 +86,24 @@       stderr `shouldBe` ""       stdout `shouldSatisfy` P.matchesSnapshot +  describe "shouldReturn" $ do+    it "should pass" $+      pure 1 `shouldReturn` (1 :: Int)++    integration . it "should show helpful failure" $ do+      runner <- getFixture+      addTestFile runner "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = it \"should fail\" $ pure 1 `shouldReturn` (2 :: Int)"+        ]++      (stdout, stderr) <- expectFailure $ runTests runner []+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot+   describe "context" $ do     integration . it "should show failure context" $ do       runner <- getFixture
test/Skeletest/__snapshots__/AssertionsSpec.snap.md view
@@ -85,6 +85,20 @@ ╰─────────────────────────────────────────────────────────────────────────────── ``` +## shouldReturn / should show helpful failure++```+./ExampleSpec.hs+╭── should fail: FAIL+│ ./ExampleSpec.hs:5:+│ │+│ │ spec = it "should fail" $ pure 1 `shouldReturn` (2 :: Int)+│ │                                  ^^^^^^^^^^^^^^+│ +│ 1 ≠ 2+╰───────────────────────────────────────────────────────────────────────────────+```+ ## shouldSatisfy / should show helpful failure  ```