SpecExtract.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveFunctor #-}
-- | Extract the descriptions from a SpecWith
module SpecExtract where

--------------------------------------------------------------------------------

import Test.Hspec
import Test.QuickCheck
import Control.Exception (evaluate)
import Test.Hspec.Core.Spec (Item(itemRequirement), SpecTree, Tree(..))
import Test.Hspec.Core.Runner
import System.Environment (getArgs)
import Control.Monad
import Data.Maybe (fromMaybe)
import Data.Foldable

--------------------------------------------------------------------------------

extractSpec :: IO ()
extractSpec = do
   (config, tree) <- evalSpec defaultConfig spec
   traverse_ ((traverse_ putStrLn) . (foldTree . extractLabels)) tree

-- | Load the spec descriptions into a 'TreeF'
extractLabels :: SpecTree a -> Fix TreeF
extractLabels = \case
  Node s trs -> Fix $ NodeF s (fmap extractLabels trs)
  NodeWithCleanup ma _ trs -> Fix $ NodeF (foldMap fst ma) (fmap extractLabels trs)
  Leaf it -> Fix $ LeafF $ itemRequirement it

--------------------------------------------------------------------------------

data TreeF r =
    NodeF String [r]
  | LeafF String
  deriving (Show, Functor)

{-
NodeF "describe1"
  [ NodeF "describe2"
      [ LeafF "it1"
      , LeafF "it2"
      ]
  , LeafF "it3"
  ]

[ "describe1/describe2/it1"
, "describe1/describe2/it2"
, "describe1/it3"
]
-}

data Fix f = Fix { unFix :: f (Fix f) }

type Alg f a = f a -> a

cata :: Functor f => Alg f a -> Fix f -> a
cata alg = alg . fmap (cata alg) . unFix 

-- | Fold a tree into a list of paths.
--
-- Note: we use @cata@ here because it is guaranteed to terminate and
-- bottom up recursion drastically simplifies the algorithm.
foldTree :: Fix TreeF -> [String]
foldTree = cata \case
  NodeF label paths -> fmap ((label <>) . ('/' :)) $ join paths
  LeafF label -> [label]

--------------------------------------------------------------------------------

spec :: Spec
spec = do
  describe "describe1" $ do
    describe "describe2" $ do
      it "it1" $ do
        head [23 ..] `shouldBe` (23 :: Int)

      describe "describe3" $ do
        it "it2" $
          property $ \x xs -> head (x:xs) == (x :: Int)

    it "it3" $ do
      evaluate (head []) `shouldThrow` anyException