Extensions.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Ormolu.Utils.Extensions
  ( Extension (..),
    getExtensionsFromCabalFile,
    findCabalFile,
    getCabalExtensionDynOptions,
  )
where

import Control.Exception
import Control.Monad.IO.Class
import qualified Data.ByteString as B
import Data.List (find)
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M
import Data.Maybe (maybeToList)
import qualified Distribution.ModuleName as ModuleName
import Distribution.PackageDescription
import Distribution.PackageDescription.Parsec
import Language.Haskell.Extension
import Ormolu.Config
import Ormolu.Exception
import System.Directory
import System.FilePath
import System.IO.Error (isDoesNotExistError)

-- | Get a map from Haskell source file paths (without any extensions)
-- to its default language extensions
getExtensionsFromCabalFile ::
  MonadIO m =>
  -- | Path to cabal file
  FilePath ->
  m (Map FilePath [DynOption])
getExtensionsFromCabalFile cabalFile = liftIO $ do
  GenericPackageDescription {..} <-
    parseGenericPackageDescriptionMaybe <$> B.readFile cabalFile >>= \case
      Just gpd -> pure gpd
      Nothing -> throwIO $ OrmoluCabalFileParsingFailed cabalFile
  let lib = maybeToList condLibrary
      sublibs = snd <$> condSubLibraries
  pure . M.unions . concat $
    [ buildMap extractFromLibrary <$> lib ++ sublibs,
      buildMap extractFromExecutable . snd <$> condExecutables,
      buildMap extractFromTestSuite . snd <$> condTestSuites,
      buildMap extractFromBenchmark . snd <$> condBenchmarks
    ]
  where
    buildMap f a = let (files, exts) = f (condTreeData a) in M.fromList $ (,exts) <$> files

    extractFromBuildInfo extraModules BuildInfo {..} = (,exts) $ do
      m <- extraModules ++ (ModuleName.toFilePath <$> otherModules)
      (takeDirectory cabalFile </>) . (</> dropExtensions m) <$> hsSourceDirs
      where
        exts = maybe [] langExt defaultLanguage ++ fmap extToDynOption defaultExtensions
        langExt =
          pure . DynOption . \case
            Haskell98 -> "-XHaskell98"
            Haskell2010 -> "-XHaskell2010"
            UnknownLanguage lan -> "-X" ++ lan
        extToDynOption =
          DynOption . \case
            EnableExtension e -> "-X" ++ show e
            DisableExtension e -> "-XNo" ++ show e
            UnknownExtension e -> "-X" ++ e

    extractFromLibrary Library {..} =
      extractFromBuildInfo (ModuleName.toFilePath <$> exposedModules) libBuildInfo
    extractFromExecutable Executable {..} =
      extractFromBuildInfo [modulePath] buildInfo
    extractFromTestSuite TestSuite {..} =
      extractFromBuildInfo mainPath testBuildInfo
      where
        mainPath = case testInterface of
          TestSuiteExeV10 _ p -> [p]
          TestSuiteLibV09 _ p -> [ModuleName.toFilePath p]
          TestSuiteUnsupported {} -> []
    extractFromBenchmark Benchmark {..} =
      extractFromBuildInfo mainPath benchmarkBuildInfo
      where
        mainPath = case benchmarkInterface of
          BenchmarkExeV10 _ p -> [p]
          BenchmarkUnsupported {} -> []

-- | Find the path to an appropriate .cabal file for a Haskell
-- source file, if available
findCabalFile ::
  MonadIO m =>
  -- | Absolute path to a Haskell source file in a project with a .cabal file
  FilePath ->
  m (Maybe FilePath)
findCabalFile p = liftIO $ do
  let parentDir = takeDirectory p
  ps <-
    listDirectory parentDir `catch` \case
      (isDoesNotExistError -> True) -> pure []
      e -> throwIO e
  case find ((== ".cabal") . takeExtension) ps of
    Just cabalFile -> pure . Just $ parentDir </> cabalFile
    Nothing ->
      if isDrive parentDir
        then pure Nothing
        else findCabalFile parentDir

-- | Get the default language extensions of a Haskell source file.
-- The .cabal file can be provided explicitly or auto-detected.
getCabalExtensionDynOptions ::
  MonadIO m =>
  -- | Haskell source file
  FilePath ->
  m [DynOption]
getCabalExtensionDynOptions sourceFile' = liftIO $ do
  sourceFile <- makeAbsolute sourceFile'
  mCabalFile <- findCabalFile sourceFile
  case mCabalFile of
    Just cabalFile -> do
      extsByFile <- getExtensionsFromCabalFile cabalFile
      pure $ M.findWithDefault [] (dropExtensions sourceFile) extsByFile
    Nothing -> pure []