{-# 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.List.NonEmpty (NonEmpty)
import Data.Text qualified as T
import Data.Text.IO.Utf8 qualified as T.Utf8
import Distribution.ModuleName (ModuleName)
import Distribution.Types.PackageName (PackageName)
import Ormolu.Exception
import Ormolu.Fixity
import Ormolu.Fixity.Parser
import Ormolu.Utils.IO (Cache, findClosestFileSatisfying, newCache, withCache)
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
$ Cache FilePath (FixityOverrides, ModuleReexports)
-> FilePath
-> IO (FixityOverrides, ModuleReexports)
-> IO (FixityOverrides, ModuleReexports)
forall k v. Ord k => Cache k v -> k -> IO v -> IO v
withCache Cache 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
T.Utf8.readFile 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 :: Cache FilePath (FixityOverrides, ModuleReexports)
cacheRef :: Cache FilePath (FixityOverrides, ModuleReexports)
cacheRef = IO (Cache FilePath (FixityOverrides, ModuleReexports))
-> Cache FilePath (FixityOverrides, ModuleReexports)
forall a. IO a -> a
unsafePerformIO IO (Cache FilePath (FixityOverrides, ModuleReexports))
forall k v. Ord k => IO (Cache k v)
newCache
{-# 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