{-# 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 Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Yaml (decodeFileThrow)
import Test.DocTest qualified as DocTest
import "Glob" System.FilePath.Glob (globDir1)

-- | 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 ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [String]
packageFlags [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
flags [String] -> [String] -> [String]
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 = String
-> (Object -> Parser PackageYaml) -> Value -> Parser PackageYaml
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"PackageYaml" ((Object -> Parser PackageYaml) -> Value -> Parser PackageYaml)
-> (Object -> Parser PackageYaml) -> Value -> Parser PackageYaml
forall a b. (a -> b) -> a -> b
$
    \Object
o -> [String] -> String -> PackageYaml
PackageYaml ([String] -> String -> PackageYaml)
-> Parser [String] -> Parser (String -> PackageYaml)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser [String]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"default-extensions" Parser (String -> PackageYaml)
-> Parser String -> Parser PackageYaml
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser String
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]
defaultExtensions :: PackageYaml -> [String]
name :: PackageYaml -> String
defaultExtensions :: [String]
name :: String
..} <- String -> IO PackageYaml
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
decodeFileThrow String
"package.yaml"
  [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String
"-package " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-X" <>) [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
  (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Text -> Bool) -> IO Text -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Bool
hasDocTests (IO Text -> IO Bool) -> (String -> IO Text) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Text
T.readFile) [String]
paths

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