{-# LANGUAGE BangPatterns #-}
{-# 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
    FixityMap,
    getFixityOverridesForSourceFile,

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

import Control.Exception
import Control.Monad
import Control.Monad.IO.Class (MonadIO (..))
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
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 qualified Ormolu.Utils.Cabal as CabalUtils
import Ormolu.Utils.Fixity (getFixityOverridesForSourceFile)
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 :: 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 PackageName -> LazyFixityMap
buildFixityMap
          Float
defaultStrategyThreshold
          (Config RegionDeltas -> Set PackageName
forall region. Config region -> Set PackageName
cfgDependencies Config RegionDeltas
cfg) -- memoized on the set of dependencies
  ([Warn]
warnings, [SourceSnippet]
result0) <-
    Config RegionDeltas
-> LazyFixityMap
-> (SrcSpan -> String -> OrmoluException)
-> String
-> Text
-> m ([Warn], [SourceSnippet])
forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> (SrcSpan -> String -> OrmoluException)
-> String
-> Text
-> m ([Warn], [SourceSnippet])
parseModule' Config RegionDeltas
cfg LazyFixityMap
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
    String -> m ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM String
"warnings:\n"
    String -> m ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM ((Warn -> String) -> [Warn] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Warn -> String
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 -> String -> m ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (String -> m ()) -> (ParseResult -> String) -> ParseResult -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommentStream -> String
showCommentStream (CommentStream -> String)
-> (ParseResult -> CommentStream) -> ParseResult -> String
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 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 = [SourceSnippet] -> Text
printSnippets [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.
    ([Warn]
_, [SourceSnippet]
result1) <-
      Config RegionDeltas
-> LazyFixityMap
-> (SrcSpan -> String -> OrmoluException)
-> String
-> Text
-> m ([Warn], [SourceSnippet])
forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> (SrcSpan -> String -> OrmoluException)
-> String
-> Text
-> m ([Warn], [SourceSnippet])
parseModule'
        Config RegionDeltas
cfg
        LazyFixityMap
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 = [SourceSnippet] -> Text
printSnippets [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 FixityMap ->
  -- | 'Config' to refine
  Config region ->
  -- | Refined 'Config'
  Config region
refineConfig :: forall region.
SourceType
-> Maybe CabalInfo
-> Maybe FixityMap
-> Config region
-> Config region
refineConfig SourceType
sourceType Maybe CabalInfo
mcabalInfo Maybe FixityMap
mfixityOverrides Config region
rawConfig =
  Config region
rawConfig
    { cfgDynOptions :: [DynOption]
cfgDynOptions = Config region -> [DynOption]
forall region. Config region -> [DynOption]
cfgDynOptions Config region
rawConfig [DynOption] -> [DynOption] -> [DynOption]
forall a. [a] -> [a] -> [a]
++ [DynOption]
dynOptsFromCabal,
      cfgFixityOverrides :: FixityMap
cfgFixityOverrides =
        (FixityInfo -> FixityInfo -> FixityInfo)
-> FixityMap -> FixityMap -> FixityMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith FixityInfo -> FixityInfo -> FixityInfo
forall a. Semigroup a => a -> a -> a
(<>) (Config region -> FixityMap
forall region. Config region -> FixityMap
cfgFixityOverrides Config region
rawConfig) FixityMap
fixityOverrides,
      cfgDependencies :: Set PackageName
cfgDependencies =
        Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Config region -> Set PackageName
forall region. Config region -> Set PackageName
cfgDependencies Config region
rawConfig) Set PackageName
depsFromCabal,
      cfgSourceType :: SourceType
cfgSourceType = SourceType
sourceType
    }
  where
    fixityOverrides :: FixityMap
fixityOverrides =
      case Maybe FixityMap
mfixityOverrides of
        Maybe FixityMap
Nothing -> FixityMap
forall k a. Map k a
Map.empty
        Just FixityMap
x -> FixityMap
x
    ([DynOption]
dynOptsFromCabal, Set PackageName
depsFromCabal) =
      case Maybe CabalInfo
mcabalInfo of
        Maybe CabalInfo
Nothing -> ([], Set PackageName
forall a. Set a
Set.empty)
        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
  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
  Text ->
  m ([GHC.Warn], [SourceSnippet])
parseModule' :: forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> (SrcSpan -> String -> OrmoluException)
-> String
-> Text
-> m ([Warn], [SourceSnippet])
parseModule' Config RegionDeltas
cfg LazyFixityMap
fixityMap SrcSpan -> String -> OrmoluException
mkException String
path Text
str = do
  ([Warn]
warnings, Either (SrcSpan, String) [SourceSnippet]
r) <- Config RegionDeltas
-> LazyFixityMap
-> String
-> Text
-> m ([Warn], Either (SrcSpan, String) [SourceSnippet])
forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> String
-> Text
-> m ([Warn], Either (SrcSpan, String) [SourceSnippet])
parseModule Config RegionDeltas
cfg LazyFixityMap
fixityMap String
path Text
str
  case Either (SrcSpan, String) [SourceSnippet]
r of
    Left (SrcSpan
spn, String
err) -> IO ([Warn], [SourceSnippet]) -> m ([Warn], [SourceSnippet])
forall a. IO a -> m a
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 -> String -> OrmoluException
mkException SrcSpan
spn String
err)
    Right [SourceSnippet]
x -> ([Warn], [SourceSnippet]) -> m ([Warn], [SourceSnippet])
forall a. a -> m a
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
    [ DiagnosticReason -> String
forall o. Outputable o => o -> String
showOutputable DiagnosticReason
reason,
      Located String -> String
forall o. Outputable o => o -> String
showOutputable 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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".hsig"
    then SourceType
SignatureSource
    else SourceType
ModuleSource