{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

-- | A formatter for Haskell source code. This module exposes the official
-- stable API, other modules may be not as reliable.
module Ormolu
  ( -- * Top-level formatting functions
    ormolu,
    ormoluFile,
    ormoluStdin,

    -- * Configuration
    Config (..),
    ColorMode (..),
    RegionIndices (..),
    SourceType (..),
    defaultConfig,
    detectSourceType,
    refineConfig,
    DynOption (..),

    -- * Cabal info
    CabalUtils.CabalSearchResult (..),
    CabalUtils.CabalInfo (..),
    CabalUtils.getCabalInfoForSourceFile,

    -- * Fixity overrides and module re-exports
    FixityOverrides,
    defaultFixityOverrides,
    ModuleReexports,
    defaultModuleReexports,
    getDotOrmoluForSourceFile,

    -- * Working with exceptions
    OrmoluException (..),
    withPrettyOrmoluExceptions,
  )
where

import Control.Exception
import Control.Monad
import Control.Monad.IO.Class (MonadIO (..))
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Debug.Trace
import GHC.Driver.CmdLine qualified as GHC
import GHC.Types.SrcLoc
import Ormolu.Config
import Ormolu.Diff.ParseResult
import Ormolu.Diff.Text
import Ormolu.Exception
import Ormolu.Fixity
import Ormolu.Parser
import Ormolu.Parser.CommentStream (showCommentStream)
import Ormolu.Parser.Result
import Ormolu.Printer
import Ormolu.Utils (showOutputable)
import Ormolu.Utils.Cabal qualified as CabalUtils
import Ormolu.Utils.Fixity (getDotOrmoluForSourceFile)
import Ormolu.Utils.IO
import System.FilePath

-- | Format a 'Text'.
--
-- The function
--
--     * Needs 'IO' because some functions from GHC that are necessary to
--       setup parsing context require 'IO'. There should be no visible
--       side-effects though.
--     * Takes file name just to use it in parse error messages.
--     * Throws 'OrmoluException'.
--
-- __NOTE__: The caller is responsible for setting the appropriate value in
-- the 'cfgSourceType' field. Autodetection of source type won't happen
-- here, see 'detectSourceType'.
ormolu ::
  (MonadIO m) =>
  -- | Ormolu configuration
  Config RegionIndices ->
  -- | Location of source file
  FilePath ->
  -- | Input to format
  Text ->
  m Text
ormolu :: forall (m :: * -> *).
MonadIO m =>
Config RegionIndices -> String -> Text -> m Text
ormolu Config RegionIndices
cfgWithIndices String
path Text
originalInput = do
  let totalLines :: Int
totalLines = forall (t :: * -> *) a. Foldable t => t a -> Int
length (Text -> [Text]
T.lines Text
originalInput)
      cfg :: Config RegionDeltas
cfg = Int -> RegionIndices -> RegionDeltas
regionIndicesToDeltas Int
totalLines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config RegionIndices
cfgWithIndices
      fixityMap :: PackageFixityMap
fixityMap =
        Set PackageName -> PackageFixityMap
packageFixityMap
          (forall region. Config region -> Set PackageName
cfgDependencies Config RegionDeltas
cfg) -- memoized on the set of dependencies
  ([Warn]
warnings, [SourceSnippet]
result0) <-
    forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> PackageFixityMap
-> (SrcSpan -> String -> OrmoluException)
-> String
-> Text
-> m ([Warn], [SourceSnippet])
parseModule' Config RegionDeltas
cfg PackageFixityMap
fixityMap SrcSpan -> String -> OrmoluException
OrmoluParsingFailed String
path Text
originalInput
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall region. Config region -> Bool
cfgDebug Config RegionDeltas
cfg) forall a b. (a -> b) -> a -> b
$ do
    forall (f :: * -> *). Applicative f => String -> f ()
traceM String
"warnings:\n"
    forall (f :: * -> *). Applicative f => String -> f ()
traceM (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Warn -> String
showWarn [Warn]
warnings)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SourceSnippet]
result0 forall a b. (a -> b) -> a -> b
$ \case
      ParsedSnippet ParseResult
