{-# LANGUAGE PackageImports #-}
module Freckle.App.Test.DocTest
( doctest
, doctestWith
, 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
doctest :: FilePath -> IO ()
doctest :: FilePath -> IO ()
doctest = [FilePath] -> FilePath -> IO ()
doctestWith []
doctestWith :: [String] -> FilePath -> IO ()
doctestWith :: [FilePath] -> FilePath -> IO ()
doctestWith [FilePath]
flags FilePath
dir = do
[FilePath]
packageFlags <- IO [FilePath]
findPackageFlags
[FilePath]
sourceFiles <- FilePath -> IO [FilePath]
findDocTestedFiles FilePath
dir
[FilePath] -> IO ()
DocTest.doctest ([FilePath] -> IO ()) -> [FilePath] -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath]
packageFlags [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath]
flags [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath]
sourceFiles
data PackageYaml = PackageYaml
{ PackageYaml -> [FilePath]
defaultExtensions :: [String]
, PackageYaml -> FilePath
name :: String
}
instance FromJSON PackageYaml where
parseJSON :: Value -> Parser PackageYaml
parseJSON = FilePath
-> (Object -> Parser PackageYaml) -> Value -> Parser PackageYaml
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"PackageYaml"
((Object -> Parser PackageYaml) -> Value -> Parser PackageYaml)
-> (Object -> Parser PackageYaml) -> Value -> Parser PackageYaml
forall a b. (a -> b) -> a -> b
$ \Object
o -> [FilePath] -> FilePath -> PackageYaml
PackageYaml ([FilePath] -> FilePath -> PackageYaml)
-> Parser [FilePath] -> Parser (FilePath -> PackageYaml)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser [FilePath]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"default-extensions" Parser (FilePath -> PackageYaml)
-> Parser FilePath -> Parser PackageYaml
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser FilePath
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
findPackageFlags :: IO [String]
findPackageFlags :: IO [FilePath]
findPackageFlags = do
PackageYaml {FilePath
[FilePath]
name :: FilePath
defaultExtensions :: [FilePath]
name :: PackageYaml -> FilePath
defaultExtensions :: PackageYaml -> [FilePath]
..} <- FilePath -> IO PackageYaml
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => FilePath -> m a
decodeFileThrow FilePath
"package.yaml"
[FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath
"-package " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
name) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-X" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>) [FilePath]
defaultExtensions
findDocTestedFiles :: FilePath -> IO [FilePath]
findDocTestedFiles :: FilePath -> IO [FilePath]
findDocTestedFiles FilePath
dir = do
[FilePath]
paths <- Pattern -> FilePath -> IO [FilePath]
globDir1 Pattern
"**/*.hs" FilePath
dir
(FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Text -> Bool) -> IO Text -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Bool
hasDocTests (IO Text -> IO Bool)
-> (FilePath -> IO Text) -> FilePath -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO Text
T.readFile) [FilePath]
paths
hasDocTests :: Text -> Bool
hasDocTests :: Text -> Bool
hasDocTests = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text
"-- >>>" Text -> Text -> Bool
`T.isInfixOf`) ([Text] -> Bool) -> (Text -> [Text]) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines