{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module Ormolu
(
ormolu,
ormoluFile,
ormoluStdin,
Config (..),
ColorMode (..),
RegionIndices (..),
SourceType (..),
defaultConfig,
detectSourceType,
refineConfig,
DynOption (..),
CabalUtils.CabalSearchResult (..),
CabalUtils.CabalInfo (..),
CabalUtils.getCabalInfoForSourceFile,
FixityOverrides,
defaultFixityOverrides,
ModuleReexports,
defaultModuleReexports,
getDotOrmoluForSourceFile,
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
ormolu ::
(MonadIO m) =>
Config RegionIndices ->
FilePath ->
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)
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 ()
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
(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 [])
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
ormoluFile ::
(MonadIO m) =>
Config RegionIndices ->
FilePath ->
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
ormoluStdin ::
(MonadIO m) =>
Config RegionIndices ->
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>"
refineConfig ::
SourceType ->
Maybe CabalUtils.CabalInfo ->
Maybe FixityOverrides ->
Maybe ModuleReexports ->
Config region ->
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 ->
([], 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
..} ->
([DynOption]
ciDynOpts, PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => a -> Set a -> Set a
Set.insert PackageName
ciPackageName Set PackageName
ciDependencies)
parseModule' ::
(MonadIO m) =>
Config RegionDeltas ->
PackageFixityMap ->
(SrcSpan -> String -> OrmoluException) ->
FilePath ->
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)
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