{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}

-- | A formatter for Haskell source code.
module Ormolu
  ( ormolu,
    ormoluFile,
    ormoluStdin,
    Config (..),
    ColorMode (..),
    RegionIndices (..),
    SourceType (..),
    defaultConfig,
    detectSourceType,
    DynOption (..),
    PrinterOpts (..),
    PrinterOptsPartial,
    PrinterOptsTotal,
    defaultPrinterOpts,
    loadConfigFile,
    ConfigFileLoadResult (..),
    configFileName,
    fillMissingPrinterOpts,
    OrmoluException (..),
    withPrettyOrmoluExceptions,
  )
where

import Control.Exception
import Control.Monad
import Control.Monad.IO.Class (MonadIO (..))
import Data.Text (Text)
import qualified Data.Text as T
import Debug.Trace
import qualified GHC.Driver.CmdLine as GHC
import qualified GHC.Types.SrcLoc as GHC
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.IO
import System.FilePath

-- | Format a 'String', return formatted version as 'Text'.
--
-- The function
--
--     * Takes 'String' because that's what GHC parser accepts.
--     * 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
  String ->
  m Text
ormolu :: Config RegionIndices -> FilePath -> FilePath -> m Text
ormolu Config RegionIndices
cfgWithIndices FilePath
path FilePath
originalInput = do
  let totalLines :: Int
totalLines = [FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (FilePath -> [FilePath]
lines FilePath
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 :: LazyFixityMap
fixityMap =
        -- It is important to keep all arguments (but last) of
        -- 'buildFixityMap' constant (such as 'defaultStrategyThreshold'),
        -- otherwise it is going to break memoization.
        Float -> Set FilePath -> LazyFixityMap
buildFixityMap
          Float
defaultStrategyThreshold
          (Config RegionDeltas -> Set FilePath
forall region. Config region -> Set FilePath
cfgDependencies Config RegionDeltas
cfg) -- memoized on the set of dependencies
  ([Warn]
warnings, [SourceSnippet]
result0) <-
    Config RegionDeltas
-> LazyFixityMap
-> (SrcSpan -> FilePath -> OrmoluException)
-> FilePath
-> FilePath
-> m ([Warn], [SourceSnippet])
forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> (SrcSpan -> FilePath -> OrmoluException)
-> FilePath
-> FilePath
-> m ([Warn], [SourceSnippet])
parseModule' Config RegionDeltas
cfg LazyFixityMap
fixityMap SrcSpan -> FilePath -> OrmoluException
OrmoluParsingFailed FilePath
path FilePath
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
    FilePath -> m ()
forall (f :: * -> *). Applicative f => FilePath -> f ()
traceM FilePath
"warnings:\n"
    FilePath -> m ()
forall (f :: * -> *). Applicative f => FilePath -> f ()
traceM ((Warn -> FilePath) -> [Warn] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Warn -> FilePath
showWarn [Warn]
warnings)
    [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 -> FilePath -> m ()
forall (f :: * -> *). Applicative f => FilePath -> f ()
traceM (FilePath -> m ())
-> (ParseResult -> FilePath) -> ParseResult -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommentStream -> FilePath
showCommentStream (CommentStream -> FilePath)
-> (ParseResult -> CommentStream) -> ParseResult -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseResult -> CommentStream
prCommentStream (ParseResult -> m ()) -> ParseResult -> m ()
forall a b. (a -> b) -> a -> b
$ ParseResult
r
      SourceSnippet
_ -> () -> m ()
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] -> PrinterOptsTotal -> Text
printSnippets [SourceSnippet]
result0 (PrinterOptsTotal -> Text) -> PrinterOptsTotal -> Text
forall a b. (a -> b) -> a -> b
$ Config RegionIndices -> PrinterOptsTotal
forall region. Config region -> PrinterOptsTotal
cfgPrinterOpts Config RegionIndices
cfgWithIndices
  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.
    ([Warn]
_, [SourceSnippet]
result1) <-
      Config RegionDeltas
-> LazyFixityMap
-> (SrcSpan -> FilePath -> OrmoluException)
-> FilePath
-> FilePath
-> m ([Warn], [SourceSnippet])
forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> (SrcSpan -> FilePath -> OrmoluException)
-> FilePath
-> FilePath
-> m ([Warn], [SourceSnippet])
parseModule'
        Config RegionDeltas
cfg
        LazyFixityMap
fixityMap
        SrcSpan -> FilePath -> OrmoluException
OrmoluOutputParsingFailed
        FilePath
path
        (Text -> FilePath
T.unpack 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 (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 -> FilePath -> Maybe TextDiff
diffText (FilePath -> Text
T.pack FilePath
originalInput) Text
formattedText FilePath
path of
            Maybe TextDiff
Nothing -> FilePath -> TextDiff
forall a. HasCallStack => FilePath -> a
error FilePath
"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 (t :: * -> *) a. Foldable t => t a -> Int
length [SourceSnippet]
result0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [SourceSnippet] -> 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 (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 (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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
      let reformattedText :: Text
reformattedText = [SourceSnippet] -> PrinterOptsTotal -> Text
printSnippets [SourceSnippet]
result1 (PrinterOptsTotal -> Text) -> PrinterOptsTotal -> Text
forall a b. (a -> b) -> a -> b
$ Config RegionIndices -> PrinterOptsTotal
forall region. Config region -> PrinterOptsTotal
cfgPrinterOpts Config RegionIndices
cfgWithIndices
       in case Text -> Text -> FilePath -> Maybe TextDiff
diffText Text
formattedText Text
reformattedText FilePath
path of
            Maybe TextDiff
Nothing -> () -> IO ()
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 (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 :: Config RegionIndices -> FilePath -> m Text
ormoluFile Config RegionIndices
cfg FilePath
path =
  FilePath -> m Text
forall (m :: * -> *). MonadIO m => FilePath -> m Text
readFileUtf8 FilePath
path m Text -> (Text -> m Text) -> m Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config RegionIndices -> FilePath -> FilePath -> m Text
forall (m :: * -> *).
MonadIO m =>
Config RegionIndices -> FilePath -> FilePath -> m Text
ormolu Config RegionIndices
cfg FilePath
path (FilePath -> m Text) -> (Text -> FilePath) -> Text -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack

-- | 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 :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config RegionIndices -> FilePath -> FilePath -> m Text
forall (m :: * -> *).
MonadIO m =>
Config RegionIndices -> FilePath -> FilePath -> m Text
ormolu Config RegionIndices
cfg FilePath
"<stdin>" (FilePath -> m Text) -> (Text -> FilePath) -> Text -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack

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

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

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

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