{-# 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.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
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 = 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
overapproximatedDependencies Config RegionDeltas
cfg)
([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 ()
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
([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 [])
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
ormoluFile ::
(MonadIO m) =>
Config RegionIndices ->
FilePath ->
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
ormoluStdin ::
(MonadIO m) =>
Config RegionIndices ->
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>"
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 :: [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 (Maybe PackageName, 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 (Maybe PackageName, ModuleName))
unModuleReexports ModuleReexports
reexports,
ModuleReexports
-> Map ModuleName (NonEmpty (Maybe PackageName, ModuleName))
unModuleReexports (forall region. Config region -> ModuleReexports
cfgModuleReexports Config region
rawConfig),
ModuleReexports
-> Map ModuleName (NonEmpty (Maybe PackageName, 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 ->
([], 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
..} ->
([DynOption]
ciDynOpts, 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 ([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)
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
]
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