morley-1.14.0: doctests/Main.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

module Main
  ( main
  ) where

import qualified Data.ByteString as BS
import Data.Char (isSpace)
import qualified Data.List as List
import Distribution.Fields (runParseResult, showPError)
import Distribution.PackageDescription
  (BuildInfo(defaultExtensions, targetBuildDepends), CondTree(condTreeData),
  GenericPackageDescription(condLibrary), Library(libBuildInfo))
import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
import Distribution.Simple (Extension(EnableExtension), depPkgName, unPackageName)
import Options.Applicative
  (ParserInfo, execParser, flag', fullDesc, help, helper, info, long, metavar, progDesc, short,
  showDefault, strArgument, strOption, value)
import System.Environment (lookupEnv)
import System.Process (readProcess)
import Test.DocTest (doctest)

-- | Runs 'doctest' on the 'morley' package.
--
-- To run via stack, simply run:
--
-- > stack test morley:test:doctests
--
-- Otherwise, you'll need to specify 3 things:
--
-- * The location of the GHC's package database
-- * The location of morley's source code
-- * The location of morley's cabal file
--
-- > ./doctests --cabal-file code/morley/morley.cabal -- -package-db=<pkg-db-dir> -i code/morley/src
--
-- Any other arguments passed to this program will be forwarded to @doctest@.
main :: IO ()
main = do
  opts <- execParser parserInfo
  doctestArgs <- getDoctestArgs opts

  log opts "Running doctest with args:"
  traverse_ (log opts . mappend "  ") doctestArgs

  putTextLn "Running doctest."
  doctest doctestArgs

data Options = Options
  { cabalFile :: FilePath
  , verbosity :: Maybe Int
  , otherArgs :: [String]
  }
  deriving stock Show

parserInfo :: ParserInfo Options
parserInfo =
  info
    (optionsParser <**> helper)
    (mconcat
      [ fullDesc
      , progDesc "Run doctests. All arguments passed after '--' will be passed down to doctest and GHC."
      ]
    )
  where
    optionsParser =
      Options
      <$> strOption
          (mconcat
            [ long "cabal-file"
            , value "morley.cabal"
            , showDefault
            , metavar "FILEPATH"
            , help "Filepath for the .cabal file"
            ]
          )
      <*> (fmap (fmap length) . optional . some . flag' () . mconcat $
            [ short 'V'
            , help "Increase verbosity (pass up to 5 times to increase further, e.g. '-VVV').\
                   \ This flag will be passed down to doctest and GHC."
            ]
          )
      <*> many (strArgument (metavar "ARGS..." ))

-- | Get all the arguments needed to run `doctest`.
getDoctestArgs :: Options -> IO [String]
getDoctestArgs opts = do
  lib <- getCabalLibComponent opts
  argsFromStack <- getArgsFromStack opts

  pure $
    [ "-package-env=-"
    , "-hide-all-packages"
    ]
    <> maybeToList (getGHCVerbosityFlag opts)
    <> argsFromStack
    <> (getDependencies lib <&> \pkg -> "-package=" <> pkg)
    <> (getEnabledExtensions lib <&> \ext -> "-X" <> ext)
    <> otherArgs opts

-- | If this program is running via @stack@, then we can:
--
-- * guess where the source code is located
-- * use @stack@ to find out where the package database is located
--
-- Otherwise, these arguments will have to be specified by the user, via the
-- @-package-db@ and @-i@ flags.
getArgsFromStack :: Options -> IO [String]
getArgsFromStack opts = do
  -- If 'STACK_EXE' is set, we assume we're running via 'stack' and not,
  -- for example, via cabal or haskell.nix.
  lookupEnv "STACK_EXE" >>= \case
    Nothing ->  do
      log opts "The environment variable 'STACK_EXE' is not set."
      pure []
    Just stackBin -> do
      log opts $ "The environment variable 'STACK_EXE' is set: " <> stackBin
      log opts "Assuming we're running via stack."
      snapshotPkgDb <- readProcess stackBin ["path", "--snapshot-pkg-db"] []
      localPkgDb <- readProcess stackBin ["path", "--local-pkg-db"] []
      pure
        [ "-package-db=" <> List.dropWhileEnd isSpace snapshotPkgDb
        , "-package-db=" <> List.dropWhileEnd isSpace localPkgDb
        , "-i", "src"
        ]

-- | Parse a cabal file and extract info about its "library" component.
getCabalLibComponent :: Options -> IO Library
getCabalLibComponent opts = do
  let cabalFilePath = cabalFile opts
  log opts $ "Reading cabal file:" <> cabalFilePath
  contents <- BS.readFile cabalFilePath
  case snd <$> runParseResult $ parseGenericPackageDescription contents of
    Left (version, err :| errs) -> do
      die $ toString $ List.unlines $
        [ "Failed to parse .cabal file: " <> cabalFilePath
        , "Version: " <> show version
        , "Errors:"
        ]
        <> (showPError cabalFilePath <$> (err : errs))
    Right cabal -> do
      case condLibrary cabal of
        Nothing -> die "Cabal file did not contain a library component."
        Just condTreeLib -> pure $ condTreeData condTreeLib

getEnabledExtensions :: Library -> [String]
getEnabledExtensions lib =
  libBuildInfo lib & defaultExtensions & mapMaybe \case
    EnableExtension extension -> Just $ show extension
    _ -> Nothing

getDependencies :: Library -> [String]
getDependencies lib =
  libBuildInfo lib & targetBuildDepends & fmap (unPackageName . depPkgName)

-- | Due to a limitation in optparse-applicative, our @-V@ flag has a
-- different syntax than GHC's @-v@ flag.
--
-- Our @-VVV@ corresponds to @-v3@ in GHC.
--
-- This function transforms our syntax into GHC's.
getGHCVerbosityFlag :: Options -> Maybe String
getGHCVerbosityFlag opts =
  verbosity opts <&> \i -> "-v" <> show i

log :: Options -> String -> IO ()
log opts msg =
  whenJust (verbosity opts) \_ ->
    putStrLn msg