{-# LANGUAGE LambdaCase #-}

module Ormolu.Utils.Fixity
  ( getDotOrmoluForSourceFile,
    parseFixityDeclarationStr,
    parseModuleReexportDeclarationStr,
  )
where

import Control.Exception (throwIO)
import Control.Monad.IO.Class
import Data.Bifunctor (first)
import Data.IORef
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Distribution.ModuleName (ModuleName)
import Distribution.Types.PackageName (PackageName)
import Ormolu.Exception
import Ormolu.Fixity
import Ormolu.Fixity.Parser
import Ormolu.Utils.IO (findClosestFileSatisfying, readFileUtf8, withIORefCache)
import System.Directory
import System.IO.Unsafe (unsafePerformIO)
import Text.Megaparsec (errorBundlePretty)

-- | Attempt to locate and parse an @.ormolu@ file. If it does not exist,
-- default fixity map and module reexports are returned. This function
-- maintains a cache of fixity overrides and module re-exports where cabal
-- file paths act as keys.
getDotOrmoluForSourceFile ::
  (MonadIO m) =>
  -- | 'CabalInfo' already obtained for this source file
  FilePath ->
  m (FixityOverrides, ModuleReexports)
getDotOrmoluForSourceFile :: forall (m :: * -> *).
MonadIO m =>
FilePath -> m (FixityOverrides, ModuleReexports)
getDotOrmoluForSourceFile FilePath
sourceFile =
  IO (Maybe FilePath) -> m (Maybe FilePath)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO (Maybe FilePath)
forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe FilePath)
findDotOrmoluFile FilePath
sourceFile) m (Maybe FilePath)
-> (Maybe FilePath -> m (FixityOverrides, ModuleReexports))
-> m (FixityOverrides, ModuleReexports)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just FilePath
dotOrmoluFile -> IO (FixityOverrides, ModuleReexports)
-> m (FixityOverrides, ModuleReexports)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FixityOverrides, ModuleReexports)
 -> m (FixityOverrides, ModuleReexports))
-> IO (FixityOverrides, ModuleReexports)
-> m (FixityOverrides, ModuleReexports)
forall a b. (a -> b) -> a -> b
$ IORef (Map FilePath (FixityOverrides, ModuleReexports))
-> FilePath
-> IO (FixityOverrides, ModuleReexports)
-> IO (FixityOverrides, ModuleReexports)
forall k v. Ord k => IORef (Map k v) -> k -> IO v -> IO v
withIORefCache IORef (Map FilePath (FixityOverrides, ModuleReexports))
cacheRef FilePath
dotOrmoluFile (IO (FixityOverrides, ModuleReexports)
 -> IO (FixityOverrides, ModuleReexports))
-> IO (FixityOverrides, ModuleReexports)
-> IO (FixityOverrides, ModuleReexports)
forall a b. (a -> b) -> a -> b
$ do
      FilePath
dotOrmoluRelative <- FilePath -> IO FilePath
makeRelativeToCurrentDirectory FilePath
dotOrmoluFile
      Text
contents <- FilePath -> IO Text
forall (m :: * -> *). MonadIO m => FilePath -> m Text
readFileUtf8 FilePath
dotOrmoluFile
      case FilePath
-> Text
-> Either
     (ParseErrorBundle Text Void) (FixityOverrides, ModuleReexports)
parseDotOrmolu FilePath
dotOrmoluRelative Text
contents of
        Left ParseErrorBundle Text Void
errorBundle ->
          OrmoluException -> IO (FixityOverrides, ModuleReexports)
forall e a. Exception e => e -> IO a
throwIO (ParseErrorBundle Text Void -> OrmoluException
OrmoluFixityOverridesParseError ParseErrorBundle Text Void
errorBundle)
        Right (FixityOverrides, ModuleReexports)
x -> (FixityOverrides, ModuleReexports)
-> IO (FixityOverrides, ModuleReexports)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityOverrides, ModuleReexports)
x
    Maybe FilePath
Nothing -> (FixityOverrides, ModuleReexports)
-> m (FixityOverrides, ModuleReexports)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityOverrides
defaultFixityOverrides, ModuleReexports
defaultModuleReexports)

-- | Find the path to an appropriate @.ormolu@ file for a Haskell source
-- file, if available.
findDotOrmoluFile ::
  (MonadIO m) =>
  -- | Path to a Haskell source file
  FilePath ->
  -- | Absolute path to the closest @.ormolu@ file, if available
  m (Maybe FilePath)
findDotOrmoluFile :: forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe FilePath)
findDotOrmoluFile = (FilePath -> Bool) -> FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
MonadIO m =>
(FilePath -> Bool) -> FilePath -> m (Maybe FilePath)
findClosestFileSatisfying ((FilePath -> Bool) -> FilePath -> m (Maybe FilePath))
-> (FilePath -> Bool) -> FilePath -> m (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ \FilePath
x ->
  FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".ormolu"

-- | Cache ref that maps names of @.ormolu@ files to their contents.
cacheRef :: IORef (Map FilePath (FixityOverrides, ModuleReexports))
cacheRef :: IORef (Map FilePath (FixityOverrides, ModuleReexports))
cacheRef = IO (IORef (Map FilePath (FixityOverrides, ModuleReexports)))
-> IORef (Map FilePath (FixityOverrides, ModuleReexports))
forall a. IO a -> a
unsafePerformIO (Map FilePath (FixityOverrides, ModuleReexports)
-> IO (IORef (Map FilePath (FixityOverrides, ModuleReexports)))
forall a. a -> IO (IORef a)
newIORef Map FilePath (FixityOverrides, ModuleReexports)
forall k a. Map k a
Map.empty)
{-# NOINLINE cacheRef #-}

-- | A wrapper around 'parseFixityDeclaration' for parsing individual fixity
-- definitions.
parseFixityDeclarationStr ::
  -- | Input to parse
  String ->
  -- | Parse result
  Either String [(OpName, FixityInfo)]
parseFixityDeclarationStr :: FilePath -> Either FilePath [(OpName, FixityInfo)]
parseFixityDeclarationStr =
  (ParseErrorBundle Text Void -> FilePath)
-> Either (ParseErrorBundle Text Void) [(OpName, FixityInfo)]
-> Either FilePath [(OpName, FixityInfo)]
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle Text Void -> FilePath
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> FilePath
errorBundlePretty (Either (ParseErrorBundle Text Void) [(OpName, FixityInfo)]
 -> Either FilePath [(OpName, FixityInfo)])
-> (FilePath
    -> Either (ParseErrorBundle Text Void) [(OpName, FixityInfo)])
-> FilePath
-> Either FilePath [(OpName, FixityInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either (ParseErrorBundle Text Void) [(OpName, FixityInfo)]
parseFixityDeclaration (Text
 -> Either (ParseErrorBundle Text Void) [(OpName, FixityInfo)])
-> (FilePath -> Text)
-> FilePath
-> Either (ParseErrorBundle Text Void) [(OpName, FixityInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack

-- | A wrapper around 'parseModuleReexportDeclaration' for parsing
-- a individual module reexport.
parseModuleReexportDeclarationStr ::
  -- | Input to parse
  String ->
  -- | Parse result
  Either String (ModuleName, NonEmpty (Maybe PackageName, ModuleName))
parseModuleReexportDeclarationStr :: FilePath
-> Either
     FilePath (ModuleName, NonEmpty (Maybe PackageName, ModuleName))
parseModuleReexportDeclarationStr =
  (ParseErrorBundle Text Void -> FilePath)
-> Either
     (ParseErrorBundle Text Void)
     (ModuleName, NonEmpty (Maybe PackageName, ModuleName))
-> Either
     FilePath (ModuleName, NonEmpty (Maybe PackageName, ModuleName))
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle Text Void -> FilePath
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> FilePath
errorBundlePretty (Either
   (ParseErrorBundle Text Void)
   (ModuleName, NonEmpty (Maybe PackageName, ModuleName))
 -> Either
      FilePath (ModuleName, NonEmpty (Maybe PackageName, ModuleName)))
-> (FilePath
    -> Either
         (ParseErrorBundle Text Void)
         (ModuleName, NonEmpty (Maybe PackageName, ModuleName)))
-> FilePath
-> Either
     FilePath (ModuleName, NonEmpty (Maybe PackageName, ModuleName))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> Either
     (ParseErrorBundle Text Void)
     (ModuleName, NonEmpty (Maybe PackageName, ModuleName))
parseModuleReexportDeclaration (Text
 -> Either
      (ParseErrorBundle Text Void)
      (ModuleName, NonEmpty (Maybe PackageName, ModuleName)))
-> (FilePath -> Text)
-> FilePath
-> Either
     (ParseErrorBundle Text Void)
     (ModuleName, NonEmpty (Maybe PackageName, ModuleName))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack