{-# LANGUAGE PackageImports #-}

module Freckle.App.Test.DocTest
  ( doctest
  , doctestWith

  -- * Lower-level, for site-specific use
  , findPackageFlags
  , findDocTestedFiles
  ) where

import Freckle.App.Prelude

import Control.Monad (filterM)
import Data.Aeson
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Yaml (decodeFileThrow)
import "Glob" System.FilePath.Glob (globDir1)
import qualified Test.DocTest as DocTest

-- | Run doctest on files in the given directory
doctest :: FilePath -> IO ()
doctest :: String -> IO ()
doctest = [String] -> String -> IO ()
doctestWith []

-- | Run doctest on files in the given directory and with additional flags
doctestWith :: [String] -> FilePath -> IO ()
doctestWith :: [String] -> String -> IO ()
doctestWith [String]
flags String
dir = do
  [String]
packageFlags <- IO [String]
findPackageFlags
  [String]
sourceFiles <- String -> IO [String]
findDocTestedFiles String
dir
  [String] -> IO ()
DocTest.doctest forall a b. (a -> b) -> a -> b
$ [String]
packageFlags forall a. Semigroup a => a -> a -> a
<> [String]
flags forall a. Semigroup a => a -> a -> a
<> [String]
sourceFiles

-- | Representation of only the information we need in a @package.yaml@
data PackageYaml = PackageYaml
  { PackageYaml -> [String]
defaultExtensions :: [String]
  , PackageYaml -> String
name :: String
  }

instance FromJSON PackageYaml where
  parseJSON :: Value -> Parser PackageYaml
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"PackageYaml"
    forall a b. (a -> b) -> a -> b
$ \Object
o -> [String] -> String -> PackageYaml
PackageYaml forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"default-extensions" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"

-- Parse @default-extensions@ and @name& out of @package.yaml@
--
-- NB. This won't find target-specific extensions. If your package does this
-- (consider not, then) add them via the direct argument to @'doctestWith'@.
--
findPackageFlags :: IO [String]
findPackageFlags :: IO [String]
findPackageFlags = do
  PackageYaml {String
[String]
name :: String
defaultExtensions :: [String]
name :: PackageYaml -> String
defaultExtensions :: PackageYaml -> [String]
..} <- forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
decodeFileThrow String
"package.yaml"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (String
"-package " forall a. Semigroup a => a -> a -> a
<> String
name) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (String
"-X" forall a. Semigroup a => a -> a -> a
<>) [String]
defaultExtensions

-- | Find any source files with doctest comments
--
-- Doctest with a lot of files is really slow. Like /really/ slow:
--
-- <https://github.com/sol/doctest/issues/141>
--
-- Also, some suites won't actually work on a lot of our files because of some
-- instance-import-related debt that we don't have the time to clean up at this
-- time:
--
-- <https://freckleinc.slack.com/archives/C459XJBGR/p1519220418000125>
--
-- So we want to only run doctest for files that need it. This function finds
-- such files by /naively/ looking for the @^-- >>>@ pattern.
--
findDocTestedFiles :: FilePath -> IO [FilePath]
findDocTestedFiles :: String -> IO [String]
findDocTestedFiles String
dir = do
  [String]
paths <- Pattern -> String -> IO [String]
globDir1 Pattern
"**/*.hs" String
dir
  forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Bool
hasDocTests forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Text
T.readFile) [String]
paths

hasDocTests :: Text -> Bool
hasDocTests :: Text -> Bool
hasDocTests = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text
"-- >>>" Text -> Text -> Bool
`T.isInfixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines