{-# 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.Errors.Types
import GHC.Types.Error
import GHC.Types.SrcLoc
import GHC.Utils.Error
import Ormolu.Config
import Ormolu.Diff.ParseResult
import Ormolu.Diff.Text
import Ormolu.Exception
import Ormolu.Fixity
import Ormolu.Parser
import Ormolu.Parser.CommentStream (CommentStream (..))
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 = [Text] -> Int
forall a. [a] -> Int
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 (RegionIndices -> RegionDeltas)
-> Config RegionIndices -> Config RegionDeltas
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config RegionIndices
cfgWithIndices
      fixityMap :: PackageFixityMap
fixityMap =
        Set PackageName -> PackageFixityMap
packageFixityMap
          (Config RegionDeltas -> Set PackageName
forall region. Config region -> Set PackageName
overapproximatedDependencies Config RegionDeltas
cfg) -- memoized on the set of dependencies
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config RegionDeltas -> Bool
forall region. Config region -> Bool
cfgDebug Config RegionDeltas
cfg) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    String -> m ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"*** CONFIG ***", Config RegionDeltas -> String
forall a. Show a => a -> String
show Config RegionDeltas
cfg]
  (DriverMessages
warnings, [SourceSnippet]
result0) <-
    Config RegionDeltas
-> PackageFixityMap
-> (SrcSpan -> String -> OrmoluException)
-> String
-> Text
-> m (DriverMessages, [SourceSnippet])
forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> PackageFixityMap
-> (SrcSpan -> String -> OrmoluException)
-> String
-> Text
-> m (DriverMessages, [SourceSnippet])
parseModule' Config RegionDeltas
cfg PackageFixityMap
fixityMap SrcSpan -> String -> OrmoluException
OrmoluParsingFailed String
path Text
originalInput
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config RegionDeltas -> Bool
forall region. Config region -> Bool
cfgDebug Config RegionDeltas
cfg) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    DriverMessages -> (DriverMessage -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ DriverMessages
warnings ((DriverMessage -> m ()) -> m ())
-> (DriverMessage -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \DriverMessage
driverMsg -> do
      let driverMsgSDoc :: SDoc
driverMsgSDoc = DecoratedSDoc -> SDoc
formatBulleted (DecoratedSDoc -> SDoc) -> DecoratedSDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ DiagnosticOpts DriverMessage -> DriverMessage -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage DiagnosticOpts DriverMessage
DriverMessageOpts
forall opts. HasDefaultDiagnosticOpts opts => opts
defaultOpts DriverMessage
driverMsg
      String -> m ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"*** WARNING ***", SDoc -> String
forall o. Outputable o => o -> String
showOutputable SDoc
driverMsgSDoc]
    [SourceSnippet] -> (SourceSnippet -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SourceSnippet]
result0 ((SourceSnippet -> m ()) -> m ())
-> (SourceSnippet -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
      ParsedSnippet ParseResult
r -> do
        let CommentStream [LComment]
comments = ParseResult -> CommentStream
prCommentStream ParseResult
r
        [LComment] -> (LComment -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [LComment]
comments ((LComment -> m ()) -> m ()) -> (LComment -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(L RealSrcSpan
loc Comment
comment) ->
          String -> m ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"*** COMMENT ***", RealSrcSpan -> String
forall o. Outputable o => o -> String
showOutputable RealSrcSpan
loc, Comment -> String
forall a. Show a => a -> String
show Comment
comment]
      SourceSnippet
_ -> () -> m ()
forall a. a -> m a
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 = Bool -> [SourceSnippet] -> Text
printSnippets (Config RegionDeltas -> Bool
forall region. Config region -> Bool
cfgDebug Config RegionDeltas
cfg) [SourceSnippet]
result0
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Config RegionDeltas -> Bool
forall region. Config region -> Bool
cfgUnsafe Config RegionDeltas
cfg) Bool -> Bool -> Bool
|| Config RegionDeltas -> Bool
forall region. Config region -> Bool
cfgCheckIdempotence Config RegionDeltas
cfg) (m () -> m ()) -> m () -> m ()
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.
    (DriverMessages
_, [SourceSnippet]
result1) <-
      Config RegionDeltas
-> PackageFixityMap
-> (SrcSpan -> String -> OrmoluException)
-> String
-> Text
-> m (DriverMessages, [SourceSnippet])
forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> PackageFixityMap
-> (SrcSpan -> String -> OrmoluException)
-> String
-> Text
-> m (DriverMessages, [SourceSnippet])
parseModule'
        Config RegionDeltas
cfg
        PackageFixityMap
fixityMap
        SrcSpan -> String -> OrmoluException
OrmoluOutputParsingFailed
        String
path
        Text
formattedText
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config RegionDeltas -> Bool
forall region. Config region -> Bool
cfgUnsafe Config RegionDeltas
cfg) (m () -> m ()) -> (IO () -> m ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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 -> String -> TextDiff
forall a. HasCallStack => String -> a
error String
"AST differs, yet no changes have been introduced"
            Just TextDiff
x -> TextDiff
x
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([SourceSnippet] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceSnippet]
result0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [SourceSnippet] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceSnippet]
result1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        OrmoluException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (TextDiff -> [RealSrcSpan] -> OrmoluException
OrmoluASTDiffers TextDiff
diff [])
      [(SourceSnippet, SourceSnippet)]
-> ((SourceSnippet, SourceSnippet) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([SourceSnippet]
result0 [SourceSnippet]
-> [SourceSnippet] -> [(SourceSnippet, SourceSnippet)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [SourceSnippet]
result1) (((SourceSnippet, SourceSnippet) -> IO ()) -> IO ())
-> ((SourceSnippet, SourceSnippet) -> IO ()) -> IO ()
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 -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Different [RealSrcSpan]
ss -> OrmoluException -> IO ()
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 {}) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        (SourceSnippet, SourceSnippet)
_ -> OrmoluException -> IO ()
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.
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config RegionDeltas -> Bool
forall region. Config region -> Bool
cfgCheckIdempotence Config RegionDeltas
cfg) (m () -> m ()) -> (IO () -> m ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
      let reformattedText :: Text
reformattedText = Bool -> [SourceSnippet] -> Text
printSnippets (Config RegionDeltas -> Bool
forall region. Config region -> Bool
cfgDebug Config RegionDeltas
cfg) [SourceSnippet]
result1
       in case Text -> Text -> String -> Maybe TextDiff
diffText Text
formattedText Text
reformattedText String
path of
            Maybe TextDiff
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just TextDiff
diff -> OrmoluException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (TextDiff -> OrmoluException
OrmoluNonIdempotentOutput TextDiff
diff)
  Text -> m Text
forall a. a -> m a
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 =
  String -> m Text
forall (m :: * -> *). MonadIO m => String -> m Text
readFileUtf8 String
path m Text -> (Text -> m Text) -> m Text
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config RegionIndices -> String -> Text -> m Text
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 =
  m Text
forall (m :: * -> *). MonadIO m => m Text
getContentsUtf8 m Text -> (Text -> m Text) -> m Text
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config RegionIndices -> String -> Text -> m Text
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 = cfgDynOptions rawConfig ++ dynOptsFromCabal,
      cfgFixityOverrides =
        FixityOverrides $
          Map.unions
            [ unFixityOverrides fixityOverrides,
              unFixityOverrides (cfgFixityOverrides rawConfig),
              unFixityOverrides defaultFixityOverrides
            ],
      cfgModuleReexports =
        ModuleReexports $
          Map.unionsWith
            (<>)
            [ unModuleReexports reexports,
              unModuleReexports (cfgModuleReexports rawConfig),
              unModuleReexports defaultModuleReexports
            ],
      cfgDependencies =
        Set.union (cfgDependencies rawConfig) depsFromCabal,
      cfgSourceType = sourceType
    }
  where
    fixityOverrides :: FixityOverrides
fixityOverrides = FixityOverrides -> Maybe FixityOverrides -> FixityOverrides
forall a. a -> Maybe a -> a
fromMaybe FixityOverrides
defaultFixityOverrides Maybe FixityOverrides
mfixityOverrides
    reexports :: ModuleReexports
reexports = ModuleReexports -> Maybe ModuleReexports -> ModuleReexports
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]
Set PackageName
PackageName
ciPackageName :: PackageName
ciDynOpts :: [DynOption]
ciDependencies :: Set PackageName
ciCabalFilePath :: String
ciPackageName :: CabalInfo -> PackageName
ciDynOpts :: CabalInfo -> [DynOption]
ciDependencies :: CabalInfo -> Set PackageName
ciCabalFilePath :: CabalInfo -> String
..} ->
          -- 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, PackageName -> Set PackageName -> Set PackageName
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 (DriverMessages, [SourceSnippet])
parseModule' :: forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> PackageFixityMap
-> (SrcSpan -> String -> OrmoluException)
-> String
-> Text
-> m (DriverMessages, [SourceSnippet])
parseModule' Config RegionDeltas
cfg PackageFixityMap
fixityMap SrcSpan -> String -> OrmoluException
mkException String
path Text
str = do
  (DriverMessages
warnings, Either (SrcSpan, String) [SourceSnippet]
r) <- Config RegionDeltas
-> PackageFixityMap
-> String
-> Text
-> m (DriverMessages, Either (SrcSpan, String) [SourceSnippet])
forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> PackageFixityMap
-> String
-> Text
-> m (DriverMessages, 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) -> IO (DriverMessages, [SourceSnippet])
-> m (DriverMessages, [SourceSnippet])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DriverMessages, [SourceSnippet])
 -> m (DriverMessages, [SourceSnippet]))
-> IO (DriverMessages, [SourceSnippet])
-> m (DriverMessages, [SourceSnippet])
forall a b. (a -> b) -> a -> b
$ OrmoluException -> IO (DriverMessages, [SourceSnippet])
forall e a. Exception e => e -> IO a
throwIO (SrcSpan -> String -> OrmoluException
mkException SrcSpan
spn String
err)
    Right [SourceSnippet]
x -> (DriverMessages, [SourceSnippet])
-> m (DriverMessages, [SourceSnippet])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DriverMessages
warnings, [SourceSnippet]
x)

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