r -> forall (f :: * -> *). Applicative f => String -> f ()
traceM forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommentStream -> String
showCommentStream forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseResult -> CommentStream
prCommentStream forall a b. (a -> b) -> a -> b
$ ParseResult
r
      SourceSnippet
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  -- We're forcing 'formattedText' here because otherwise errors (such as
  -- messages about not-yet-supported functionality) will be thrown later
  -- when we try to parse the rendered code back, inside of GHC monad
  -- wrapper which will lead to error messages presenting the exceptions as
  -- GHC bugs.
  let !formattedText :: Text
formattedText = [SourceSnippet] -> Text
printSnippets [SourceSnippet]
result0
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall region. Config region -> Bool
cfgUnsafe Config RegionDeltas
cfg) Bool -> Bool -> Bool
|| forall region. Config region -> Bool
cfgCheckIdempotence Config RegionDeltas
cfg) forall a b. (a -> b) -> a -> b
$ do
    -- Parse the result of pretty-printing again and make sure that AST
    -- is the same as AST of original snippet module span positions.
    ([Warn]
_, [SourceSnippet]
result1) <-
      forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> PackageFixityMap
-> (SrcSpan -> String -> OrmoluException)
-> String
-> Text
-> m ([Warn], [SourceSnippet])
parseModule'
        Config RegionDeltas
cfg
        PackageFixityMap
fixityMap
        SrcSpan -> String -> OrmoluException
OrmoluOutputParsingFailed
        String
path
        Text
formattedText
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall region. Config region -> Bool
cfgUnsafe Config RegionDeltas
cfg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      let diff :: TextDiff
diff = case Text -> Text -> String -> Maybe TextDiff
diffText Text
originalInput Text
formattedText String
path of
            Maybe TextDiff
Nothing -> forall a. HasCallStack => String -> a
error String
"AST differs, yet no changes have been introduced"
            Just TextDiff
x -> TextDiff
x
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceSnippet]
result0 forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceSnippet]
result1) forall a b. (a -> b) -> a -> b
$
        forall e a. Exception e => e -> IO a
throwIO (TextDiff -> [RealSrcSpan] -> OrmoluException
OrmoluASTDiffers TextDiff
diff [])
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([SourceSnippet]
result0 forall a b. [a] -> [b] -> [(a, b)]
`zip` [SourceSnippet]
result1) forall a b. (a -> b) -> a -> b
$ \case
        (ParsedSnippet ParseResult
s, ParsedSnippet ParseResult
s') -> case ParseResult -> ParseResult -> ParseResultDiff
diffParseResult ParseResult
s ParseResult
s' of
          ParseResultDiff
Same -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Different [RealSrcSpan]
ss -> forall e a. Exception e => e -> IO a
throwIO (TextDiff -> [RealSrcSpan] -> OrmoluException
OrmoluASTDiffers ([RealSrcSpan] -> TextDiff -> TextDiff
selectSpans [RealSrcSpan]
ss TextDiff
diff) [RealSrcSpan]
ss)
        (RawSnippet {}, RawSnippet {}) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        (SourceSnippet, SourceSnippet)
_ -> forall e a. Exception e => e -> IO a
throwIO (TextDiff -> [RealSrcSpan] -> OrmoluException
OrmoluASTDiffers TextDiff
diff [])
    -- Try re-formatting the formatted result to check if we get exactly
    -- the same output.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall region. Config region -> Bool
cfgCheckIdempotence Config RegionDeltas
cfg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      let reformattedText :: Text
reformattedText = [SourceSnippet] -> Text
printSnippets [SourceSnippet]
result1
       in case Text -> Text -> String -> Maybe TextDiff
diffText Text
formattedText Text
reformattedText String
path of
            Maybe TextDiff
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just TextDiff
diff -> forall e a. Exception e => e -> IO a
throwIO (TextDiff -> OrmoluException
OrmoluNonIdempotentOutput TextDiff
diff)
  forall (m :: * -> *) a. Monad m => a -> m a
return Text
formattedText

-- | Load a file and format it. The file stays intact and the rendered
-- version is returned as 'Text'.
--
-- __NOTE__: The caller is responsible for setting the appropriate value in
-- the 'cfgSourceType' field. Autodetection of source type won't happen
-- here, see 'detectSourceType'.
ormoluFile ::
  (MonadIO m) =>
  -- | Ormolu configuration
  Config RegionIndices ->
  -- | Location of source file
  FilePath ->
  -- | Resulting rendition
  m Text
ormoluFile :: forall (m :: * -> *).
MonadIO m =>
Config RegionIndices -> String -> m Text
ormoluFile Config RegionIndices
cfg String
path =
  forall (m :: * -> *). MonadIO m => String -> m Text
readFileUtf8 String
path forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadIO m =>
Config RegionIndices -> String -> Text -> m Text
ormolu Config RegionIndices
cfg String
path

-- | Read input from stdin and format it.
--
-- __NOTE__: The caller is responsible for setting the appropriate value in
-- the 'cfgSourceType' field. Autodetection of source type won't happen
-- here, see 'detectSourceType'.
ormoluStdin ::
  (MonadIO m) =>
  -- | Ormolu configuration
  Config RegionIndices ->
  -- | Resulting rendition
  m Text
ormoluStdin :: forall (m :: * -> *). MonadIO m => Config RegionIndices -> m Text
ormoluStdin Config RegionIndices
cfg =
  forall (m :: * -> *). MonadIO m => m Text
getContentsUtf8 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadIO m =>
Config RegionIndices -> String -> Text -> m Text
ormolu Config RegionIndices
cfg String
"<stdin>"

-- | Refine a 'Config' by incorporating given 'SourceType', 'CabalInfo', and
-- fixity overrides 'FixityMap'. You can use 'detectSourceType' to deduce
-- 'SourceType' based on the file extension,
-- 'CabalUtils.getCabalInfoForSourceFile' to obtain 'CabalInfo' and
-- 'getFixityOverridesForSourceFile' for 'FixityMap'.
--
-- @since 0.5.3.0
refineConfig ::
  -- | Source type to use
  SourceType ->
  -- | Cabal info for the file, if available
  Maybe CabalUtils.CabalInfo ->
  -- | Fixity overrides, if available
  Maybe FixityOverrides ->
  -- | Module re-exports, if available
  Maybe ModuleReexports ->
  -- | 'Config' to refine
  Config region ->
  -- | Refined 'Config'
  Config region
refineConfig :: forall region.
SourceType
-> Maybe CabalInfo
-> Maybe FixityOverrides
-> Maybe ModuleReexports
-> Config region
-> Config region
refineConfig SourceType
sourceType Maybe CabalInfo
mcabalInfo Maybe FixityOverrides
mfixityOverrides Maybe ModuleReexports
mreexports Config region
rawConfig =
  Config region
rawConfig
    { cfgDynOptions :: [DynOption]
cfgDynOptions = forall region. Config region -> [DynOption]
cfgDynOptions Config region
rawConfig forall a. [a] -> [a] -> [a]
++ [DynOption]
dynOptsFromCabal,
      cfgFixityOverrides :: FixityOverrides
cfgFixityOverrides =
        Map OpName FixityInfo -> FixityOverrides
FixityOverrides forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
            [ FixityOverrides -> Map OpName FixityInfo
unFixityOverrides FixityOverrides
fixityOverrides,
              FixityOverrides -> Map OpName FixityInfo
unFixityOverrides (forall region. Config region -> FixityOverrides
cfgFixityOverrides Config region
rawConfig),
              FixityOverrides -> Map OpName FixityInfo
unFixityOverrides FixityOverrides
defaultFixityOverrides
            ],
      cfgModuleReexports :: ModuleReexports
cfgModuleReexports =
        Map ModuleName (NonEmpty ModuleName) -> ModuleReexports
ModuleReexports forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith
            forall a. Semigroup a => a -> a -> a
(<>)
            [ ModuleReexports -> Map ModuleName (NonEmpty ModuleName)
unModuleReexports ModuleReexports
reexports,
              ModuleReexports -> Map ModuleName (NonEmpty ModuleName)
unModuleReexports (forall region. Config region -> ModuleReexports
cfgModuleReexports Config region
rawConfig),
              ModuleReexports -> Map ModuleName (NonEmpty ModuleName)
unModuleReexports ModuleReexports
defaultModuleReexports
            ],
      cfgDependencies :: Set PackageName
cfgDependencies =
        forall a. Ord a => Set a -> Set a -> Set a
Set.union (forall region. Config region -> Set PackageName
cfgDependencies Config region
rawConfig) Set PackageName
depsFromCabal,
      cfgSourceType :: SourceType
cfgSourceType = SourceType
sourceType
    }
  where
    fixityOverrides :: FixityOverrides
fixityOverrides = forall a. a -> Maybe a -> a
fromMaybe FixityOverrides
defaultFixityOverrides Maybe FixityOverrides
mfixityOverrides
    reexports :: ModuleReexports
reexports = forall a. a -> Maybe a -> a
fromMaybe ModuleReexports
defaultModuleReexports Maybe ModuleReexports
mreexports
    ([DynOption]
dynOptsFromCabal, Set PackageName
depsFromCabal) =
      case Maybe CabalInfo
mcabalInfo of
        Maybe CabalInfo
Nothing ->
          -- If no cabal info is provided, assume base as a dependency by
          -- default.
          ([], Set PackageName
defaultDependencies)
        Just CabalUtils.CabalInfo {String
[DynOption]
PackageName
Set PackageName
ciCabalFilePath :: CabalInfo -> String
ciDependencies :: CabalInfo -> Set PackageName
ciDynOpts :: CabalInfo -> [DynOption]
ciPackageName :: CabalInfo -> PackageName
ciCabalFilePath :: String
ciDependencies :: Set PackageName
ciDynOpts :: [DynOption]
ciPackageName :: PackageName
..} ->
          -- It makes sense to take into account the operator info for the
          -- package itself if we know it, as if it were its own dependency.
          ([DynOption]
ciDynOpts, forall a. Ord a => a -> Set a -> Set a
Set.insert PackageName
ciPackageName Set PackageName
ciDependencies)

----------------------------------------------------------------------------
-- Helpers

-- | A wrapper around 'parseModule'.
parseModule' ::
  (MonadIO m) =>
  -- | Ormolu configuration
  Config RegionDeltas ->
  -- | Fixity Map for operators
  PackageFixityMap ->
  -- | How to obtain 'OrmoluException' to throw when parsing fails
  (SrcSpan -> String -> OrmoluException) ->
  -- | File name to use in errors
  FilePath ->
  -- | Actual input for the parser
  Text ->
  m ([GHC.Warn], [SourceSnippet])
parseModule' :: forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> PackageFixityMap
-> (SrcSpan -> String -> OrmoluException)
-> String
-> Text
-> m ([Warn], [SourceSnippet])
parseModule' Config RegionDeltas
cfg PackageFixityMap
fixityMap SrcSpan -> String -> OrmoluException
mkException String
path Text
str = do
  ([Warn]
warnings, Either (SrcSpan, String) [SourceSnippet]
r) <- forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> PackageFixityMap
-> String
-> Text
-> m ([Warn], Either (SrcSpan, String) [SourceSnippet])
parseModule Config RegionDeltas
cfg PackageFixityMap
fixityMap String
path Text
str
  case Either (SrcSpan, String) [SourceSnippet]
r of
    Left (SrcSpan
spn, String
err) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO (SrcSpan -> String -> OrmoluException
mkException SrcSpan
spn String
err)
    Right [SourceSnippet]
x -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Warn]
warnings, [SourceSnippet]
x)

-- | Pretty-print a 'GHC.Warn'.
showWarn :: GHC.Warn -> String
showWarn :: Warn -> String
showWarn (GHC.Warn DiagnosticReason
reason Located String
l) =
  [String] -> String
unlines
    [ forall o. Outputable o => o -> String
showOutputable DiagnosticReason
reason,
      forall l e. GenLocated l e -> e
unLoc Located String
l
    ]

-- | Detect 'SourceType' based on the file extension.
detectSourceType :: FilePath -> SourceType
detectSourceType :: String -> SourceType
detectSourceType String
mpath =
  if String -> String
takeExtension String
mpath forall a. Eq a => a -> a -> Bool
== String
".hsig"
    then SourceType
SignatureSource
    else SourceType
ModuleSource