diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,33 @@ +## Ormolu 0.7.0.0 + +* Inference of operator fixity information is now more precise and takes + into account the import section of the module being formatted. [Issue + 892](https://github.com/tweag/ormolu/issues/892) and [issue + 929](https://github.com/tweag/ormolu/issues/929). + +* Ormolu can now be made aware of module re-exports through either special + declarations in `.ormolu` files (see the readme for a description of the + syntax), or on the command line with the `--reexport`/`-r` option. [Issue + 1017](https://github.com/tweag/ormolu/issues/1017). + +* Ormolu now looks for `.ormolu` files independently of `.cabal` files. This + means that it is now possible to have one `.ormolu` file for multiple + Cabal packages. [Issue 1019](https://github.com/tweag/ormolu/issues/1019). + +* Consistently format `do` blocks/`case`s/`MultiWayIf`s with 4 spaces if and + only if they occur as the applicand. [Issue + 1002](https://github.com/tweag/ormolu/issues/1002) and [issue + 730](https://github.com/tweag/ormolu/issues/730). + +* Support the (deprecated) `DatatypeContexts` extension to avoid surprises. + [Issue 1012](https://github.com/tweag/ormolu/issues/1012). + +* Don't let comments escape from empty export lists. [Issue + 906](https://github.com/tweag/ormolu/issues/906). + +* Format `\cases` with multiple patterns across multiple lines correctly. [Issue + 1025](https://github.com/tweag/ormolu/issues/1025). + ## Ormolu 0.6.0.1 * Fix false positives in AST diffing related to `UnicodeSyntax`. [PR diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -162,15 +162,15 @@ ### Language extensions, dependencies, and fixities Ormolu automatically locates the Cabal file that corresponds to a given -source code file. When input comes from stdin, one can pass -`--stdin-input-file` which will give Ormolu the location of the Haskell -source file that should be used as the starting point for searching for a -suitable Cabal file. Cabal files are used to extract both default extensions +source code file. Cabal files are used to extract both default extensions and dependencies. Default extensions directly affect behavior of the GHC parser, while dependencies are used to figure out fixities of operators that -appear in the source code. Fixities can also be overridden if `.ormolu` file -is found next to the corresponding Cabal file, i.e. they should be siblings -in the same directory. +appear in the source code. Fixities can also be overridden via an `.ormolu` +file which should be located at a higher level in the file system hierarchy +than the source file that is being formatted. When the input comes from +stdin, one can pass `--stdin-input-file` which will give Ormolu the location +that should be used as the starting point for searching for `.cabal` and +`.ormolu` files. Here is an example of `.ormolu` file: @@ -187,15 +187,35 @@ It uses exactly the same syntax as usual Haskell fixity declarations to make it easier for Haskellers to edit and maintain. -Besides, all of the above-mentioned parameters can be controlled from the +As of Ormolu 0.7.0.0, `.ormolu` files can also contain instructions about +module re-exports that Ormolu should be aware of. This might be desirable +because at the moment Ormolu cannot know about all possible module +re-exports in the ecosystem and only few of them are actually important when +it comes to fixity deduction. In 99% of cases the user won't have to do +anything, especially since most common re-exports are already programmed +into Ormolu. (You are welcome to open PRs to make Ormolu aware of more +re-exports by default.) However, when the fixity of an operator is not +inferred correctly, making Ormolu aware of a re-export may come in handy. +Here is an example: + +```haskell +module Control.Lens exports Control.Lens.At +module Control.Lens exports Control.Lens.Lens +``` + +Module re-export declarations can be mixed freely with fixity overrides, as +long as each declaration is on its own line. + +Finally, all of the above-mentioned parameters can be controlled from the command line: * Language extensions can be specified with the `-o` or `--ghc-opt` flag. * Dependencies can be specified with the `-p` or `--package` flag. * Fixities can be specified with the `-f` or `--fixity` flag. +* Re-exports can be specified with the `-r` or `--reexport` flag. -Searching for both `.cabal` and `.ormolu` files can be disabled by passing -`--no-cabal`. +Searching for `.cabal` and `.ormolu` files can be disabled by passing +`--no-cabal` and `--no-dot-ormolu` respectively. ### Magic comments diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -11,20 +11,22 @@ import Control.Monad import Data.Bool (bool) import Data.List (intercalate, sort) +import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.Set qualified as Set import Data.Text.IO qualified as TIO import Data.Version (showVersion) +import Distribution.ModuleName (ModuleName) import Language.Haskell.TH.Env (envQ) import Options.Applicative import Ormolu import Ormolu.Diff.Text (diffText, printTextDiff) -import Ormolu.Fixity (FixityInfo, OpName) +import Ormolu.Fixity import Ormolu.Parser (manualExts) import Ormolu.Terminal import Ormolu.Utils (showOutputable) -import Ormolu.Utils.Fixity (parseFixityDeclarationStr) +import Ormolu.Utils.Fixity import Ormolu.Utils.IO import Paths_ormolu (version) import System.Directory @@ -38,7 +40,7 @@ Opts {..} <- execParser optsParserInfo let formatOne' = formatOne - optCabal + optConfigFileOpts optMode optSourceType optConfig @@ -65,7 +67,7 @@ -- | Format a single input. formatOne :: -- | How to use .cabal files - CabalOpts -> + ConfigFileOpts -> -- | Mode of operation Mode -> -- | The 'SourceType' requested by the user @@ -75,7 +77,7 @@ -- | File to format or stdin as 'Nothing' Maybe FilePath -> IO ExitCode -formatOne CabalOpts {..} mode reqSourceType rawConfig mpath = +formatOne ConfigFileOpts {..} mode reqSourceType rawConfig mpath = withPrettyOrmoluExceptions (cfgColorMode rawConfig) $ do let getCabalInfoForSourceFile' sourceFile = do cabalSearchResult <- getCabalInfoForSourceFile sourceFile @@ -97,21 +99,24 @@ <> sourceFile return (Just cabalInfo) CabalFound cabalInfo -> return (Just cabalInfo) + getDotOrmoluForSourceFile' sourceFile = do + if optDoNotUseDotOrmolu + then return Nothing + else Just <$> getDotOrmoluForSourceFile sourceFile case FP.normalise <$> mpath of -- input source = STDIN Nothing -> do - resultConfig <- - ( if optDoNotUseCabal - then pure Nothing - else case optStdinInputFile of - Just stdinInputFile -> - getCabalInfoForSourceFile' stdinInputFile - Nothing -> throwIO OrmoluMissingStdinInputFile - ) - >>= patchConfig Nothing + mcabalInfo <- case (optStdinInputFile, optDoNotUseCabal) of + (_, True) -> return Nothing + (Nothing, False) -> throwIO OrmoluMissingStdinInputFile + (Just inputFile, False) -> getCabalInfoForSourceFile' inputFile + mdotOrmolu <- case optStdinInputFile of + Nothing -> return Nothing + Just inputFile -> getDotOrmoluForSourceFile' inputFile + config <- patchConfig Nothing mcabalInfo mdotOrmolu case mode of Stdout -> do - ormoluStdin resultConfig >>= TIO.putStr + ormoluStdin config >>= TIO.putStr return ExitSuccess InPlace -> do hPutStrLn @@ -124,25 +129,29 @@ originalInput <- getContentsUtf8 let stdinRepr = "" formattedInput <- - ormolu resultConfig stdinRepr originalInput + ormolu config stdinRepr originalInput handleDiff originalInput formattedInput stdinRepr -- input source = a file Just inputFile -> do - resultConfig <- - ( if optDoNotUseCabal - then pure Nothing - else getCabalInfoForSourceFile' inputFile - ) - >>= patchConfig (Just (detectSourceType inputFile)) + mcabalInfo <- + if optDoNotUseCabal + then return Nothing + else getCabalInfoForSourceFile' inputFile + mdotOrmolu <- getDotOrmoluForSourceFile' inputFile + config <- + patchConfig + (Just (detectSourceType inputFile)) + mcabalInfo + mdotOrmolu case mode of Stdout -> do - ormoluFile resultConfig inputFile >>= TIO.putStr + ormoluFile config inputFile >>= TIO.putStr return ExitSuccess InPlace -> do -- ormoluFile is not used because we need originalInput originalInput <- readFileUtf8 inputFile formattedInput <- - ormolu resultConfig inputFile originalInput + ormolu config inputFile originalInput when (formattedInput /= originalInput) $ writeFileUtf8 inputFile formattedInput return ExitSuccess @@ -150,16 +159,23 @@ -- ormoluFile is not used because we need originalInput originalInput <- readFileUtf8 inputFile formattedInput <- - ormolu resultConfig inputFile originalInput + ormolu config inputFile originalInput handleDiff originalInput formattedInput inputFile where - patchConfig mdetectedSourceType mcabalInfo = do + patchConfig mdetectedSourceType mcabalInfo mdotOrmolu = do let sourceType = fromMaybe ModuleSource (reqSourceType <|> mdetectedSourceType) - mfixityOverrides <- traverse getFixityOverridesForSourceFile mcabalInfo - return (refineConfig sourceType mcabalInfo mfixityOverrides rawConfig) + let mfixityOverrides = fst <$> mdotOrmolu + mmoduleReexports = snd <$> mdotOrmolu + return $ + refineConfig + sourceType + mcabalInfo + mfixityOverrides + mmoduleReexports + rawConfig handleDiff originalInput formattedInput fileRepr = case diffText originalInput formattedInput fileRepr of Nothing -> return ExitSuccess @@ -179,8 +195,8 @@ optMode :: !Mode, -- | Ormolu 'Config' optConfig :: !(Config RegionIndices), - -- | Options related to info extracted from .cabal files - optCabal :: CabalOpts, + -- | Options related to info extracted from files + optConfigFileOpts :: ConfigFileOpts, -- | Source type option, where 'Nothing' means autodetection optSourceType :: !(Maybe SourceType), -- | Haskell source files to format or stdin (when the list is empty) @@ -198,10 +214,12 @@ Check deriving (Eq, Show) --- | Configuration related to .cabal files. -data CabalOpts = CabalOpts +-- | Options related to configuration stored in the file system. +data ConfigFileOpts = ConfigFileOpts { -- | DO NOT extract default-extensions and dependencies from .cabal files optDoNotUseCabal :: Bool, + -- | DO NOT look for @.ormolu@ files + optDoNotUseDotOrmolu :: Bool, -- | Optional path to a file which will be used to find a .cabal file -- when using input from stdin optStdinInputFile :: Maybe FilePath @@ -252,22 +270,24 @@ ] ) <*> configParser - <*> cabalOptsParser + <*> configFileOptsParser <*> sourceTypeParser <*> (many . strArgument . mconcat) [ metavar "FILE", help "Haskell source files to format or stdin (the default)" ] -cabalOptsParser :: Parser CabalOpts -cabalOptsParser = - CabalOpts +configFileOptsParser :: Parser ConfigFileOpts +configFileOptsParser = + ConfigFileOpts <$> (switch . mconcat) [ long "no-cabal", - help $ - "Do not extract default-extensions and dependencies from .cabal files" - ++ ", do not look for .ormolu files" + help "Do not extract default-extensions and dependencies from .cabal files" ] + <*> (switch . mconcat) + [ long "no-dot-ormolu", + help "Do not look for .ormolu files" + ] <*> (optional . strOption . mconcat) [ long "stdin-input-file", help "Path which will be used to find the .cabal file when using input from stdin" @@ -282,7 +302,7 @@ metavar "OPT", help "GHC options to enable (e.g. language extensions)" ] - <*> ( fmap (Map.fromListWith (<>) . mconcat) + <*> ( fmap (FixityOverrides . Map.fromList . mconcat) . many . option parseFixityDeclaration . mconcat @@ -292,6 +312,16 @@ metavar "FIXITY", help "Fixity declaration to use (an override)" ] + <*> ( fmap (ModuleReexports . Map.fromListWith (<>) . mconcat . pure) + . many + . option parseModuleReexportDeclaration + . mconcat + ) + [ long "reexport", + short 'r', + metavar "REEXPORT", + help "Module re-export that Ormolu should know about" + ] <*> (fmap Set.fromList . many . strOption . mconcat) [ long "package", short 'p', @@ -360,6 +390,10 @@ -- | Parse a fixity declaration. parseFixityDeclaration :: ReadM [(OpName, FixityInfo)] parseFixityDeclaration = eitherReader parseFixityDeclarationStr + +-- | Parse a module reexport declaration. +parseModuleReexportDeclaration :: ReadM (ModuleName, NonEmpty ModuleName) +parseModuleReexportDeclaration = eitherReader parseModuleReexportDeclarationStr -- | Parse 'ColorMode'. parseColorMode :: ReadM ColorMode diff --git a/data/examples/declaration/data/datatype-contexts-out.hs b/data/examples/declaration/data/datatype-contexts-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/datatype-contexts-out.hs @@ -0,0 +1,11 @@ +data (IsString s) => T s = T + +data + (IsString s) => + T s = T + +data + ( IsString s, + IsString s + ) => + T s = T diff --git a/data/examples/declaration/data/datatype-contexts.hs b/data/examples/declaration/data/datatype-contexts.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/datatype-contexts.hs @@ -0,0 +1,8 @@ +data IsString s => T s = T + +data IsString s => + T s = T + +data + ( IsString s + , IsString s ) => T s = T diff --git a/data/examples/declaration/type-synonyms/multi-line-out.hs b/data/examples/declaration/type-synonyms/multi-line-out.hs --- a/data/examples/declaration/type-synonyms/multi-line-out.hs +++ b/data/examples/declaration/type-synonyms/multi-line-out.hs @@ -1,3 +1,5 @@ +import Servant.API + type Foo a b c = Bar c a b diff --git a/data/examples/declaration/type-synonyms/multi-line.hs b/data/examples/declaration/type-synonyms/multi-line.hs --- a/data/examples/declaration/type-synonyms/multi-line.hs +++ b/data/examples/declaration/type-synonyms/multi-line.hs @@ -1,3 +1,5 @@ +import Servant.API + type Foo a b c = Bar c a b diff --git a/data/examples/declaration/value/function/application-1-out.hs b/data/examples/declaration/value/function/application-1-out.hs --- a/data/examples/declaration/value/function/application-1-out.hs +++ b/data/examples/declaration/value/function/application-1-out.hs @@ -1,19 +1,19 @@ main = do - x - y - z + x + y + z main = case foo of - x -> a - foo - a - b + x -> a + foo + a + b main = do - if x then y else z - foo - a - b + if x then y else z + foo + a + b diff --git a/data/examples/declaration/value/function/application-2-out.hs b/data/examples/declaration/value/function/application-2-out.hs --- a/data/examples/declaration/value/function/application-2-out.hs +++ b/data/examples/declaration/value/function/application-2-out.hs @@ -16,8 +16,8 @@ foo = do do - (+ 1) - 2 + (+ 1) + 2 foo = do case () of () -> (+ 1) @@ -25,8 +25,8 @@ foo = do case () of - () -> (+ 1) - 2 + () -> (+ 1) + 2 foo = do \case 2 -> 3 @@ -34,5 +34,5 @@ foo = do \case - 2 -> 3 - 2 + 2 -> 3 + 2 diff --git a/data/examples/declaration/value/function/arrow/proc-applications2-out.hs b/data/examples/declaration/value/function/arrow/proc-applications2-out.hs --- a/data/examples/declaration/value/function/arrow/proc-applications2-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-applications2-out.hs @@ -8,4 +8,5 @@ LT -> \a -> returnA -< x + a EQ -> \b -> returnA -< y + z + b GT -> \c -> returnA -< z + x - ) 1 + ) + 1 diff --git a/data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs b/data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs --- a/data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs @@ -15,3 +15,15 @@ f -< a + +foo = + proc x -> + do + returnA -< x + 1 + +foo a = + proc x -> + case Left x of + Left x -> returnA -< x + a diff --git a/data/examples/declaration/value/function/arrow/proc-do-simple1.hs b/data/examples/declaration/value/function/arrow/proc-do-simple1.hs --- a/data/examples/declaration/value/function/arrow/proc-do-simple1.hs +++ b/data/examples/declaration/value/function/arrow/proc-do-simple1.hs @@ -18,3 +18,13 @@ -< a +foo = + proc x -> do + returnA -< x + 1 + +foo a = + proc x -> + case Left x of + Left x -> returnA -< x + a diff --git a/data/examples/declaration/value/function/arrow/proc-form-do-indent-out.hs b/data/examples/declaration/value/function/arrow/proc-form-do-indent-out.hs --- a/data/examples/declaration/value/function/arrow/proc-form-do-indent-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-form-do-indent-out.hs @@ -10,4 +10,5 @@ (| bar (bindA -< y) - |) z + |) + z diff --git a/data/examples/declaration/value/function/infix/esqueleto-0-out.hs b/data/examples/declaration/value/function/infix/esqueleto-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/esqueleto-0-out.hs @@ -0,0 +1,12 @@ +import Database.Esqueleto.Experimental + +foo = select $ do + t <- + from $ + table @Bar + `innerJoin` table @Baz + `on` do + \(br :& bz) -> whatever + where_ $ + t ^. BarInt ==. val 3 + &&. t ^. BarName `in_` valList ["hello", "world"] diff --git a/data/examples/declaration/value/function/infix/esqueleto-0.hs b/data/examples/declaration/value/function/infix/esqueleto-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/esqueleto-0.hs @@ -0,0 +1,10 @@ +import Database.Esqueleto.Experimental + +foo = select $ do + t <- from $ table @Bar + `innerJoin` table @Baz + `on` do + \(br :& bz) -> whatever + where_ $ + t ^. BarInt ==. val 3 + &&. t ^. BarName `in_` valList ["hello", "world"] diff --git a/data/examples/declaration/value/function/infix/esqueleto-1-out.hs b/data/examples/declaration/value/function/infix/esqueleto-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/esqueleto-1-out.hs @@ -0,0 +1,9 @@ +import qualified Database.Esqueleto.Experimental as E + +foo = + E.from $ + E.table + `E.innerJoin` E.table + `E.on` ( \(a :& b) -> + a E.^. AField E.==. b E.^. BField + ) diff --git a/data/examples/declaration/value/function/infix/esqueleto-1.hs b/data/examples/declaration/value/function/infix/esqueleto-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/esqueleto-1.hs @@ -0,0 +1,9 @@ +import qualified Database.Esqueleto.Experimental as E + +foo = + E.from $ + E.table + `E.innerJoin` E.table + `E.on` ( \(a :& b) -> + a E.^. AField E.==. b E.^. BField + ) diff --git a/data/examples/declaration/value/function/infix/lenses-out.hs b/data/examples/declaration/value/function/infix/lenses-out.hs --- a/data/examples/declaration/value/function/infix/lenses-out.hs +++ b/data/examples/declaration/value/function/infix/lenses-out.hs @@ -1,3 +1,5 @@ +import Control.Lens + lenses = Just $ M.fromList $ diff --git a/data/examples/declaration/value/function/infix/lenses.hs b/data/examples/declaration/value/function/infix/lenses.hs --- a/data/examples/declaration/value/function/infix/lenses.hs +++ b/data/examples/declaration/value/function/infix/lenses.hs @@ -1,3 +1,5 @@ +import Control.Lens + lenses = Just $ M.fromList $ "type" .= ("user.connection" :: Text) # "connection" .= uc diff --git a/data/examples/declaration/value/function/infix/qualified-prelude-out.hs b/data/examples/declaration/value/function/infix/qualified-prelude-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/qualified-prelude-out.hs @@ -0,0 +1,12 @@ +module StreamSpec where + +import Prelude (($)) +import qualified Prelude + +spec :: Spec +spec = do + describe "Comparing list function to" $ do + qit "yieldMany" $ + \(mono :: Seq Int) -> + yieldMany mono + `checkProducer` otoList mono diff --git a/data/examples/declaration/value/function/infix/qualified-prelude.hs b/data/examples/declaration/value/function/infix/qualified-prelude.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/qualified-prelude.hs @@ -0,0 +1,12 @@ +module StreamSpec where + +import qualified Prelude +import Prelude (($)) + +spec :: Spec +spec = do + describe "Comparing list function to" $ do + qit "yieldMany" $ + \(mono :: Seq Int) -> + yieldMany mono `checkProducer` + otoList mono diff --git a/data/examples/declaration/value/function/lambda-case-out.hs b/data/examples/declaration/value/function/lambda-case-out.hs --- a/data/examples/declaration/value/function/lambda-case-out.hs +++ b/data/examples/declaration/value/function/lambda-case-out.hs @@ -15,3 +15,9 @@ foo = \cases (Just a) (Just a) -> a + a _ _ -> 0 + +foo :: Bool -> Bool -> Bool +foo = \cases + True + True -> True + _ _ -> False diff --git a/data/examples/declaration/value/function/lambda-case.hs b/data/examples/declaration/value/function/lambda-case.hs --- a/data/examples/declaration/value/function/lambda-case.hs +++ b/data/examples/declaration/value/function/lambda-case.hs @@ -15,3 +15,9 @@ foo = \cases (Just a) (Just a) -> a + a _ _ -> 0 + +foo :: Bool -> Bool -> Bool +foo = \cases + True + True -> True + _ _ -> False diff --git a/data/examples/declaration/value/function/multi-way-if-out.hs b/data/examples/declaration/value/function/multi-way-if-out.hs --- a/data/examples/declaration/value/function/multi-way-if-out.hs +++ b/data/examples/declaration/value/function/multi-way-if-out.hs @@ -4,10 +4,10 @@ bar x y = if - | x > y -> x - | x < y -> - y - | otherwise -> x + | x > y -> x + | x < y -> + y + | otherwise -> x baz = if diff --git a/data/examples/declaration/value/function/operators-0-out.hs b/data/examples/declaration/value/function/operators-0-out.hs --- a/data/examples/declaration/value/function/operators-0-out.hs +++ b/data/examples/declaration/value/function/operators-0-out.hs @@ -1,3 +1,5 @@ +import Control.Lens.Operators + a = b & c .~ d diff --git a/data/examples/declaration/value/function/operators-0.hs b/data/examples/declaration/value/function/operators-0.hs --- a/data/examples/declaration/value/function/operators-0.hs +++ b/data/examples/declaration/value/function/operators-0.hs @@ -1,3 +1,5 @@ +import Control.Lens.Operators + a = b & c .~ d & e %~ f diff --git a/data/examples/declaration/value/function/operators-3-out.hs b/data/examples/declaration/value/function/operators-3-out.hs --- a/data/examples/declaration/value/function/operators-3-out.hs +++ b/data/examples/declaration/value/function/operators-3-out.hs @@ -1,3 +1,5 @@ +import Control.Arrow + foo = op <> n <+> colon diff --git a/data/examples/declaration/value/function/operators-3.hs b/data/examples/declaration/value/function/operators-3.hs --- a/data/examples/declaration/value/function/operators-3.hs +++ b/data/examples/declaration/value/function/operators-3.hs @@ -1,3 +1,5 @@ +import Control.Arrow + foo = op <> n <+> colon <+> prettySe <+> text "=" <+> prettySe <> text sc diff --git a/data/examples/declaration/value/function/operators-4-out.hs b/data/examples/declaration/value/function/operators-4-out.hs --- a/data/examples/declaration/value/function/operators-4-out.hs +++ b/data/examples/declaration/value/function/operators-4-out.hs @@ -1,3 +1,5 @@ +import Control.Arrow + foo = line <> bindingOf <+> text "=" diff --git a/data/examples/declaration/value/function/operators-4.hs b/data/examples/declaration/value/function/operators-4.hs --- a/data/examples/declaration/value/function/operators-4.hs +++ b/data/examples/declaration/value/function/operators-4.hs @@ -1,3 +1,5 @@ +import Control.Arrow + foo = line <> bindingOf <+> text "=" <+> tPretty <+> colon <+> align <> prettyPs diff --git a/data/examples/declaration/value/function/operators-6-out.hs b/data/examples/declaration/value/function/operators-6-out.hs --- a/data/examples/declaration/value/function/operators-6-out.hs +++ b/data/examples/declaration/value/function/operators-6-out.hs @@ -1,3 +1,5 @@ +import Servant.API + type PermuteRef = "a" :> ( "b" :> "c" :> End diff --git a/data/examples/declaration/value/function/operators-6.hs b/data/examples/declaration/value/function/operators-6.hs --- a/data/examples/declaration/value/function/operators-6.hs +++ b/data/examples/declaration/value/function/operators-6.hs @@ -1,3 +1,5 @@ +import Servant.API + type PermuteRef = "a" :> ( "b" :> "c" :> End :<|> "c" :> "b" :> End diff --git a/data/examples/module-header/multiline-empty-comment-out.hs b/data/examples/module-header/multiline-empty-comment-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/multiline-empty-comment-out.hs @@ -0,0 +1,4 @@ +module Foo + ( -- test + ) +where diff --git a/data/examples/module-header/multiline-empty-comment.hs b/data/examples/module-header/multiline-empty-comment.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/multiline-empty-comment.hs @@ -0,0 +1,2 @@ +module Foo ( -- test + ) where diff --git a/extract-hackage-info/hackage-info.bin b/extract-hackage-info/hackage-info.bin Binary files a/extract-hackage-info/hackage-info.bin and b/extract-hackage-info/hackage-info.bin differ diff --git a/ormolu.cabal b/ormolu.cabal --- a/ormolu.cabal +++ b/ormolu.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: ormolu -version: 0.6.0.1 +version: 0.7.0.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov @@ -78,6 +78,7 @@ Ormolu.Printer.Meat.Type Ormolu.Printer.Operators Ormolu.Fixity + Ormolu.Fixity.Imports Ormolu.Fixity.Internal Ormolu.Fixity.Parser Ormolu.Fixity.Printer @@ -99,7 +100,7 @@ Cabal-syntax >=3.10 && <3.11, Diff >=0.4 && <1.0, MemoTrie >=0.6 && <0.7, - ansi-terminal >=0.10 && <1.0, + ansi-terminal >=0.10 && <1.1, array >=0.5 && <0.6, base >=4.14 && <5.0, binary >=0.8 && <0.9, @@ -133,15 +134,16 @@ autogen-modules: Paths_ormolu default-language: GHC2021 build-depends: + Cabal-syntax >=3.10 && <3.11, base >=4.12 && <5.0, containers >=0.5 && <0.7, directory ^>=1.3, filepath >=1.2 && <1.5, ghc-lib-parser >=9.6 && <9.7, - th-env >=0.1.1 && <0.2, optparse-applicative >=0.14 && <0.18, ormolu, - text >=2.0 && <3.0 + text >=2.0 && <3.0, + th-env >=0.1.1 && <0.2 if flag(dev) ghc-options: @@ -161,7 +163,7 @@ Ormolu.Diff.TextSpec Ormolu.Fixity.ParserSpec Ormolu.Fixity.PrinterSpec - Ormolu.HackageInfoSpec + Ormolu.FixitySpec Ormolu.OpTreeSpec Ormolu.Parser.OptionsSpec Ormolu.Parser.ParseFailureSpec @@ -179,6 +181,7 @@ ghc-lib-parser >=9.6 && <9.7, hspec >=2.0 && <3.0, hspec-megaparsec >=2.2, + megaparsec >=9.0, ormolu, path >=0.6 && <0.10, path-io >=1.4.2 && <2.0, diff --git a/src/Ormolu.hs b/src/Ormolu.hs --- a/src/Ormolu.hs +++ b/src/Ormolu.hs @@ -24,9 +24,12 @@ CabalUtils.CabalInfo (..), CabalUtils.getCabalInfoForSourceFile, - -- * Fixity overrides - FixityMap, - getFixityOverridesForSourceFile, + -- * Fixity overrides and module re-exports + FixityOverrides, + defaultFixityOverrides, + ModuleReexports, + defaultModuleReexports, + getDotOrmoluForSourceFile, -- * Working with exceptions OrmoluException (..), @@ -38,6 +41,7 @@ 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 @@ -55,7 +59,7 @@ import Ormolu.Printer import Ormolu.Utils (showOutputable) import Ormolu.Utils.Cabal qualified as CabalUtils -import Ormolu.Utils.Fixity (getFixityOverridesForSourceFile) +import Ormolu.Utils.Fixity (getDotOrmoluForSourceFile) import Ormolu.Utils.IO import System.FilePath @@ -85,11 +89,7 @@ let totalLines = length (T.lines originalInput) cfg = regionIndicesToDeltas totalLines <$> cfgWithIndices fixityMap = - -- It is important to keep all arguments (but last) of - -- 'buildFixityMap' constant (such as 'defaultStrategyThreshold'), - -- otherwise it is going to break memoization. - buildFixityMap - defaultStrategyThreshold + packageFixityMap (cfgDependencies cfg) -- memoized on the set of dependencies (warnings, result0) <- parseModule' cfg fixityMap OrmoluParsingFailed path originalInput @@ -180,32 +180,47 @@ -- | Cabal info for the file, if available Maybe CabalUtils.CabalInfo -> -- | Fixity overrides, if available - Maybe FixityMap -> + Maybe FixityOverrides -> + -- | Module re-exports, if available + Maybe ModuleReexports -> -- | 'Config' to refine Config region -> -- | Refined 'Config' Config region -refineConfig sourceType mcabalInfo mfixityOverrides rawConfig = +refineConfig sourceType mcabalInfo mfixityOverrides mreexports rawConfig = rawConfig { cfgDynOptions = cfgDynOptions rawConfig ++ dynOptsFromCabal, cfgFixityOverrides = - Map.unionWith (<>) (cfgFixityOverrides rawConfig) fixityOverrides, + 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 = - case mfixityOverrides of - Nothing -> Map.empty - Just x -> x + fixityOverrides = fromMaybe defaultFixityOverrides mfixityOverrides + reexports = fromMaybe defaultModuleReexports mreexports (dynOptsFromCabal, depsFromCabal) = case mcabalInfo of - Nothing -> ([], Set.empty) + Nothing -> + -- If no cabal info is provided, assume base as a dependency by + -- default. + ([], defaultDependencies) Just CabalUtils.CabalInfo {..} -> -- 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. + -- package itself if we know it, as if it were its own dependency. (ciDynOpts, Set.insert ciPackageName ciDependencies) ---------------------------------------------------------------------------- @@ -217,7 +232,7 @@ -- | Ormolu configuration Config RegionDeltas -> -- | Fixity Map for operators - LazyFixityMap -> + PackageFixityMap -> -- | How to obtain 'OrmoluException' to throw when parsing fails (SrcSpan -> String -> OrmoluException) -> -- | File name to use in errors diff --git a/src/Ormolu/Config.hs b/src/Ormolu/Config.hs --- a/src/Ormolu/Config.hs +++ b/src/Ormolu/Config.hs @@ -14,13 +14,12 @@ ) where -import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Set qualified as Set import Distribution.Types.PackageName (PackageName) import GHC.Generics (Generic) import GHC.Types.SrcLoc qualified as GHC -import Ormolu.Fixity (FixityMap) +import Ormolu.Fixity import Ormolu.Terminal (ColorMode (..)) -- | Type of sources that can be formatted by Ormolu. @@ -36,7 +35,9 @@ { -- | Dynamic options to pass to GHC parser cfgDynOptions :: ![DynOption], -- | Fixity overrides - cfgFixityOverrides :: FixityMap, + cfgFixityOverrides :: !FixityOverrides, + -- | Module reexports to take into account when doing fixity resolution + cfgModuleReexports :: !ModuleReexports, -- | Known dependencies, if any cfgDependencies :: !(Set PackageName), -- | Do formatting faster but without automatic detection of defects @@ -78,7 +79,8 @@ defaultConfig = Config { cfgDynOptions = [], - cfgFixityOverrides = Map.empty, + cfgFixityOverrides = defaultFixityOverrides, + cfgModuleReexports = defaultModuleReexports, cfgDependencies = Set.empty, cfgUnsafe = False, cfgDebug = False, diff --git a/src/Ormolu/Fixity.hs b/src/Ormolu/Fixity.hs --- a/src/Ormolu/Fixity.hs +++ b/src/Ormolu/Fixity.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -- | Definitions for fixity analysis. @@ -12,34 +12,39 @@ occOpName, FixityDirection (..), FixityInfo (..), - FixityMap, - LazyFixityMap, - lookupFixity, - HackageInfo (..), - defaultStrategyThreshold, defaultFixityInfo, - buildFixityMap, - buildFixityMap', - bootPackages, - packageToOps, - packageToPopularity, + FixityApproximation (..), + defaultFixityApproximation, + FixityOverrides (..), + defaultFixityOverrides, + ModuleReexports (..), + defaultModuleReexports, + PackageFixityMap (..), + ModuleFixityMap (..), + inferFixity, + HackageInfo (..), + hackageInfo, + defaultDependencies, + packageFixityMap, + packageFixityMap', + moduleFixityMap, + applyFixityOverrides, ) where import Data.Binary qualified as Binary import Data.Binary.Get qualified as Binary import Data.ByteString.Lazy qualified as BL -import Data.Foldable (foldl') -import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE -import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe) import Data.MemoTrie (memo) -import Data.Semigroup (sconcat) import Data.Set (Set) import Data.Set qualified as Set +import Distribution.ModuleName (ModuleName) import Distribution.Types.PackageName (PackageName, mkPackageName, unPackageName) +import Language.Haskell.Syntax.ImpExp (ImportListInterpretation (..)) +import Ormolu.Fixity.Imports (FixityImport (..)) import Ormolu.Fixity.Internal #if BUNDLE_FIXITIES import Data.FileEmbed (embedFile) @@ -48,210 +53,131 @@ import System.IO.Unsafe (unsafePerformIO) #endif -packageToOps :: Map PackageName FixityMap -packageToPopularity :: Map PackageName Int +-- | The built-in 'HackageInfo' used by Ormolu. +hackageInfo :: HackageInfo #if BUNDLE_FIXITIES -HackageInfo packageToOps packageToPopularity = +hackageInfo = Binary.runGet Binary.get $ BL.fromStrict $(embedFile "extract-hackage-info/hackage-info.bin") #else -- The GHC WASM backend does not yet support Template Haskell, so we instead -- pass in the encoded fixity DB via pre-initialization with Wizer. -HackageInfo packageToOps packageToPopularity = +hackageInfo = unsafePerformIO $ Binary.runGet Binary.get . BL.fromStrict <$> B.readFile "hackage-info.bin" -{-# NOINLINE packageToOps #-} -{-# NOINLINE packageToPopularity #-} +{-# NOINLINE hackageInfo #-} #endif --- | List of packages shipped with GHC, for which the download count from --- Hackage does not reflect their high popularity. --- See https://github.com/tweag/ormolu/pull/830#issuecomment-986609572. --- "base" is not is this list, because it is already whitelisted --- by buildFixityMap'. -bootPackages :: Set PackageName -bootPackages = - Set.fromList - [ "array", - "binary", - "bytestring", - "containers", - "deepseq", - "directory", - "exceptions", - "filepath", - "ghc-binary", - "mtl", - "parsec", - "process", - "stm", - "template-haskell", - "terminfo", - "text", - "time", - "transformers", - "unix", - "Win32" - ] - --- | The default value for the popularity ratio threshold, after which a --- very popular definition from packageToOps will completely rule out --- conflicting definitions instead of being merged with them. -defaultStrategyThreshold :: Float -defaultStrategyThreshold = 0.9 +-- | Default set of packages to assume as dependencies e.g. when no Cabal +-- file is found or taken into consideration. +defaultDependencies :: Set PackageName +defaultDependencies = Set.singleton (mkPackageName "base") --- | Build a fixity map using the given popularity threshold and a list of --- cabal dependencies. Dependencies from the list have higher priority than --- other packages. -buildFixityMap :: - -- | Popularity ratio threshold, after which a very popular package will - -- completely rule out conflicting definitions coming from other packages - -- instead of being merged with them - Float -> - -- | Explicitly known dependencies +-- | Compute the fixity map that is specific to the package we are formatting. +packageFixityMap :: + -- | Set of packages to select Set PackageName -> - -- | Resulting map - LazyFixityMap -buildFixityMap = buildFixityMap' packageToOps packageToPopularity bootPackages + -- | Package fixity map + PackageFixityMap +packageFixityMap = packageFixityMap' hackageInfo --- | Build a fixity map using the given popularity threshold and a list of --- cabal dependencies. Dependencies from the list have higher priority than --- other packages. This specific version of the function allows the user to --- specify the package databases used to build the final fixity map. -buildFixityMap' :: - -- | Map from package to fixity map for operators defined in this package - Map PackageName FixityMap -> - -- | Map from package to popularity - Map PackageName Int -> - -- | Higher priority packages - Set PackageName -> - -- | Popularity ratio threshold, after which a very popular package will - -- completely rule out conflicting definitions coming from other packages - -- instead of being merged with them - Float -> - -- | Explicitly known dependencies +-- | The same as 'packageFixityMap', except this specific version of the +-- function allows the user to specify 'HackageInfo' used to build the final +-- fixity map. +packageFixityMap' :: + -- | Hackage info + HackageInfo -> + -- | Set of packages to select Set PackageName -> - -- | Resulting map - LazyFixityMap -buildFixityMap' - operatorMap - popularityMap - higherPriorityPackages - strategyThreshold = memoSet $ \dependencies -> - let baseFixityMap = - Map.insert ":" colonFixityInfo $ - fromMaybe Map.empty $ - Map.lookup "base" operatorMap - cabalFixityMap = - mergeAll (buildPackageFixityMap <$> Set.toList dependencies) - higherPriorityFixityMap = - mergeAll (buildPackageFixityMap <$> Set.toList higherPriorityPackages) - remainingFixityMap = - mergeFixityMaps - popularityMap - strategyThreshold - (buildPackageFixityMap <$> Set.toList remainingPackages) - remainingPackages = - Map.keysSet operatorMap - `Set.difference` Set.union dependencies higherPriorityPackages - buildPackageFixityMap packageName = - ( packageName, - fromMaybe Map.empty $ - Map.lookup packageName operatorMap - ) - -- we need a threshold > 1.0 so that no dependency can reach the - -- threshold - mergeAll = mergeFixityMaps Map.empty 10.0 - in LazyFixityMap - [ baseFixityMap, - cabalFixityMap, - higherPriorityFixityMap, - remainingFixityMap - ] - -memoSet :: (Set PackageName -> v) -> Set PackageName -> v -memoSet f = memo (f . Set.fromAscList . fmap mkPackageName) . fmap unPackageName . Set.toAscList + -- | Package fixity map + PackageFixityMap +packageFixityMap' (HackageInfo m) = memoSet $ \dependencies -> + -- The core idea here is to transform: + -- + -- Map PackageName (Map ModuleName (Map OpName FixityInfo)) + -- + -- into + -- + -- Map OpName [(PackageName, ModuleName, FixityInfo)] + -- + -- which we accomplish by turning 'Map's into tuples with 'Map.toList' and + -- then flattening them with 'flatten :: [(a, [b])] -> [(a, b)]'. + -- + -- The target type results from the need to be able to quickly index by + -- the operator name when we do fixity resolution later. + PackageFixityMap + . Map.mapMaybe NE.nonEmpty + . Map.fromListWith (<>) + . fmap rearrange + . flatten + . Map.toList + . Map.map (flatten . Map.toList . Map.map Map.toList) + $ Map.restrictKeys m dependencies + where + rearrange (packageName, (moduleName, (opName, fixityInfo))) = + (opName, [(packageName, moduleName, fixityInfo)]) + flatten xs = do + (k, vs) <- xs + v <- vs + return (k, v) --- | Merge a list of individual fixity maps, coming from different packages. --- Package popularities and the given threshold are used to choose between --- the "keep best only" (>= threshold) and "merge all" (< threshold) --- strategies when conflicting definitions are encountered for an operator. -mergeFixityMaps :: - -- | Map from package name to 30-days download count - Map PackageName Int -> - -- | Popularity ratio threshold - Float -> - -- | List of (package name, package fixity map) to merge - [(PackageName, FixityMap)] -> - -- | Resulting fixity map - FixityMap -mergeFixityMaps popularityMap threshold packageMaps = - Map.map - (useThreshold threshold . NE.fromList . Map.toList) - scoredMap +-- | Compute the fixity map that is specific to the module we are formatting. +moduleFixityMap :: + -- | Fixity information selected from dependencies of this package + PackageFixityMap -> + -- | A simplified representation of the import list in this module + [FixityImport] -> + -- | Fixity map specific to this module + ModuleFixityMap +moduleFixityMap (PackageFixityMap m) imports = + ModuleFixityMap $ + Map.insert + ":" + (Given colonFixityInfo) + (Map.map FromModuleImports (Map.mapMaybeWithKey select m)) where - scoredMap = Map.map getScores opFixityMap - -- when we encounter a duplicate key (op1) in the unionsWith operation, - -- we have - -- op1 -map-> {definitions1 -map-> originPackages} - -- op1 -map-> {definitions2 -map-> originPackages} - -- so we merge the keys (which have the type: - -- Map FixityInfo (NonEmpty PackageName)) - -- using 'Map.unionWith (<>)', to "concatenate" the list of - -- definitions for this operator, and to also "concatenate" origin - -- packages if a same definition is found in both maps - opFixityMap = - Map.unionsWith - (Map.unionWith (<>)) - (opFixityMapFrom <$> packageMaps) - useThreshold :: - -- Threshold - Float -> - -- List of conflicting (definition, score) for a given operator - NonEmpty (FixityInfo, Int) -> - -- Resulting fixity, using the specified threshold to choose between - -- strategy "keep best only" and "merge all" - FixityInfo - useThreshold t fixScores = - if toFloat maxScore / toFloat sumScores >= t - then sconcat . fmap fst $ maxs -- merge potential ex-aequo winners - else sconcat . fmap fst $ fixScores - where - toFloat x = fromIntegral x :: Float - maxs = maxWith snd fixScores - maxScore = snd $ NE.head maxs - sumScores = foldl' (+) 0 (snd <$> fixScores) - getScores :: - -- Map for a given operator associating each of its conflicting - -- definitions with the packages that define it - Map FixityInfo (NonEmpty PackageName) -> - -- Map for a given operator associating each of its conflicting - -- definitions with their score (= sum of the popularity of the - -- packages that define it) - Map FixityInfo Int - getScores = - Map.map - (sum . fmap (fromMaybe 0 . flip Map.lookup popularityMap)) - opFixityMapFrom :: - -- (packageName, package fixity map) - (PackageName, FixityMap) -> - -- Map associating each operator of the package with a - -- {map for a given operator associating each of its definitions with - -- the list of packages that define it} - -- (this list can only be == [packageName] in the context of this - -- function) - Map OpName (Map FixityInfo (NonEmpty PackageName)) - opFixityMapFrom (packageName, opsMap) = - Map.map - (flip Map.singleton (packageName :| [])) - opsMap - maxWith :: (Ord b) => (a -> b) -> NonEmpty a -> NonEmpty a - maxWith f xs = snd $ foldl' comp (f h, h :| []) t - where - h :| t = xs - comp (fMax, maxs) x = - let fX = f x - in if - | fMax < fX -> (fX, x :| []) - | fMax == fX -> (fMax, NE.cons x maxs) - | otherwise -> (fMax, maxs) + select :: + OpName -> + NonEmpty (PackageName, ModuleName, FixityInfo) -> + Maybe (NonEmpty (FixityQualification, FixityInfo)) + select opName = + let f (packageName, moduleName, fixityInfo) = + (,fixityInfo) + <$> resolveThroughImports packageName moduleName opName + in NE.nonEmpty . concatMap f + resolveThroughImports :: + PackageName -> + ModuleName -> + OpName -> + [FixityQualification] + resolveThroughImports packageName moduleName opName = + let doesImportMatch FixityImport {..} = + let packageMatches = + case fimportPackage of + Nothing -> True + Just p -> p == packageName + moduleMatches = + fimportModule == moduleName + opMatches = case fimportList of + Nothing -> True + Just (Exactly, xs) -> opName `elem` xs + Just (EverythingBut, xs) -> opName `notElem` xs + in packageMatches && moduleMatches && opMatches + in fimportQualified <$> filter doesImportMatch imports + +-- | Apply fixity overrides. +applyFixityOverrides :: + -- | User overrides + FixityOverrides -> + -- | Module fixity map + ModuleFixityMap -> + -- | Module fixity map with overrides applied + ModuleFixityMap +applyFixityOverrides (FixityOverrides o) (ModuleFixityMap m) = + ModuleFixityMap (Map.union (Map.map Given o) m) + +memoSet :: (Set PackageName -> v) -> Set PackageName -> v +memoSet f = + memo (f . Set.fromAscList . fmap mkPackageName) + . fmap unPackageName + . Set.toAscList diff --git a/src/Ormolu/Fixity/Imports.hs b/src/Ormolu/Fixity/Imports.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Fixity/Imports.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Simplified representation of the import list for the purposes of fixity +-- inference. +module Ormolu.Fixity.Imports + ( FixityImport (..), + extractFixityImports, + applyModuleReexports, + ) +where + +import Data.Bifunctor (second) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Map +import Distribution.ModuleName (ModuleName) +import Distribution.Types.PackageName +import GHC.Data.FastString qualified as GHC +import GHC.Hs hiding (ModuleName) +import GHC.Types.Name.Occurrence +import GHC.Types.PkgQual (RawPkgQual (..)) +import GHC.Types.SourceText (StringLiteral (..)) +import GHC.Types.SrcLoc +import Ormolu.Fixity.Internal +import Ormolu.Utils (ghcModuleNameToCabal) + +-- | Simplified info about an import. +data FixityImport = FixityImport + { fimportPackage :: !(Maybe PackageName), + fimportModule :: !ModuleName, + fimportQualified :: !FixityQualification, + fimportList :: !(Maybe (ImportListInterpretation, [OpName])) + } + +-- | Extract 'FixityImport's from the AST. +extractFixityImports :: + [LImportDecl GhcPs] -> + [FixityImport] +extractFixityImports = fmap (extractFixityImport . unLoc) + +-- | Extract an individual 'FixityImport'. +extractFixityImport :: ImportDecl GhcPs -> FixityImport +extractFixityImport ImportDecl {..} = + FixityImport + { fimportPackage = case ideclPkgQual of + NoRawPkgQual -> Nothing + RawPkgQual strLiteral -> + Just . mkPackageName . GHC.unpackFS . sl_fs $ strLiteral, + fimportModule = ideclName', + fimportQualified = case (ideclQualified, ideclAs') of + (QualifiedPre, Nothing) -> + OnlyQualified ideclName' + (QualifiedPost, Nothing) -> + OnlyQualified ideclName' + (QualifiedPre, Just m) -> OnlyQualified m + (QualifiedPost, Just m) -> OnlyQualified m + (NotQualified, Nothing) -> + UnqualifiedAndQualified ideclName' + (NotQualified, Just m) -> + UnqualifiedAndQualified m, + fimportList = + fmap + (second (concatMap (fmap occOpName . ieToOccNames . unLoc) . unLoc)) + ideclImportList + } + where + ideclName' = ghcModuleNameToCabal (unLoc ideclName) + ideclAs' = ghcModuleNameToCabal . unLoc <$> ideclAs + +ieToOccNames :: IE GhcPs -> [OccName] +ieToOccNames = \case + IEVar _ (L _ x) -> [occName x] + IEThingAbs _ (L _ x) -> [occName x] + IEThingAll _ (L _ x) -> [occName x] -- TODO not quite correct, but how to do better? + IEThingWith _ (L _ x) _ xs -> occName x : fmap (occName . unLoc) xs + _ -> [] + +-- | Apply given module re-exports. +applyModuleReexports :: ModuleReexports -> [FixityImport] -> [FixityImport] +applyModuleReexports (ModuleReexports reexports) imports = imports >>= expand + where + expand i = do + case Map.lookup (fimportModule i) reexports of + Nothing -> pure i + Just exports -> + let exportToImport mmodule = + i + { fimportPackage = Nothing, + fimportModule = mmodule + } + in NE.toList exports >>= expand . exportToImport diff --git a/src/Ormolu/Fixity/Internal.hs b/src/Ormolu/Fixity/Internal.hs --- a/src/Ormolu/Fixity/Internal.hs +++ b/src/Ormolu/Fixity/Internal.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} module Ormolu.Fixity.Internal @@ -10,12 +12,20 @@ occOpName, FixityDirection (..), FixityInfo (..), - defaultFixityInfo, colonFixityInfo, + defaultFixityInfo, + FixityApproximation (..), + defaultFixityApproximation, HackageInfo (..), - FixityMap, - LazyFixityMap (..), - lookupFixity, + FixityOverrides (..), + defaultFixityOverrides, + ModuleReexports (..), + defaultModuleReexports, + PackageFixityMap (..), + ModuleFixityMap (..), + FixityProvenance (..), + FixityQualification (..), + inferFixity, ) where @@ -23,18 +33,51 @@ import Data.Binary (Binary) import Data.ByteString.Short (ShortByteString) import Data.ByteString.Short qualified as SBS -import Data.Foldable (asum) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) import Data.String (IsString (..)) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T -import Distribution.Types.PackageName (PackageName) +import Distribution.ModuleName (ModuleName) +import Distribution.Types.PackageName import GHC.Data.FastString (fs_sbs) import GHC.Generics (Generic) import GHC.Types.Name (OccName (occNameFS)) +import GHC.Types.Name.Reader (RdrName (..), rdrNameOcc) +import Ormolu.Utils (ghcModuleNameToCabal) +-- | An operator name. +newtype OpName = MkOpName + { -- | Invariant: UTF-8 encoded + getOpName :: ShortByteString + } + deriving newtype (Eq, Ord, Binary, NFData) + +-- | Convert an 'OpName' to 'Text'. +unOpName :: OpName -> Text +unOpName = T.decodeUtf8 . SBS.fromShort . getOpName + +pattern OpName :: Text -> OpName +pattern OpName opName <- (unOpName -> opName) + where + OpName = MkOpName . SBS.toShort . T.encodeUtf8 + +{-# COMPLETE OpName #-} + +-- | Convert an 'OccName to an 'OpName'. +occOpName :: OccName -> OpName +occOpName = MkOpName . fs_sbs . occNameFS + +instance Show OpName where + show = T.unpack . unOpName + +instance IsString OpName where + fromString = OpName . T.pack + -- | Fixity direction. data FixityDirection = InfixL @@ -43,102 +86,183 @@ deriving stock (Eq, Ord, Show, Generic) deriving anyclass (Binary, NFData) --- | Fixity information about an infix operator that takes the uncertainty --- that can arise from conflicting definitions into account. +-- | Fixity information about an infix operator. This type provides precise +-- information as opposed to 'FixityApproximation'. data FixityInfo = FixityInfo + { -- | Fixity direction + fiDirection :: FixityDirection, + -- | Precedence + fiPrecedence :: Int + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (Binary, NFData) + +-- | Fixity info of the built-in colon data constructor. +colonFixityInfo :: FixityInfo +colonFixityInfo = FixityInfo InfixR 5 + +-- | Fixity that is implicitly assumed if no fixity declaration is present. +defaultFixityInfo :: FixityInfo +defaultFixityInfo = FixityInfo InfixL 9 + +-- | Approximation of fixity information that takes the uncertainty that can +-- arise from conflicting definitions into account. +data FixityApproximation = FixityApproximation { -- | Fixity direction if it is known - fiDirection :: Maybe FixityDirection, + faDirection :: Maybe FixityDirection, -- | Minimum precedence level found in the (maybe conflicting) -- definitions for the operator (inclusive) - fiMinPrecedence :: Int, + faMinPrecedence :: Int, -- | Maximum precedence level found in the (maybe conflicting) -- definitions for the operator (inclusive) - fiMaxPrecedence :: Int + faMaxPrecedence :: Int } deriving stock (Eq, Ord, Show, Generic) deriving anyclass (Binary, NFData) --- | The lowest level of information we can have about an operator. -defaultFixityInfo :: FixityInfo -defaultFixityInfo = - FixityInfo - { fiDirection = Just InfixL, - fiMinPrecedence = 9, - fiMaxPrecedence = 9 - } - --- | Fixity info of the built-in colon data constructor. -colonFixityInfo :: FixityInfo -colonFixityInfo = - FixityInfo - { fiDirection = Just InfixR, - fiMinPrecedence = 5, - fiMaxPrecedence = 5 - } - -- | Gives the ability to merge two (maybe conflicting) definitions for an -- operator, keeping the higher level of compatible information from both. -instance Semigroup FixityInfo where - FixityInfo {fiDirection = dir1, fiMinPrecedence = min1, fiMaxPrecedence = max1} - <> FixityInfo {fiDirection = dir2, fiMinPrecedence = min2, fiMaxPrecedence = max2} = - FixityInfo - { fiDirection = dir', - fiMinPrecedence = min min1 min2, - fiMaxPrecedence = max max1 max2 +instance Semigroup FixityApproximation where + FixityApproximation {faDirection = dir1, faMinPrecedence = min1, faMaxPrecedence = max1} + <> FixityApproximation {faDirection = dir2, faMinPrecedence = min2, faMaxPrecedence = max2} = + FixityApproximation + { faDirection = dir', + faMinPrecedence = min min1 min2, + faMaxPrecedence = max max1 max2 } where dir' = case (dir1, dir2) of (Just a, Just b) | a == b -> Just a _ -> Nothing --- | An operator name. -newtype OpName = MkOpName - { -- | Invariant: UTF-8 encoded - getOpName :: ShortByteString - } - deriving newtype (Eq, Ord, Binary, NFData) +-- | The lowest level of information we can have about an operator. +defaultFixityApproximation :: FixityApproximation +defaultFixityApproximation = fixityInfoToApproximation defaultFixityInfo --- | Convert an 'OpName' to 'Text'. -unOpName :: OpName -> Text -unOpName = T.decodeUtf8 . SBS.fromShort . getOpName +-- | Convert from 'FixityInfo' to 'FixityApproximation'. +fixityInfoToApproximation :: FixityInfo -> FixityApproximation +fixityInfoToApproximation FixityInfo {..} = + FixityApproximation + { faDirection = Just fiDirection, + faMinPrecedence = fiPrecedence, + faMaxPrecedence = fiPrecedence + } -pattern OpName :: Text -> OpName -pattern OpName opName <- (unOpName -> opName) - where - OpName = MkOpName . SBS.toShort . T.encodeUtf8 +-- | The map of operators declared by each package grouped by module name. +newtype HackageInfo + = HackageInfo (Map PackageName (Map ModuleName (Map OpName FixityInfo))) + deriving stock (Generic) + deriving anyclass (Binary, NFData) -{-# COMPLETE OpName #-} +-- | Map from the operator name to its 'FixityInfo'. +newtype FixityOverrides = FixityOverrides + { unFixityOverrides :: Map OpName FixityInfo + } + deriving stock (Eq, Show) --- | Convert an 'OccName to an 'OpName'. -occOpName :: OccName -> OpName -occOpName = MkOpName . fs_sbs . occNameFS +-- | Fixity overrides to use by default. +defaultFixityOverrides :: FixityOverrides +defaultFixityOverrides = FixityOverrides Map.empty -instance Show OpName where - show = T.unpack . unOpName +-- | Module re-exports +newtype ModuleReexports = ModuleReexports + { unModuleReexports :: Map ModuleName (NonEmpty ModuleName) + } + deriving stock (Eq, Show) -instance IsString OpName where - fromString = OpName . T.pack +-- | Module re-exports to apply by default. +defaultModuleReexports :: ModuleReexports +defaultModuleReexports = + ModuleReexports . Map.fromList $ + [ ( "Control.Lens", + NE.fromList + [ "Control.Lens.At", + "Control.Lens.Cons", + "Control.Lens.Each", + "Control.Lens.Empty", + "Control.Lens.Equality", + "Control.Lens.Fold", + "Control.Lens.Getter", + "Control.Lens.Indexed", + "Control.Lens.Iso", + "Control.Lens.Lens", + "Control.Lens.Level", + "Control.Lens.Plated", + "Control.Lens.Prism", + "Control.Lens.Reified", + "Control.Lens.Review", + "Control.Lens.Setter", + "Control.Lens.TH", + "Control.Lens.Traversal", + "Control.Lens.Tuple", + "Control.Lens.Type", + "Control.Lens.Wrapped", + "Control.Lens.Zoom" + ] + ), + ( "Servant", + NE.fromList + [ "Servant.API" + ] + ), + ( "Optics", + NE.fromList + [ "Optics.Fold", + "Optics.Operators", + "Optics.IxAffineFold", + "Optics.IxFold", + "Optics.IxTraversal", + "Optics.Traversal" + ] + ) + ] --- | Map from the operator name to its 'FixityInfo'. -type FixityMap = Map OpName FixityInfo +-- | Fixity information that is specific to a package being formatted. It +-- requires module-specific imports in order to be usable. +newtype PackageFixityMap + = PackageFixityMap (Map OpName (NonEmpty (PackageName, ModuleName, FixityInfo))) + deriving stock (Eq, Show) --- | A variant of 'FixityMap', represented as a lazy union of several --- 'FixityMap's. -newtype LazyFixityMap = LazyFixityMap [FixityMap] - deriving (Show) +-- | Fixity map that takes into account imports in a particular module. +newtype ModuleFixityMap + = ModuleFixityMap (Map OpName FixityProvenance) + deriving stock (Eq, Show) --- | Lookup a 'FixityInfo' of an operator. This might have drastically --- different performance depending on whether this is an "unusual" operator. -lookupFixity :: OpName -> LazyFixityMap -> Maybe FixityInfo -lookupFixity op (LazyFixityMap maps) = asum (Map.lookup op <$> maps) +-- | Provenance of fixity info. +data FixityProvenance + = -- | 'FixityInfo' of a built-in operator or provided by a user override. + Given FixityInfo + | -- | 'FixityInfo' to be inferred from module imports. + FromModuleImports (NonEmpty (FixityQualification, FixityInfo)) + deriving stock (Eq, Show) --- | The map of operators declared by each package and the popularity of --- each package, if available. -data HackageInfo - = HackageInfo - -- | Map from package name to a map from operator name to its fixity - (Map PackageName FixityMap) - -- | Map from package name to its 30-days download count from Hackage - (Map PackageName Int) - deriving stock (Generic) - deriving anyclass (Binary) +-- | Fixity qualification that determines how 'FixityInfo' matches a +-- particular use of an operator, given whether it is qualified or +-- unqualified and the module name used. +data FixityQualification + = UnqualifiedAndQualified ModuleName + | OnlyQualified ModuleName + deriving stock (Eq, Show) + +-- | Get a 'FixityApproximation' of an operator. +inferFixity :: RdrName -> ModuleFixityMap -> FixityApproximation +inferFixity rdrName (ModuleFixityMap m) = + case Map.lookup opName m of + Nothing -> defaultFixityApproximation + Just (Given fixityInfo) -> + fixityInfoToApproximation fixityInfo + Just (FromModuleImports xs) -> + let isMatching (provenance, _fixityInfo) = + case provenance of + UnqualifiedAndQualified mn -> + maybe True (== mn) moduleName + OnlyQualified mn -> + maybe False (== mn) moduleName + in fromMaybe defaultFixityApproximation + . foldMap (Just . fixityInfoToApproximation . snd) + $ NE.filter isMatching xs + where + opName = occOpName (rdrNameOcc rdrName) + moduleName = case rdrName of + Qual x _ -> Just (ghcModuleNameToCabal x) + _ -> Nothing diff --git a/src/Ormolu/Fixity/Parser.hs b/src/Ormolu/Fixity/Parser.hs --- a/src/Ormolu/Fixity/Parser.hs +++ b/src/Ormolu/Fixity/Parser.hs @@ -3,20 +3,41 @@ -- | Parser for fixity maps. module Ormolu.Fixity.Parser - ( parseFixityMap, + ( parseDotOrmolu, parseFixityDeclaration, + parseModuleReexportDeclaration, -- * Raw parsers pFixity, pOperator, + pModuleName, + pPackageName, + + -- * Internal + isIdentifierFirstChar, + isIdentifierConstituent, + isOperatorConstituent, + isPackageNameConstituent, + isModuleSegmentFirstChar, + isModuleSegmentConstituent, ) where +import Control.Monad (void, when) +import Data.Bifunctor (bimap) +import Data.Char (isAlphaNum, isUpper) import Data.Char qualified as Char +import Data.Either (partitionEithers) +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T import Data.Void (Void) +import Distribution.ModuleName (ModuleName) +import Distribution.ModuleName qualified as ModuleName +import Distribution.Types.PackageName (PackageName, mkPackageName) import Ormolu.Fixity import Text.Megaparsec import Text.Megaparsec.Char @@ -24,39 +45,62 @@ type Parser = Parsec Void Text --- | Parse textual representation of a 'FixityMap'. -parseFixityMap :: +-- | Parse textual representation of 'FixityOverrides'. +parseDotOrmolu :: -- | Location of the file we are parsing (only for parse errors) FilePath -> -- | File contents to parse Text -> -- | Parse result - Either (ParseErrorBundle Text Void) FixityMap -parseFixityMap = runParser pFixityMap + Either (ParseErrorBundle Text Void) (FixityOverrides, ModuleReexports) +parseDotOrmolu = runParser pDotOrmolu -- | Parse a single self-contained fixity declaration. parseFixityDeclaration :: - -- | Expression to parse + -- | Text to parse Text -> -- | Parse result Either (ParseErrorBundle Text Void) [(OpName, FixityInfo)] parseFixityDeclaration = runParser (pFixity <* eof) "" -pFixityMap :: Parser FixityMap -pFixityMap = - Map.fromListWith (<>) . mconcat - <$> many (pFixity <* eol <* hidden space) +-- | Parse a single self-contained module re-export declaration. +parseModuleReexportDeclaration :: + -- | Text to parse + Text -> + -- | Parse result + Either + (ParseErrorBundle Text Void) + (ModuleName, NonEmpty ModuleName) +parseModuleReexportDeclaration = runParser (pModuleReexport <* eof) "" + +pDotOrmolu :: Parser (FixityOverrides, ModuleReexports) +pDotOrmolu = + bimap + (FixityOverrides . Map.fromList . mconcat) + (ModuleReexports . Map.map NE.sort . Map.fromListWith (<>)) + . partitionEithers + <$> many configLine <* eof + where + configLine = do + x <- eitherP pFixity pModuleReexport + void eol + hidden space + return x -- | Parse a single fixity declaration, such as -- -- > infixr 4 +++, >>> pFixity :: Parser [(OpName, FixityInfo)] pFixity = do - fiDirection <- Just <$> pFixityDirection + fiDirection <- pFixityDirection hidden hspace1 - fiMinPrecedence <- L.decimal - let fiMaxPrecedence = fiMinPrecedence + offsetAtPrecedence <- getOffset + fiPrecedence <- L.decimal + when (fiPrecedence > 9) $ + region + (setErrorOffset offsetAtPrecedence) + (fail "precedence should not be greater than 9") hidden hspace1 ops <- sepBy1 pOperator (char ',' >> hidden hspace) hidden hspace @@ -80,8 +124,60 @@ haskellIdentifier = T.cons <$> letterChar - <*> takeWhileP Nothing (\x -> Char.isAlphaNum x || x == '_' || x == '\'') + <*> takeWhileP Nothing isIdentifierConstituent normalOperator = - takeWhile1P (Just "operator character") $ \x -> - (Char.isSymbol x || Char.isPunctuation x) - && (x /= ',' && x /= '`' && x /= '(' && x /= ')') + takeWhile1P (Just "operator character") isOperatorConstituent + +pModuleReexport :: Parser (ModuleName, NonEmpty ModuleName) +pModuleReexport = do + void (string "module") + hidden hspace1 + exportingModule <- pModuleName + hidden hspace1 + void (string "exports") + hidden hspace1 + exportedModule <- pModuleName + hidden hspace + return (exportingModule, NE.singleton exportedModule) + +pModuleName :: Parser ModuleName +pModuleName = + ModuleName.fromString . intercalate "." + <$> sepBy1 pModuleSegment (char '.') + "module name" + where + pModuleSegment = do + x <- satisfy isModuleSegmentFirstChar "capital letter" + xs <- + many + ( satisfy isModuleSegmentConstituent + "module segment continuation" + ) + return (x : xs) + +pPackageName :: Parser PackageName +pPackageName = + mkPackageName <$> some (satisfy isPackageNameConstituent) "package name" + +-- Internal predicates (exposed for testing) + +isIdentifierFirstChar :: Char -> Bool +isIdentifierFirstChar = Char.isLetter + +isIdentifierConstituent :: Char -> Bool +isIdentifierConstituent x = Char.isAlphaNum x || x == '_' || x == '\'' + +isOperatorConstituent :: Char -> Bool +isOperatorConstituent x = + (Char.isSymbol x || Char.isPunctuation x) + && (x /= ',' && x /= '`' && x /= '(' && x /= ')') + +isPackageNameConstituent :: Char -> Bool +isPackageNameConstituent x = x == '-' || isAlphaNum x + +isModuleSegmentFirstChar :: Char -> Bool +isModuleSegmentFirstChar x = isAlphaNum x && isUpper x + +isModuleSegmentConstituent :: Char -> Bool +isModuleSegmentConstituent x = + x == '_' || x == '\'' || isAlphaNum x diff --git a/src/Ormolu/Fixity/Printer.hs b/src/Ormolu/Fixity/Printer.hs --- a/src/Ormolu/Fixity/Printer.hs +++ b/src/Ormolu/Fixity/Printer.hs @@ -1,55 +1,71 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} --- | Printer for fixity maps. +-- | Printer for fixity overrides. module Ormolu.Fixity.Printer - ( printFixityMap, + ( printDotOrmolu, ) where import Data.Char qualified as Char +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict qualified as Map +import Data.Semigroup (sconcat) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Builder (Builder) import Data.Text.Lazy.Builder qualified as B import Data.Text.Lazy.Builder.Int qualified as B +import Distribution.ModuleName (ModuleName) +import Distribution.ModuleName qualified as ModuleName import Ormolu.Fixity --- | Print out a textual representation of a 'FixityMap'. -printFixityMap :: FixityMap -> Text -printFixityMap = - TL.toStrict - . B.toLazyText - . mconcat - . fmap renderOne - . concatMap decompose - . Map.toList +-- | Print out a textual representation of an @.ormolu@ file. +printDotOrmolu :: + FixityOverrides -> + ModuleReexports -> + Text +printDotOrmolu + (FixityOverrides fixityOverrides) + (ModuleReexports moduleReexports) = + TL.toStrict . B.toLazyText $ + (mconcat . fmap renderSingleFixityOverride . Map.toList) fixityOverrides + <> (mconcat . fmap renderSingleModuleReexport . Map.toList) moduleReexports + +renderSingleFixityOverride :: (OpName, FixityInfo) -> Builder +renderSingleFixityOverride (OpName operator, FixityInfo {..}) = + mconcat + [ case fiDirection of + InfixL -> "infixl" + InfixR -> "infixr" + InfixN -> "infix", + " ", + B.decimal fiPrecedence, + " ", + if isTickedOperator operator + then "`" <> B.fromText operator <> "`" + else B.fromText operator, + "\n" + ] where - decompose :: (OpName, FixityInfo) -> [(FixityDirection, Int, OpName)] - decompose (operator, FixityInfo {..}) = - let forDirection dir = - (dir, fiMinPrecedence, operator) - : [ (dir, fiMaxPrecedence, operator) - | fiMinPrecedence /= fiMaxPrecedence - ] - in case fiDirection of - Nothing -> concatMap forDirection [InfixL, InfixR] - Just dir -> forDirection dir - renderOne :: (FixityDirection, Int, OpName) -> Builder - renderOne (fixityDirection, n, OpName operator) = + isTickedOperator = maybe True (Char.isLetter . fst) . T.uncons + +renderSingleModuleReexport :: + (ModuleName, NonEmpty ModuleName) -> + Builder +renderSingleModuleReexport (exportingModule, exports) = + sconcat (renderSingle <$> exports) + where + renderSingle exportedModule = mconcat - [ case fixityDirection of - InfixL -> "infixl" - InfixR -> "infixr" - InfixN -> "infix", - " ", - B.decimal n, - " ", - if isTickedOperator operator - then "`" <> B.fromText operator <> "`" - else B.fromText operator, + [ "module ", + renderModuleName exportingModule, + " exports ", + renderModuleName exportedModule, "\n" ] - isTickedOperator = maybe True (Char.isLetter . fst) . T.uncons + +renderModuleName :: ModuleName -> Builder +renderModuleName = B.fromString . intercalate "." . ModuleName.components diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -18,31 +18,38 @@ import Control.Monad.IO.Class import Data.Char (isSpace) import Data.Functor -import Data.Generics +import Data.Generics hiding (orElse) import Data.List qualified as L import Data.List.NonEmpty qualified as NE import Data.Text (Text) +import GHC.Builtin.Names (mAIN_NAME) import GHC.Data.Bag (bagToList) import GHC.Data.EnumSet qualified as EnumSet import GHC.Data.FastString qualified as GHC +import GHC.Data.Maybe (orElse) +import GHC.Data.StringBuffer (StringBuffer) import GHC.Driver.CmdLine qualified as GHC import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Errors.Types qualified as GHC import GHC.Driver.Session as GHC import GHC.DynFlags (baseDynFlags) import GHC.Hs hiding (UnicodeSyntax) import GHC.LanguageExtensions.Type (Extension (..)) import GHC.Parser qualified as GHC +import GHC.Parser.Annotation qualified as GHC import GHC.Parser.Header qualified as GHC import GHC.Parser.Lexer qualified as GHC -import GHC.Types.Error (NoDiagnosticOpts (..), getMessages) -import GHC.Types.SourceError qualified as GHC (handleSourceError) +import GHC.Types.Error qualified as GHC +import GHC.Types.SourceError qualified as GHC import GHC.Types.SrcLoc import GHC.Utils.Error +import GHC.Utils.Exception (ExceptionMonad) import GHC.Utils.Outputable (defaultSDocContext) import GHC.Utils.Panic qualified as GHC import Ormolu.Config import Ormolu.Exception -import Ormolu.Fixity (LazyFixityMap) +import Ormolu.Fixity hiding (packageFixityMap) +import Ormolu.Fixity.Imports (applyModuleReexports, extractFixityImports) import Ormolu.Imports (normalizeImports) import Ormolu.Parser.CommentStream import Ormolu.Parser.Result @@ -50,13 +57,13 @@ import Ormolu.Processing.Preprocess import Ormolu.Utils (incSpanLine, showOutputable, textToStringBuffer) --- | Parse a complete module from string. +-- | Parse a complete module from 'Text'. parseModule :: (MonadIO m) => -- | Ormolu configuration Config RegionDeltas -> - -- | Fixity map to include in the resulting 'ParseResult's - LazyFixityMap -> + -- | Package fixity map + PackageFixityMap -> -- | File name (only for source location annotations) FilePath -> -- | Input for parser @@ -65,7 +72,7 @@ ( [GHC.Warn], Either (SrcSpan, String) [SourceSnippet] ) -parseModule config@Config {..} fixityMap path rawInput = liftIO $ do +parseModule config@Config {..} packageFixityMap path rawInput = liftIO $ do -- It's important that 'setDefaultExts' is done before -- 'parsePragmasIntoDynFlags', because otherwise we might enable an -- extension that was explicitly disabled in the file. @@ -74,35 +81,46 @@ GHC.Opt_Haddock (setDefaultExts baseDynFlags) extraOpts = dynOptionToLocatedStr <$> cfgDynOptions + rawInputStringBuffer = textToStringBuffer rawInput + beginningLoc = + mkSrcSpan + (mkSrcLoc (GHC.mkFastString path) 1 1) + (mkSrcLoc (GHC.mkFastString path) 1 1) (warnings, dynFlags) <- - parsePragmasIntoDynFlags baseFlags extraOpts path rawInput >>= \case + parsePragmasIntoDynFlags baseFlags extraOpts path rawInputStringBuffer >>= \case Right res -> pure res - Left err -> - let loc = - mkSrcSpan - (mkSrcLoc (GHC.mkFastString path) 1 1) - (mkSrcLoc (GHC.mkFastString path) 1 1) - in throwIO (OrmoluParsingFailed loc err) + Left err -> throwIO (OrmoluParsingFailed beginningLoc err) let cppEnabled = EnumSet.member Cpp (GHC.extensionFlags dynFlags) + implicitPrelude = EnumSet.member ImplicitPrelude (GHC.extensionFlags dynFlags) + fixityImports <- + parseImports dynFlags implicitPrelude path rawInputStringBuffer >>= \case + Right res -> + pure (applyModuleReexports cfgModuleReexports (extractFixityImports res)) + Left err -> + throwIO (OrmoluParsingFailed beginningLoc err) + let modFixityMap = + applyFixityOverrides + cfgFixityOverrides + (moduleFixityMap packageFixityMap fixityImports) snippets <- runExceptT . forM (preprocess cppEnabled cfgRegion rawInput) $ \case Right region -> fmap ParsedSnippet . ExceptT $ - parseModuleSnippet (config $> region) fixityMap dynFlags path rawInput + parseModuleSnippet (config $> region) modFixityMap dynFlags path rawInput Left raw -> pure $ RawSnippet raw pure (warnings, snippets) parseModuleSnippet :: (MonadIO m) => Config RegionDeltas -> - LazyFixityMap -> + ModuleFixityMap -> DynFlags -> FilePath -> Text -> m (Either (SrcSpan, String) ParseResult) -parseModuleSnippet Config {..} fixityMap dynFlags path rawInput = liftIO $ do +parseModuleSnippet Config {..} modFixityMap dynFlags path rawInput = liftIO $ do let (input, indent) = removeIndentation . linesInRegion cfgRegion $ rawInput let pStateErrors pstate = - let errs = bagToList . getMessages $ GHC.getPsErrorMessages pstate + let errs = bagToList . GHC.getMessages $ GHC.getPsErrorMessages pstate fixupErrSpan = incSpanLine (regionPrefixLength cfgRegion) rateSeverity = \case SevError -> 1 :: Int @@ -116,7 +134,7 @@ msg = showOutputable . formatBulleted defaultSDocContext - . diagnosticMessage NoDiagnosticOpts + . diagnosticMessage GHC.NoDiagnosticOpts $ err in case L.sortOn (rateSeverity . errMsgSeverity) errs of [] -> Nothing @@ -148,8 +166,7 @@ prPragmas = pragmas, prCommentStream = comments, prExtensions = GHC.extensionFlags dynFlags, - prFixityOverrides = cfgFixityOverrides, - prFixityMap = fixityMap, + prModuleFixityMap = modFixityMap, prIndent = indent } return r @@ -253,6 +270,8 @@ ---------------------------------------------------------------------------- -- Helpers taken from HLint +-- | Detect pragmas in the given input and return them as a collection of +-- 'DynFlags'. parsePragmasIntoDynFlags :: -- | Pre-set 'DynFlags' DynFlags -> @@ -261,14 +280,14 @@ -- | File name (only for source location annotations) FilePath -> -- | Input for parser - Text -> + StringBuffer -> IO (Either String ([GHC.Warn], DynFlags)) -parsePragmasIntoDynFlags flags extraOpts filepath str = - catchErrors $ do +parsePragmasIntoDynFlags flags extraOpts filepath input = + catchGhcErrors $ do let (_warnings, fileOpts) = GHC.getOptions (initParserOpts flags) - (textToStringBuffer str) + input filepath (flags', leftovers, warnings) <- parseDynamicFilePragma flags (extraOpts <> fileOpts) @@ -278,9 +297,45 @@ throwIO (OrmoluUnrecognizedOpts (unLoc <$> unrecognizedOpts)) let flags'' = flags' `gopt_set` Opt_KeepRawTokenStream return $ Right (warnings, flags'') + +-- | Detect the collection of imports used in the given input. +parseImports :: + -- | Pre-set 'DynFlags' + DynFlags -> + -- | Implicit Prelude? + Bool -> + -- | File name (only for source location annotations) + FilePath -> + -- | Input for the parser + StringBuffer -> + IO (Either String [LImportDecl GhcPs]) +parseImports flags implicitPrelude filepath input = + case GHC.unP GHC.parseHeader (GHC.initParserState popts input loc) of + GHC.PFailed pst -> + return $ Left (showOutputable (GHC.getPsErrorMessages pst)) + GHC.POk pst rdr_module -> + return $ + let (_warnings, errors) = GHC.getPsMessages pst + in if not (isEmptyMessages errors) + then Left (showOutputable (GHC.GhcPsMessage <$> errors)) + else + let hsmod = unLoc rdr_module + mmoduleName = hsmodName hsmod + main_loc = srcLocSpan (mkSrcLoc (GHC.mkFastString filepath) 1 1) + mod' = mmoduleName `orElse` L (GHC.noAnnSrcSpan main_loc) mAIN_NAME + explicitImports = hsmodImports hsmod + implicitImports = + GHC.mkPrelImports (unLoc mod') main_loc implicitPrelude explicitImports + in Right (explicitImports ++ implicitImports) where - catchErrors act = - GHC.handleGhcException - reportErr - (GHC.handleSourceError reportErr act) + popts = initParserOpts flags + loc = mkRealSrcLoc (GHC.mkFastString filepath) 1 1 + +-- | Catch and report GHC errors. +catchGhcErrors :: (ExceptionMonad m) => m (Either String a) -> m (Either String a) +catchGhcErrors m = + GHC.handleGhcException + reportErr + (GHC.handleSourceError reportErr m) + where reportErr e = return $ Left (show e) diff --git a/src/Ormolu/Parser/CommentStream.hs b/src/Ormolu/Parser/CommentStream.hs --- a/src/Ormolu/Parser/CommentStream.hs +++ b/src/Ormolu/Parser/CommentStream.hs @@ -10,6 +10,7 @@ showCommentStream, -- * Comment + LComment, Comment (..), unComment, hasAtomsBefore, @@ -44,7 +45,7 @@ -- | A stream of 'RealLocated' 'Comment's in ascending order with respect to -- beginning of corresponding spans. -newtype CommentStream = CommentStream [RealLocated Comment] +newtype CommentStream = CommentStream [LComment] deriving (Eq, Data, Semigroup, Monoid) -- | Create 'CommentStream' from 'HsModule'. The pragmas are @@ -55,8 +56,8 @@ -- | Module to use for comment extraction HsModule GhcPs -> -- | Stack header, pragmas, and comment stream - ( Maybe (RealLocated Comment), - [([RealLocated Comment], Pragma)], + ( Maybe LComment, + [([LComment], Pragma)], CommentStream ) mkCommentStream input hsModule = @@ -115,6 +116,8 @@ ---------------------------------------------------------------------------- -- Comment +type LComment = RealLocated Comment + -- | A wrapper for a single comment. The 'Bool' indicates whether there were -- atoms before beginning of the comment in the original input. The -- 'NonEmpty' list inside contains lines of multiline comment @{- … -}@ or @@ -131,7 +134,7 @@ -- | Raw comment string RealLocated Text -> -- | Remaining lines of original input and the constructed 'Comment' - ([(Int, Text)], RealLocated Comment) + ([(Int, Text)], LComment) mkComment ls (L l s) = (ls', comment) where comment = @@ -185,7 +188,7 @@ extractStackHeader :: -- | Comment stream to analyze [RealLocated Text] -> - ([RealLocated Text], Maybe (RealLocated Comment)) + ([RealLocated Text], Maybe LComment) extractStackHeader = \case [] -> ([], Nothing) (x : xs) -> @@ -203,7 +206,7 @@ Text -> -- | Comment stream to analyze [RealLocated Text] -> - ([RealLocated Comment], [([RealLocated Comment], Pragma)]) + ([LComment], [([LComment], Pragma)]) extractPragmas input = go initialLs id id where initialLs = zip [1 ..] (T.lines input) diff --git a/src/Ormolu/Parser/Result.hs b/src/Ormolu/Parser/Result.hs --- a/src/Ormolu/Parser/Result.hs +++ b/src/Ormolu/Parser/Result.hs @@ -9,9 +9,8 @@ import GHC.Data.EnumSet (EnumSet) import GHC.Hs import GHC.LanguageExtensions.Type -import GHC.Types.SrcLoc import Ormolu.Config (SourceType) -import Ormolu.Fixity (FixityMap, LazyFixityMap) +import Ormolu.Fixity (ModuleFixityMap) import Ormolu.Parser.CommentStream import Ormolu.Parser.Pragma (Pragma) @@ -25,17 +24,15 @@ -- | Either regular module or signature file prSourceType :: SourceType, -- | Stack header - prStackHeader :: Maybe (RealLocated Comment), + prStackHeader :: Maybe LComment, -- | Pragmas and the associated comments - prPragmas :: [([RealLocated Comment], Pragma)], + prPragmas :: [([LComment], Pragma)], -- | Comment stream prCommentStream :: CommentStream, -- | Enabled extensions prExtensions :: EnumSet Extension, - -- | Fixity overrides - prFixityOverrides :: FixityMap, -- | Fixity map for operators - prFixityMap :: LazyFixityMap, + prModuleFixityMap :: ModuleFixityMap, -- | Indentation level, can be non-zero in case of region formatting prIndent :: Int } diff --git a/src/Ormolu/Printer.hs b/src/Ormolu/Printer.hs --- a/src/Ormolu/Printer.hs +++ b/src/Ormolu/Printer.hs @@ -36,6 +36,5 @@ prCommentStream prSourceType prExtensions - prFixityOverrides - prFixityMap + prModuleFixityMap RawSnippet r -> r diff --git a/src/Ormolu/Printer/Combinators.hs b/src/Ormolu/Printer/Combinators.hs --- a/src/Ormolu/Printer/Combinators.hs +++ b/src/Ormolu/Printer/Combinators.hs @@ -10,6 +10,7 @@ R, runR, getEnclosingSpan, + getEnclosingSpanWhere, isExtensionEnabled, -- * Combinators @@ -21,11 +22,10 @@ newline, inci, inciIf, - inciHalf, askSourceType, - askFixityOverrides, - askFixityMap, + askModuleFixityMap, located, + encloseLocated, located', switchLayout, Layout (..), @@ -78,7 +78,7 @@ import GHC.Types.SrcLoc import Ormolu.Printer.Comments import Ormolu.Printer.Internal -import Ormolu.Utils (HasSrcSpan (..)) +import Ormolu.Utils (HasSrcSpan (..), getLoc') ---------------------------------------------------------------------------- -- Basic @@ -111,6 +111,23 @@ withEnclosingSpan l $ switchLayout [RealSrcSpan l Strict.Nothing] (f a) spitFollowingComments l + +-- | Similar to 'located', but when the "payload" is an empty list, print +-- virtual elements at the start and end of the source span to prevent comments +-- from "floating out". +encloseLocated :: + (HasSrcSpan l) => + GenLocated l [a] -> + ([a] -> R ()) -> + R () +encloseLocated la f = located la $ \a -> do + when (null a) $ located (L startSpan ()) pure + f a + when (null a) $ located (L endSpan ()) pure + where + l = getLoc' la + (startLoc, endLoc) = (srcSpanStart l, srcSpanEnd l) + (startSpan, endSpan) = (mkSrcSpan startLoc startLoc, mkSrcSpan endLoc endLoc) -- | A version of 'located' with arguments flipped. located' :: diff --git a/src/Ormolu/Printer/Comments.hs b/src/Ormolu/Printer/Comments.hs --- a/src/Ormolu/Printer/Comments.hs +++ b/src/Ormolu/Printer/Comments.hs @@ -27,8 +27,8 @@ RealSrcSpan -> R () spitPrecedingComments ref = do - gotSome <- handleCommentSeries (spitPrecedingComment ref) - when gotSome $ do + comments <- handleCommentSeries (spitPrecedingComment ref) + when (not $ null comments) $ do lastMark <- getSpanMark -- Insert a blank line between the preceding comments and the thing -- after them if there was a blank line in the input. @@ -58,8 +58,8 @@ spitPrecedingComment :: -- | Span of the element to attach comments to RealSrcSpan -> - -- | Are we done? - R Bool + -- | The comment that was output, if any + R (Maybe LComment) spitPrecedingComment ref = do mlastMark <- getSpanMark let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref @@ -81,14 +81,14 @@ spitFollowingComment :: -- | AST element to attach comments to RealSrcSpan -> - -- | Are we done? - R Bool + -- | The comment that was output, if any + R (Maybe LComment) spitFollowingComment ref = do mlastMark <- getSpanMark mnSpn <- nextEltSpan -- Get first enclosing span that is not equal to reference span, i.e. it's -- truly something enclosing the AST element. - meSpn <- getEnclosingSpan (/= ref) + meSpn <- getEnclosingSpanWhere (/= ref) withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastMark) $ \l comment -> if theSameLinePost l ref then @@ -102,8 +102,8 @@ -- | Output a single remaining comment from the comment stream. spitRemainingComment :: - -- | Are we done? - R Bool + -- | The comment that was output, if any + R (Maybe LComment) spitRemainingComment = do mlastMark <- getSpanMark withPoppedComment (const True) $ \l comment -> do @@ -116,33 +116,33 @@ -- | Output series of comments. handleCommentSeries :: - -- | Given location of previous comment, output the next comment - -- returning 'True' if we're done - R Bool -> - -- | Whether we printed any comments - R Bool -handleCommentSeries f = go False + -- | Output and return the next comment, if any + R (Maybe LComment) -> + -- | The comments outputted + R [LComment] +handleCommentSeries f = go where - go gotSome = do - done <- f - if done - then return gotSome - else go True + go = do + mComment <- f + case mComment of + Nothing -> return [] + Just comment -> (comment :) <$> go -- | Try to pop a comment using given predicate and if there is a comment -- matching the predicate, print it out. withPoppedComment :: -- | Comment predicate - (RealLocated Comment -> Bool) -> + (LComment -> Bool) -> -- | Printing function (RealSrcSpan -> Comment -> R ()) -> -- | Are we done? - R Bool + R (Maybe LComment) withPoppedComment p f = do r <- popComment p case r of - Nothing -> return True - Just (L l comment) -> False <$ f l comment + Nothing -> return () + Just (L l comment) -> f l comment + return r -- | Determine if we need to insert a newline between current comment and -- last printed comment. @@ -190,7 +190,7 @@ -- | Location of last comment in the series Maybe SpanMark -> -- | Comment to test - RealLocated Comment -> + LComment -> Bool commentFollowsElt ref mnSpn meSpn mlastMark (L l comment) = -- A comment follows a AST element if all 4 conditions are satisfied: diff --git a/src/Ormolu/Printer/Internal.hs b/src/Ormolu/Printer/Internal.hs --- a/src/Ormolu/Printer/Internal.hs +++ b/src/Ormolu/Printer/Internal.hs @@ -17,10 +17,8 @@ space, newline, askSourceType, - askFixityOverrides, - askFixityMap, + askModuleFixityMap, inci, - inciHalf, sitcc, Layout (..), enterLayout, @@ -39,6 +37,7 @@ nextEltSpan, popComment, getEnclosingSpan, + getEnclosingSpanWhere, withEnclosingSpan, thisLineSpans, @@ -59,6 +58,7 @@ import Control.Monad.State.Strict import Data.Bool (bool) import Data.Coerce +import Data.List (find) import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Text qualified as T @@ -70,7 +70,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable (Outputable) import Ormolu.Config (SourceType (..)) -import Ormolu.Fixity (FixityMap, LazyFixityMap) +import Ormolu.Fixity (ModuleFixityMap) import Ormolu.Parser.CommentStream import Ormolu.Printer.SpanStream import Ormolu.Utils (showOutputable) @@ -99,12 +99,8 @@ rcExtensions :: EnumSet Extension, -- | Whether the source is a signature or a regular module rcSourceType :: SourceType, - -- | Fixity map overrides, kept separately because if we parametrized - -- 'Ormolu.Fixity.buildFixityMap' by fixity overrides it would break - -- memoization - rcFixityOverrides :: FixityMap, - -- | Fixity map for operators - rcFixityMap :: LazyFixityMap + -- | Module fixity map + rcModuleFixityMap :: ModuleFixityMap } -- | State context of 'R'. @@ -172,13 +168,11 @@ SourceType -> -- | Enabled extensions EnumSet Extension -> - -- | Fixity overrides - FixityMap -> - -- | Fixity map - LazyFixityMap -> + -- | Module fixity map + ModuleFixityMap -> -- | Resulting rendition Text -runR (R m) sstream cstream sourceType extensions fixityOverrides fixityMap = +runR (R m) sstream cstream sourceType extensions moduleFixityMap = TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc where rc = @@ -189,8 +183,7 @@ rcCanUseBraces = False, rcExtensions = extensions, rcSourceType = sourceType, - rcFixityOverrides = fixityOverrides, - rcFixityMap = fixityMap + rcModuleFixityMap = moduleFixityMap } sc = SC @@ -387,13 +380,9 @@ askSourceType :: R SourceType askSourceType = R (asks rcSourceType) --- | Retrieve fixity overrides map. -askFixityOverrides :: R FixityMap -askFixityOverrides = R (asks rcFixityOverrides) - --- | Retrieve the lazy fixity map. -askFixityMap :: R LazyFixityMap -askFixityMap = R (asks rcFixityMap) +-- | Retrieve the module fixity map. +askModuleFixityMap :: R ModuleFixityMap +askModuleFixityMap = R (asks rcModuleFixityMap) inciBy :: Int -> R () -> R () inciBy step (R m) = R (local modRC m) @@ -411,11 +400,6 @@ inci :: R () -> R () inci = inciBy indentStep --- | In rare cases, we have to indent by a positive amount smaller --- than 'indentStep'. -inciHalf :: R () -> R () -inciHalf = inciBy $ (indentStep `div` 2) `max` 1 - -- | Set indentation level for the inner computation equal to current -- column. This makes sure that the entire inner block is uniformly -- \"shifted\" to the right. @@ -496,31 +480,27 @@ -- | Pop a 'Comment' from the 'CommentStream' if given predicate is -- satisfied and there are comments in the stream. popComment :: - (RealLocated Comment -> Bool) -> - R (Maybe (RealLocated Comment)) + (LComment -> Bool) -> + R (Maybe LComment) popComment f = R $ do CommentStream cstream <- gets scCommentStream case cstream of - [] -> return Nothing - (x : xs) -> - if f x - then - Just x - <$ modify - ( \sc -> - sc - { scCommentStream = CommentStream xs - } - ) - else return Nothing + (x : xs) | f x -> do + modify $ \sc -> sc {scCommentStream = CommentStream xs} + return $ Just x + _ -> return Nothing +-- | Get the immediately enclosing 'RealSrcSpan'. +getEnclosingSpan :: R (Maybe RealSrcSpan) +getEnclosingSpan = getEnclosingSpanWhere (const True) + -- | Get the first enclosing 'RealSrcSpan' that satisfies given predicate. -getEnclosingSpan :: +getEnclosingSpanWhere :: -- | Predicate to use (RealSrcSpan -> Bool) -> R (Maybe RealSrcSpan) -getEnclosingSpan f = - listToMaybe . filter f <$> R (asks rcEnclosingSpans) +getEnclosingSpanWhere f = + find f <$> R (asks rcEnclosingSpans) -- | Set 'RealSrcSpan' of enclosing span for the given computation. withEnclosingSpan :: RealSrcSpan -> R () -> R () diff --git a/src/Ormolu/Printer/Meat/Common.hs b/src/Ormolu/Printer/Meat/Common.hs --- a/src/Ormolu/Printer/Meat/Common.hs +++ b/src/Ormolu/Printer/Meat/Common.hs @@ -164,7 +164,7 @@ -- It's often the case that the comment itself doesn't have a span -- attached to it and instead its location can be obtained from -- nearest enclosing span. - getEnclosingSpan (const True) >>= mapM_ (setSpanMark . HaddockSpan hstyle) + getEnclosingSpan >>= mapM_ (setSpanMark . HaddockSpan hstyle) RealSrcSpan spn _ -> setSpanMark (HaddockSpan hstyle spn) -- | Print anchor of named doc section. diff --git a/src/Ormolu/Printer/Meat/Declaration/Data.hs b/src/Ormolu/Printer/Meat/Declaration/Data.hs --- a/src/Ormolu/Printer/Meat/Declaration/Data.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Data.hs @@ -59,10 +59,18 @@ txt " #-}" let constructorSpans = getLocA name : fmap lhsTypeArgSrcSpan tpats sigSpans = maybeToList . fmap getLocA $ dd_kindSig - declHeaderSpans = constructorSpans ++ sigSpans + declHeaderSpans = + maybeToList (getLocA <$> dd_ctxt) ++ constructorSpans ++ sigSpans switchLayout declHeaderSpans $ do breakpoint inci $ do + case dd_ctxt of + Nothing -> pure () + Just ctxt -> do + located ctxt p_hsContext + space + txt "=>" + breakpoint switchLayout constructorSpans $ p_infixDefHelper (isInfix fixity) diff --git a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs --- a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs +++ b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs @@ -23,7 +23,8 @@ import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common (p_rdrName) import Ormolu.Printer.Meat.Declaration.Value - ( cmdTopPlacement, + ( IsApplicand (..), + cmdTopPlacement, exprPlacement, p_hsCmdTop, p_hsExpr, @@ -91,7 +92,7 @@ -- operator fixity OpTree (LHsExpr GhcPs) (OpInfo (LHsExpr GhcPs)) -> R () -p_exprOpTree s (OpNode x) = located x (p_hsExpr' s) +p_exprOpTree s (OpNode x) = located x (p_hsExpr' NotApplicand s) p_exprOpTree s t@(OpBranches exprs ops) = do let firstExpr = head exprs otherExprs = tail exprs @@ -114,7 +115,7 @@ couldBeTrailing (prevExpr, opi) = -- An operator with fixity InfixR 0, like seq, $, and $ variants, -- is required - isHardSplitterOp (opiFix opi) + isHardSplitterOp (opiFixityApproximation opi) -- the LHS must be single-line && isOneLineSpan (opTreeLoc prevExpr) -- can only happen when a breakpoint would have been added anyway diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs b/src/Ormolu/Printer/Meat/Declaration/Value.hs --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs @@ -10,6 +10,7 @@ p_hsExpr, p_hsUntypedSplice, p_stringLit, + IsApplicand (..), p_hsExpr', p_hsCmdTop, exprPlacement, @@ -186,7 +187,7 @@ False <$ case style of Function name -> p_rdrName name _ -> return () - Just ne_pats -> do + Just ne_pats@(head_pat :| tail_pats) -> do let combinedSpans = case style of Function name -> combineSrcSpans (getLocA name) patSpans _ -> patSpans @@ -204,7 +205,7 @@ PatternBind -> stdCase Case -> stdCase Lambda -> do - let needsSpace = case unLoc (NE.head ne_pats) of + let needsSpace = case unLoc head_pat of LazyPat _ _ -> True BangPat _ _ -> True SplicePat _ _ -> True @@ -212,7 +213,13 @@ txt "\\" when needsSpace space sitcc stdCase - LambdaCase -> stdCase + LambdaCase -> do + located' p_pat head_pat + unless (null tail_pats) $ do + breakpoint + -- When we have multiple patterns (with `\cases`) across multiple + -- lines, we have to indent all but the first pattern. + inci $ sep breakpoint (located' p_pat) tail_pats return indentBody let -- Calculate position of end of patterns. This is useful when we decide -- about putting certain constructions in hanging positions. @@ -317,10 +324,10 @@ p_body = located body render p_hsCmd :: HsCmd GhcPs -> R () -p_hsCmd = p_hsCmd' N +p_hsCmd = p_hsCmd' NotApplicand N -p_hsCmd' :: BracketStyle -> HsCmd GhcPs -> R () -p_hsCmd' s = \case +p_hsCmd' :: IsApplicand -> BracketStyle -> HsCmd GhcPs -> R () +p_hsCmd' isApp s = \case HsCmdArrApp _ body input arrType rightToLeft -> do let (l, r) = if rightToLeft then (body, input) else (input, body) located l p_hsExpr @@ -339,34 +346,33 @@ breakpoint inci (sequence_ (intersperse breakpoint (located' (p_hsCmdTop N) <$> cmds))) HsCmdArrForm _ form Infix _ [left, right] -> do - fixityOverrides <- askFixityOverrides - fixityMap <- askFixityMap + modFixityMap <- askModuleFixityMap let opTree = OpBranches [cmdOpTree left, cmdOpTree right] [form] p_cmdOpTree s - (reassociateOpTree (getOpName . unLoc) fixityOverrides fixityMap opTree) + (reassociateOpTree (getOpName . unLoc) modFixityMap opTree) HsCmdArrForm _ _ Infix _ _ -> notImplemented "HsCmdArrForm" HsCmdApp _ cmd expr -> do - located cmd (p_hsCmd' s) - space - located expr p_hsExpr + located cmd (p_hsCmd' Applicand s) + breakpoint + inci $ located expr p_hsExpr HsCmdLam _ mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup HsCmdPar _ _ c _ -> parens N (located c p_hsCmd) HsCmdCase _ e mgroup -> - p_case cmdPlacement p_hsCmd e mgroup + p_case isApp cmdPlacement p_hsCmd e mgroup HsCmdLamCase _ variant mgroup -> - p_lamcase variant cmdPlacement p_hsCmd mgroup + p_lamcase isApp variant cmdPlacement p_hsCmd mgroup HsCmdIf _ _ if' then' else' -> p_if cmdPlacement p_hsCmd if' then' else' HsCmdLet _ _ localBinds _ c -> p_let p_hsCmd localBinds c HsCmdDo _ es -> do txt "do" - p_stmts cmdPlacement (p_hsCmd' S) es + p_stmts isApp cmdPlacement (p_hsCmd' NotApplicand S) es -- | Print a top-level command. p_hsCmdTop :: BracketStyle -> HsCmdTop GhcPs -> R () -p_hsCmdTop s (HsCmdTop _ cmd) = located cmd (p_hsCmd' s) +p_hsCmdTop s (HsCmdTop _ cmd) = located cmd (p_hsCmd' NotApplicand s) -- | Render an expression preserving blank lines between such consecutive -- expressions found in the original source code. @@ -472,6 +478,7 @@ ( Anno (Stmt GhcPs (LocatedA body)) ~ SrcSpanAnnA, Anno [LocatedA (Stmt GhcPs (LocatedA body))] ~ SrcSpanAnnL ) => + IsApplicand -> -- | Placer (body -> Placement) -> -- | Render @@ -479,10 +486,10 @@ -- | Statements to render LocatedL [LocatedA (Stmt GhcPs (LocatedA body))] -> R () -p_stmts placer render es = do +p_stmts isApp placer render es = do breakpoint ub <- layoutToBraces <$> getLayout - inci . located es $ + inciApplicand isApp . located es $ sepSemi (ub . withSpacing (p_stmt' placer render)) @@ -567,10 +574,24 @@ placeHanging placement (located hfbRHS p_hsExpr) p_hsExpr :: HsExpr GhcPs -> R () -p_hsExpr = p_hsExpr' N +p_hsExpr = p_hsExpr' NotApplicand N -p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R () -p_hsExpr' s = \case +-- | An applicand is the left-hand side in a function application, i.e. @f@ in +-- @f a@. We need to track this in order to add extra identation in cases like +-- +-- > foo = +-- > do +-- > succ +-- > 1 +data IsApplicand = Applicand | NotApplicand + +inciApplicand :: IsApplicand -> R () -> R () +inciApplicand = \case + Applicand -> inci . inci + NotApplicand -> inci + +p_hsExpr' :: IsApplicand -> BracketStyle -> HsExpr GhcPs -> R () +p_hsExpr' isApp s = \case HsVar _ name -> p_rdrName name HsUnboundVar _ occ -> atom occ HsRecSel _ fldOcc -> p_fieldOcc fldOcc @@ -589,7 +610,7 @@ HsLam _ mgroup -> p_matchGroup Lambda mgroup HsLamCase _ variant mgroup -> - p_lamcase variant exprPlacement p_hsExpr mgroup + p_lamcase isApp variant exprPlacement p_hsExpr mgroup HsApp _ f x -> do let -- In order to format function applications with multiple parameters -- nicer, traverse the AST to gather the function and all the @@ -617,35 +638,20 @@ -- one. case placement of Normal -> do - let -- Usually we want to bump indentation for arguments for the - -- sake of readability. However: - -- When the function is itself a multi line do-block or a case - -- expression, we can't indent by indentStep or more. - -- When we are on the other hand *in* a do block, we have to - -- indent by at least 1. - -- Thus, we indent by half of indentStep when the function is - -- a multi line do block or case expression. - indentArg - | isOneLineSpan (getLocA func) = inci - | otherwise = case unLoc func of - HsDo {} -> inciHalf - HsCase {} -> inciHalf - HsLamCase {} -> inciHalf - _ -> inci ub <- getLayout <&> \case SingleLine -> useBraces MultiLine -> id ub $ do - located func (p_hsExpr' s) + located func (p_hsExpr' Applicand s) breakpoint - indentArg $ sep breakpoint (located' p_hsExpr) initp - indentArg $ do + inci $ sep breakpoint (located' p_hsExpr) initp + inci $ do unless (null initp) breakpoint located lastp p_hsExpr Hanging -> do useBraces . switchLayout [initSpan] $ do - located func (p_hsExpr' s) + located func (p_hsExpr' Applicand s) breakpoint sep breakpoint (located' p_hsExpr) initp placeHanging placement . dontUseBraces $ @@ -662,12 +668,11 @@ _ -> return () located (hswc_body a) p_hsType OpApp _ x op y -> do - fixityOverrides <- askFixityOverrides - fixityMap <- askFixityMap + modFixityMap <- askModuleFixityMap let opTree = OpBranches [exprOpTree x, exprOpTree y] [op] p_exprOpTree s - (reassociateOpTree (getOpName . unLoc) fixityOverrides fixityMap opTree) + (reassociateOpTree (getOpName . unLoc) modFixityMap opTree) NegApp _ e _ -> do negativeLiterals <- isExtensionEnabled NegativeLiterals let isLiteral = case unLoc e of @@ -704,7 +709,7 @@ Unboxed -> parensHash enclSpan <- fmap (flip RealSrcSpan Strict.Nothing) . maybeToList - <$> getEnclosingSpan (const True) + <$> getEnclosingSpan if isSection then switchLayout [] . parens' s $ @@ -715,20 +720,20 @@ ExplicitSum _ tag arity e -> p_unboxedSum N tag arity (located e p_hsExpr) HsCase _ e mgroup -> - p_case exprPlacement p_hsExpr e mgroup + p_case isApp exprPlacement p_hsExpr e mgroup HsIf _ if' then' else' -> p_if exprPlacement p_hsExpr if' then' else' HsMultiIf _ guards -> do txt "if" breakpoint - inci . inci $ sep newline (located' (p_grhs RightArrow)) guards + inciApplicand isApp $ sep newline (located' (p_grhs RightArrow)) guards HsLet _ _ localBinds _ e -> p_let p_hsExpr localBinds e HsDo _ doFlavor es -> do let doBody moduleName header = do forM_ moduleName $ \m -> atom m *> txt "." txt header - p_stmts exprPlacement (p_hsExpr' S) es + p_stmts isApp exprPlacement (p_hsExpr' NotApplicand S) es compBody = brackets s . located es $ \xs -> do let p_parBody = sep @@ -911,6 +916,7 @@ ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns, Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => + IsApplicand -> -- | Placer (body -> Placement) -> -- | Render @@ -920,19 +926,20 @@ -- | Match group MatchGroup GhcPs (LocatedA body) -> R () -p_case placer render e mgroup = do +p_case isApp placer render e mgroup = do txt "case" space located e p_hsExpr space txt "of" breakpoint - inci (p_matchGroup' placer render Case mgroup) + inciApplicand isApp (p_matchGroup' placer render Case mgroup) p_lamcase :: ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns, Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => + IsApplicand -> -- | Variant (@\\case@ or @\\cases@) LamCaseVariant -> -- | Placer @@ -942,12 +949,12 @@ -- | Expression MatchGroup GhcPs (LocatedA body) -> R () -p_lamcase variant placer render mgroup = do +p_lamcase isApp variant placer render mgroup = do txt $ case variant of LamCase -> "\\case" LamCases -> "\\cases" breakpoint - inci (p_matchGroup' placer render LambdaCase mgroup) + inciApplicand isApp (p_matchGroup' placer render LambdaCase mgroup) p_if :: -- | Placer diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot b/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot @@ -19,7 +19,10 @@ p_hsExpr :: HsExpr GhcPs -> R () p_hsUntypedSplice :: SpliceDecoration -> HsUntypedSplice GhcPs -> R () p_stringLit :: String -> R () -p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R () + +data IsApplicand + +p_hsExpr' :: IsApplicand -> BracketStyle -> HsExpr GhcPs -> R () p_hsCmdTop :: BracketStyle -> HsCmdTop GhcPs -> R () exprPlacement :: HsExpr GhcPs -> Placement cmdTopPlacement :: HsCmdTop GhcPs -> Placement diff --git a/src/Ormolu/Printer/Meat/ImportExport.hs b/src/Ormolu/Printer/Meat/ImportExport.hs --- a/src/Ormolu/Printer/Meat/ImportExport.hs +++ b/src/Ormolu/Printer/Meat/ImportExport.hs @@ -19,10 +19,6 @@ import Ormolu.Utils (RelativePos (..), attachRelativePos) p_hsmodExports :: [LIE GhcPs] -> R () -p_hsmodExports [] = do - txt "(" - breakpoint' - txt ")" p_hsmodExports xs = parens N $ do layout <- getLayout diff --git a/src/Ormolu/Printer/Meat/Module.hs b/src/Ormolu/Printer/Meat/Module.hs --- a/src/Ormolu/Printer/Meat/Module.hs +++ b/src/Ormolu/Printer/Meat/Module.hs @@ -24,9 +24,9 @@ -- signature). p_hsModule :: -- | Stack header - Maybe (RealLocated Comment) -> + Maybe LComment -> -- | Pragmas and the associated comments - [([RealLocated Comment], Pragma)] -> + [([LComment], Pragma)] -> -- | AST to print HsModule GhcPs -> R () @@ -54,7 +54,7 @@ case hsmodExports of Nothing -> return () Just l -> do - located l $ \exports -> do + encloseLocated l $ \exports -> do inci (p_hsmodExports exports) breakpoint txt "where" diff --git a/src/Ormolu/Printer/Meat/Pragma.hs b/src/Ormolu/Printer/Meat/Pragma.hs --- a/src/Ormolu/Printer/Meat/Pragma.hs +++ b/src/Ormolu/Printer/Meat/Pragma.hs @@ -51,7 +51,7 @@ deriving (Eq, Ord) -- | Print a collection of 'Pragma's with their associated comments. -p_pragmas :: [([RealLocated Comment], Pragma)] -> R () +p_pragmas :: [([LComment], Pragma)] -> R () p_pragmas ps = do let prepare = L.sortOn snd . L.nub . concatMap analyze analyze = \case @@ -63,7 +63,7 @@ forM_ (prepare ps) $ \(cs, (pragmaTy, x)) -> p_pragma cs pragmaTy x -p_pragma :: [RealLocated Comment] -> PragmaTy -> Text -> R () +p_pragma :: [LComment] -> PragmaTy -> Text -> R () p_pragma comments ty x = do forM_ comments $ \(L l comment) -> do spitCommentNow l comment diff --git a/src/Ormolu/Printer/Meat/Type.hs b/src/Ormolu/Printer/Meat/Type.hs --- a/src/Ormolu/Printer/Meat/Type.hs +++ b/src/Ormolu/Printer/Meat/Type.hs @@ -110,11 +110,10 @@ parensHash N $ sep (space >> txt "|" >> breakpoint) (sitcc . located' p_hsType) xs HsOpTy _ _ x op y -> do - fixityOverrides <- askFixityOverrides - fixityMap <- askFixityMap + modFixityMap <- askModuleFixityMap let opTree = OpBranches [tyOpTree x, tyOpTree y] [op] p_tyOpTree - (reassociateOpTree (Just . unLoc) fixityOverrides fixityMap opTree) + (reassociateOpTree (Just . unLoc) modFixityMap opTree) HsParTy _ t -> parens N (located t p_hsType) HsIParamTy _ n t -> sitcc $ do diff --git a/src/Ormolu/Printer/Operators.hs b/src/Ormolu/Printer/Operators.hs --- a/src/Ormolu/Printer/Operators.hs +++ b/src/Ormolu/Printer/Operators.hs @@ -11,10 +11,7 @@ ) where -import Control.Applicative ((<|>)) import Data.List.NonEmpty qualified as NE -import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe) import GHC.Types.Name.Reader import GHC.Types.SrcLoc import Ormolu.Fixity @@ -42,13 +39,13 @@ data OpInfo op = OpInfo { -- | The actual operator opiOp :: op, - -- | Its name, if available. We use 'Maybe OpName' here instead of 'OpName' - -- because the name-fetching function received by 'reassociateOpTree' - -- returns a 'Maybe' - opiName :: Maybe OpName, + -- | Its name, if available. We use 'Maybe RdrName' here instead of + -- 'RdrName' because the name-fetching function received by + -- 'reassociateOpTree' returns a 'Maybe' + opiName :: Maybe RdrName, -- | Information about the fixity direction and precedence level of the -- operator - opiFix :: FixityInfo + opiFixityApproximation :: FixityApproximation } deriving (Eq) @@ -57,21 +54,21 @@ -- of equality. compareOp :: OpInfo op -> OpInfo op -> Maybe Ordering compareOp - (OpInfo _ mName1 FixityInfo {fiMinPrecedence = min1, fiMaxPrecedence = max1}) - (OpInfo _ mName2 FixityInfo {fiMinPrecedence = min2, fiMaxPrecedence = max2}) = + (OpInfo _ mName1 FixityApproximation {faMinPrecedence = min1, faMaxPrecedence = max1}) + (OpInfo _ mName2 FixityApproximation {faMinPrecedence = min2, faMaxPrecedence = max2}) = if - -- Only declare two precedence levels as equal when - -- * either both precedence levels are precise - -- (fiMinPrecedence == fiMaxPrecedence) and match - -- * or when the precedence levels are imprecise but when the - -- operator names match - | min1 == min2 - && max1 == max2 - && (min1 == max1 || sameSymbol) -> - Just EQ - | max1 < min2 -> Just LT - | max2 < min1 -> Just GT - | otherwise -> Nothing + -- Only declare two precedence levels as equal when + -- * either both precedence levels are precise + -- (fiMinPrecedence == fiMaxPrecedence) and match + -- * or when the precedence levels are imprecise but when the + -- operator names match + | min1 == min2 + && max1 == max2 + && (min1 == max1 || sameSymbol) -> + Just EQ + | max1 < min2 -> Just LT + | max2 < min1 -> Just GT + | otherwise -> Nothing where sameSymbol = case (mName1, mName2) of (Just n1, Just n2) -> n1 == n2 @@ -89,48 +86,40 @@ reassociateOpTree :: -- | How to get name of an operator (op -> Maybe RdrName) -> - -- | Fixity overrides - FixityMap -> -- | Fixity Map - LazyFixityMap -> + ModuleFixityMap -> -- | Original 'OpTree' OpTree ty op -> -- | Re-associated 'OpTree', with added context and info around operators OpTree ty (OpInfo op) -reassociateOpTree getOpName fixityOverrides fixityMap = +reassociateOpTree getOpName modFixityMap = reassociateFlatOpTree . makeFlatOpTree - . addFixityInfo fixityOverrides fixityMap getOpName + . addFixityInfo modFixityMap getOpName -- | Wrap every operator of the tree with 'OpInfo' to carry the information -- about its fixity (extracted from the specified fixity map). addFixityInfo :: - -- | Fixity overrides - FixityMap -> -- | Fixity map for operators - LazyFixityMap -> + ModuleFixityMap -> -- | How to get the name of an operator (op -> Maybe RdrName) -> -- | 'OpTree' OpTree ty op -> -- | 'OpTree', with fixity info wrapped around each operator OpTree ty (OpInfo op) -addFixityInfo _ _ _ (OpNode n) = OpNode n -addFixityInfo fixityOverrides fixityMap getOpName (OpBranches exprs ops) = +addFixityInfo _ _ (OpNode n) = OpNode n +addFixityInfo modFixityMap getOpName (OpBranches exprs ops) = OpBranches - (addFixityInfo fixityOverrides fixityMap getOpName <$> exprs) + (addFixityInfo modFixityMap getOpName <$> exprs) (toOpInfo <$> ops) where - toOpInfo o = OpInfo o mName fixityInfo + toOpInfo o = OpInfo o mrdrName fixityApproximation where - mName = occOpName . rdrNameOcc <$> getOpName o - fixityInfo = - fromMaybe - defaultFixityInfo - ( do - name <- mName - Map.lookup name fixityOverrides <|> lookupFixity name fixityMap - ) + mrdrName = getOpName o + fixityApproximation = case mrdrName of + Nothing -> defaultFixityApproximation + Just rdrName -> inferFixity rdrName modFixityMap -- | Given a 'OpTree' of any shape, produce a flat 'OpTree', where every -- node and operator is directly connected to the root. @@ -202,7 +191,7 @@ where indicesOfHardSplitter = fmap fst $ - filter (isHardSplitterOp . opiFix . snd) $ + filter (isHardSplitterOp . opiFixityApproximation . snd) $ zip [0 ..] noptOps indexOfMinMaxPrecOps [] = (Nothing, Nothing) indexOfMinMaxPrecOps (oo : oos) = go oos 1 oo (Just [0]) oo (Just [0]) @@ -367,5 +356,5 @@ -- class of operators because they often have, like ('$'), a specific -- “separator” use-case, and we sometimes format them differently than other -- operators. -isHardSplitterOp :: FixityInfo -> Bool -isHardSplitterOp = (== FixityInfo (Just InfixR) 0 0) +isHardSplitterOp :: FixityApproximation -> Bool +isHardSplitterOp = (== FixityApproximation (Just InfixR) 0 0) diff --git a/src/Ormolu/Utils.hs b/src/Ormolu/Utils.hs --- a/src/Ormolu/Utils.hs +++ b/src/Ormolu/Utils.hs @@ -17,6 +17,7 @@ getLoc', matchAddEpAnn, textToStringBuffer, + ghcModuleNameToCabal, ) where @@ -27,16 +28,19 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Foreign qualified as TFFI +import Distribution.ModuleName (ModuleName) +import Distribution.ModuleName qualified as ModuleName import Foreign (pokeElemOff, withForeignPtr) import GHC.Data.Strict qualified as Strict import GHC.Data.StringBuffer (StringBuffer (..)) import GHC.Driver.Ppr import GHC.DynFlags (baseDynFlags) import GHC.ForeignPtr (mallocPlainForeignPtrBytes) -import GHC.Hs +import GHC.Hs hiding (ModuleName) import GHC.IO.Unsafe (unsafePerformIO) import GHC.Types.SrcLoc import GHC.Utils.Outputable (Outputable (..)) +import Language.Haskell.Syntax.Module.Name qualified as GHC -- | Relative positions in a list. data RelativePos @@ -169,3 +173,7 @@ pure StringBuffer {buf, len, cur = 0} where len = TFFI.lengthWord8 txt + +-- | Convert GHC's 'ModuleName' into the one used by Cabal. +ghcModuleNameToCabal :: GHC.ModuleName -> ModuleName +ghcModuleNameToCabal = ModuleName.fromString . GHC.moduleNameString diff --git a/src/Ormolu/Utils/Cabal.hs b/src/Ormolu/Utils/Cabal.hs --- a/src/Ormolu/Utils/Cabal.hs +++ b/src/Ormolu/Utils/Cabal.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} module Ormolu.Utils.Cabal ( CabalSearchResult (..), @@ -29,9 +28,9 @@ import Language.Haskell.Extension import Ormolu.Config import Ormolu.Exception +import Ormolu.Utils.IO (findClosestFileSatisfying) import System.Directory import System.FilePath -import System.IO.Error (isDoesNotExistError) import System.IO.Unsafe (unsafePerformIO) -- | The result of searching for a @.cabal@ file. @@ -68,8 +67,8 @@ FilePath -> -- | Extracted cabal info, if any m CabalSearchResult -getCabalInfoForSourceFile sourceFile = liftIO $ do - findCabalFile sourceFile >>= \case +getCabalInfoForSourceFile sourceFile = + liftIO (findCabalFile sourceFile) >>= \case Just cabalFile -> do (mentioned, cabalInfo) <- parseCabalInfo cabalFile sourceFile return @@ -79,34 +78,16 @@ ) Nothing -> return CabalNotFound --- | Find the path to an appropriate .cabal file for a Haskell source file, --- if available. +-- | Find the path to an appropriate @.cabal@ file for a Haskell source +-- file, if available. findCabalFile :: (MonadIO m) => - -- | Path to a Haskell source file in a project with a .cabal file + -- | Path to a Haskell source file in a project with a @.cabal@ file FilePath -> - -- | Absolute path to the .cabal file if available + -- | Absolute path to the @.cabal@ file, if available m (Maybe FilePath) -findCabalFile sourceFile = liftIO $ do - parentDir <- takeDirectory <$> makeAbsolute sourceFile - dirEntries <- - listDirectory parentDir `catch` \case - (isDoesNotExistError -> True) -> pure [] - e -> throwIO e - let findDotCabal = \case - [] -> pure Nothing - e : es - | takeExtension e == ".cabal" -> - doesFileExist (parentDir e) >>= \case - True -> pure $ Just e - False -> findDotCabal es - _ : es -> findDotCabal es - findDotCabal dirEntries >>= \case - Just cabalFile -> pure . Just $ parentDir cabalFile - Nothing -> - if isDrive parentDir - then pure Nothing - else findCabalFile parentDir +findCabalFile = findClosestFileSatisfying $ \x -> + takeExtension x == ".cabal" -- | Parsed cabal file information to be shared across multiple source files. data CachedCabalFile = CachedCabalFile @@ -118,12 +99,12 @@ } deriving (Show) --- | Cache ref that stores 'CachedCabalFile' per cabal file. -cabalCacheRef :: IORef (Map FilePath CachedCabalFile) -cabalCacheRef = unsafePerformIO $ newIORef M.empty -{-# NOINLINE cabalCacheRef #-} +-- | Cache ref that stores 'CachedCabalFile' per Cabal file. +cacheRef :: IORef (Map FilePath CachedCabalFile) +cacheRef = unsafePerformIO $ newIORef M.empty +{-# NOINLINE cacheRef #-} --- | Parse 'CabalInfo' from a .cabal file at the given 'FilePath'. +-- | Parse 'CabalInfo' from a @.cabal@ file at the given 'FilePath'. parseCabalInfo :: (MonadIO m) => -- | Location of the .cabal file @@ -136,7 +117,7 @@ parseCabalInfo cabalFileAsGiven sourceFileAsGiven = liftIO $ do cabalFile <- makeAbsolute cabalFileAsGiven sourceFileAbs <- makeAbsolute sourceFileAsGiven - cabalCache <- readIORef cabalCacheRef + cabalCache <- readIORef cacheRef CachedCabalFile {..} <- whenNothing (M.lookup cabalFile cabalCache) $ do cabalFileBs <- B.readFile cabalFile genericPackageDescription <- @@ -145,7 +126,7 @@ let extensionsAndDeps = getExtensionAndDepsMap cabalFile genericPackageDescription cachedCabalFile = CachedCabalFile {..} - atomicModifyIORef cabalCacheRef $ + atomicModifyIORef cacheRef $ (,cachedCabalFile) . M.insert cabalFile cachedCabalFile let (dynOpts, dependencies, mentioned) = case M.lookup (dropExtensions sourceFileAbs) extensionsAndDeps of diff --git a/src/Ormolu/Utils/Fixity.hs b/src/Ormolu/Utils/Fixity.hs --- a/src/Ormolu/Utils/Fixity.hs +++ b/src/Ormolu/Utils/Fixity.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} module Ormolu.Utils.Fixity - ( getFixityOverridesForSourceFile, + ( getDotOrmoluForSourceFile, parseFixityDeclarationStr, + parseModuleReexportDeclarationStr, ) where @@ -10,51 +11,61 @@ 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 Ormolu.Exception import Ormolu.Fixity import Ormolu.Fixity.Parser -import Ormolu.Utils.Cabal -import Ormolu.Utils.IO (readFileUtf8) +import Ormolu.Utils.IO (findClosestFileSatisfying, readFileUtf8) import System.Directory -import System.FilePath import System.IO.Unsafe (unsafePerformIO) import Text.Megaparsec (errorBundlePretty) --- | Cache ref that stores fixity overrides per cabal file. -cacheRef :: IORef (Map FilePath FixityMap) -cacheRef = unsafePerformIO (newIORef Map.empty) -{-# NOINLINE cacheRef #-} - -- | Attempt to locate and parse an @.ormolu@ file. If it does not exist, --- empty fixity map is returned. This function maintains a cache of fixity --- overrides where cabal file paths act as keys. -getFixityOverridesForSourceFile :: +-- 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 - CabalInfo -> - m FixityMap -getFixityOverridesForSourceFile CabalInfo {..} = liftIO $ do - cache <- readIORef cacheRef - case Map.lookup ciCabalFilePath cache of - Nothing -> do - let dotOrmolu = replaceFileName ciCabalFilePath ".ormolu" - exists <- doesFileExist dotOrmolu - if exists - then do - dotOrmoluRelative <- makeRelativeToCurrentDirectory dotOrmolu - contents <- readFileUtf8 dotOrmolu - case parseFixityMap dotOrmoluRelative contents of + FilePath -> + m (FixityOverrides, ModuleReexports) +getDotOrmoluForSourceFile sourceFile = + liftIO (findDotOrmoluFile sourceFile) >>= \case + Just dotOrmoluFile -> liftIO $ do + cache <- readIORef cacheRef + case Map.lookup dotOrmoluFile cache of + Nothing -> do + dotOrmoluRelative <- makeRelativeToCurrentDirectory dotOrmoluFile + contents <- readFileUtf8 dotOrmoluFile + case parseDotOrmolu dotOrmoluRelative contents of Left errorBundle -> throwIO (OrmoluFixityOverridesParseError errorBundle) Right x -> do - modifyIORef' cacheRef (Map.insert ciCabalFilePath x) + modifyIORef' cacheRef (Map.insert dotOrmoluFile x) return x - else return Map.empty - Just x -> return x + Just x -> return x + Nothing -> return (defaultFixityOverrides, 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 = findClosestFileSatisfying $ \x -> + x == ".ormolu" + +-- | Cache ref that maps names of @.ormolu@ files to their contents. +cacheRef :: IORef (Map FilePath (FixityOverrides, ModuleReexports)) +cacheRef = unsafePerformIO (newIORef Map.empty) +{-# NOINLINE cacheRef #-} + -- | A wrapper around 'parseFixityDeclaration' for parsing individual fixity -- definitions. parseFixityDeclarationStr :: @@ -64,3 +75,13 @@ Either String [(OpName, FixityInfo)] parseFixityDeclarationStr = first errorBundlePretty . parseFixityDeclaration . T.pack + +-- | A wrapper around 'parseModuleReexportDeclaration' for parsing +-- a individual module reexport. +parseModuleReexportDeclarationStr :: + -- | Input to parse + String -> + -- | Parse result + Either String (ModuleName, NonEmpty ModuleName) +parseModuleReexportDeclarationStr = + first errorBundlePretty . parseModuleReexportDeclaration . T.pack diff --git a/src/Ormolu/Utils/IO.hs b/src/Ormolu/Utils/IO.hs --- a/src/Ormolu/Utils/IO.hs +++ b/src/Ormolu/Utils/IO.hs @@ -1,18 +1,25 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + -- | Write 'Text' to files using UTF8 and ignoring native -- line ending conventions. module Ormolu.Utils.IO ( writeFileUtf8, readFileUtf8, getContentsUtf8, + findClosestFileSatisfying, ) where -import Control.Exception (throwIO) +import Control.Exception (catch, throwIO) import Control.Monad.IO.Class import Data.ByteString (ByteString) import Data.ByteString qualified as B import Data.Text (Text) import Data.Text.Encoding qualified as TE +import System.Directory +import System.FilePath +import System.IO.Error (isDoesNotExistError) -- | Write a 'Text' to a file using UTF8 and ignoring native -- line ending conventions. @@ -32,3 +39,35 @@ -- strict and fails immediately if decoding encounters a problem. decodeUtf8 :: (MonadIO m) => ByteString -> m Text decodeUtf8 = liftIO . either throwIO pure . TE.decodeUtf8' + +-- | Find the path to the closest file higher in the file hierarchy that +-- satisfies a given predicate. +findClosestFileSatisfying :: + (MonadIO m) => + -- | The predicate that determines what we are looking for + (FilePath -> Bool) -> + -- | Path to the starting point for the search + FilePath -> + -- | Absolute path to the found file if available + m (Maybe FilePath) +findClosestFileSatisfying isRightFile rootOfSearch = liftIO $ do + parentDir <- takeDirectory <$> makeAbsolute rootOfSearch + dirEntries <- + listDirectory parentDir `catch` \case + (isDoesNotExistError -> True) -> pure [] + e -> throwIO e + let searchAtParentDirLevel = \case + [] -> pure Nothing + x : xs -> + if isRightFile x + then + doesFileExist (parentDir x) >>= \case + True -> pure (Just x) + False -> searchAtParentDirLevel xs + else searchAtParentDirLevel xs + searchAtParentDirLevel dirEntries >>= \case + Just foundFile -> pure . Just $ parentDir foundFile + Nothing -> + if isDrive parentDir + then pure Nothing + else findClosestFileSatisfying isRightFile parentDir diff --git a/tests/Ormolu/CabalInfoSpec.hs b/tests/Ormolu/CabalInfoSpec.hs --- a/tests/Ormolu/CabalInfoSpec.hs +++ b/tests/Ormolu/CabalInfoSpec.hs @@ -44,7 +44,7 @@ mentioned `shouldBe` True unPackageName ciPackageName `shouldBe` "ormolu" ciDynOpts `shouldBe` [DynOption "-XGHC2021"] - Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "QuickCheck", "base", "containers", "directory", "filepath", "ghc-lib-parser", "hspec", "hspec-megaparsec", "ormolu", "path", "path-io", "temporary", "text"] + Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "QuickCheck", "base", "containers", "directory", "filepath", "ghc-lib-parser", "hspec", "hspec-megaparsec", "megaparsec", "ormolu", "path", "path-io", "temporary", "text"] ciCabalFilePath `shouldSatisfy` isAbsolute makeRelativeToCurrentDirectory ciCabalFilePath `shouldReturn` "ormolu.cabal" it "handles correctly files that are not mentioned in ormolu.cabal" $ do diff --git a/tests/Ormolu/Fixity/ParserSpec.hs b/tests/Ormolu/Fixity/ParserSpec.hs --- a/tests/Ormolu/Fixity/ParserSpec.hs +++ b/tests/Ormolu/Fixity/ParserSpec.hs @@ -2,6 +2,7 @@ module Ormolu.Fixity.ParserSpec (spec) where +import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T @@ -9,35 +10,126 @@ import Ormolu.Fixity.Parser import Test.Hspec import Test.Hspec.Megaparsec +import Text.Megaparsec.Error (ErrorFancy (..)) spec :: Spec spec = do + describe "parseDotOrmolu" $ do + it "parses the empty input without choking" $ + parseDotOrmolu "" "" + `shouldParse` (FixityOverrides Map.empty, ModuleReexports Map.empty) + it "parses a collection of fixity declarations" $ + -- The example is taken from base. + parseDotOrmolu + "" + ( T.unlines + [ "infixr 9 .", + "infixr 5 ++", + "infixl 4 <$", + "infixl 1 >>, >>=", + "infixr 1 =<<", + "infixr 0 $, $!", + "infixl 4 <*>, <*, *>, <**>" + ] + ) + `shouldParse` ( exampleFixityOverrides, + ModuleReexports Map.empty + ) + it "combines conflicting fixity declarations correctly" $ + parseDotOrmolu + "" + ( T.unlines + [ "infixr 9 ., ^", + "infixr 7 ., $", + "infixr 9 ^ ", + "infixl 7 $" + ] + ) + `shouldParse` ( FixityOverrides + ( Map.fromList + [ ("$", FixityInfo InfixL 7), + (".", FixityInfo InfixR 7), + ("^", FixityInfo InfixR 9) + ] + ), + ModuleReexports Map.empty + ) + it "handles CRLF line endings correctly" $ + parseDotOrmolu "" + `shouldSucceedOn` unlinesCrlf + [ "infixr 9 .", + "infixr 5 ++" + ] + it "fails with correct parse error (keyword wrong second line)" $ + parseDotOrmolu "" "infixr 5 .\nfoobar 5 $" + `shouldFailWith` err + 11 + ( mconcat + [ utok 'f', + etoks "infix", + etoks "infixl", + etoks "infixr", + etoks "module", + eeof + ] + ) + it "parses module re-exports and combines them correctly" $ + parseDotOrmolu + "" + ( T.unlines + [ "module Control.Lens exports Control.Lens.Lens", + "module Control.Lens exports Control.Lens.At", + "module Text.Megaparsec exports Control.Monad.Combinators" + ] + ) + `shouldParse` (FixityOverrides Map.empty, exampleModuleReexports) + it "parses fixity declarations + module re-export declarations with blanks" $ + parseDotOrmolu + "" + ( T.unlines + [ "module Control.Lens exports Control.Lens.Lens", + "", + "infixr 5 ++", + "infixl 4 <$", + "", + "", + "module Control.Lens exports Control.Lens.At", + "infixr 9 .", + "module Text.Megaparsec exports Control.Monad.Combinators", + "infixl 1 >>, >>=", + "infixr 1 =<<", + "", + "infixr 0 $, $!", + "infixl 4 <*>, <*, *>, <**>" + ] + ) + `shouldParse` (exampleFixityOverrides, exampleModuleReexports) describe "parseFixtiyDeclaration" $ do it "parses a simple infixr declaration" $ parseFixityDeclaration "infixr 5 $" - `shouldParse` [("$", FixityInfo (Just InfixR) 5 5)] + `shouldParse` [("$", FixityInfo InfixR 5)] it "parses a simple infixl declaration" $ parseFixityDeclaration "infixl 5 $" - `shouldParse` [("$", FixityInfo (Just InfixL) 5 5)] + `shouldParse` [("$", FixityInfo InfixL 5)] it "parses a simple infix declaration" $ parseFixityDeclaration "infix 5 $" - `shouldParse` [("$", FixityInfo (Just InfixN) 5 5)] + `shouldParse` [("$", FixityInfo InfixN 5)] it "parses a declaration for a ticked identifier" $ parseFixityDeclaration "infixl 5 `foo`" - `shouldParse` [("foo", FixityInfo (Just InfixL) 5 5)] + `shouldParse` [("foo", FixityInfo InfixL 5)] it "parses a declaration for a ticked identifier (constructor case)" $ parseFixityDeclaration "infixl 5 `Foo`" - `shouldParse` [("Foo", FixityInfo (Just InfixL) 5 5)] + `shouldParse` [("Foo", FixityInfo InfixL 5)] it "parses a multi-operator declaration" $ parseFixityDeclaration "infixl 5 $, ., `Foo`, `bar`" - `shouldParse` [ ("$", FixityInfo (Just InfixL) 5 5), - (".", FixityInfo (Just InfixL) 5 5), - ("Foo", FixityInfo (Just InfixL) 5 5), - ("bar", FixityInfo (Just InfixL) 5 5) + `shouldParse` [ ("$", FixityInfo InfixL 5), + (".", FixityInfo InfixL 5), + ("Foo", FixityInfo InfixL 5), + ("bar", FixityInfo InfixL 5) ] it "parses a declaration with a unicode operator" $ parseFixityDeclaration "infixr 5 ×" - `shouldParse` [("×", FixityInfo (Just InfixR) 5 5)] + `shouldParse` [("×", FixityInfo InfixR 5)] it "fails with correct parse error (keyword wrong)" $ parseFixityDeclaration "foobar 5 $" `shouldFailWith` err @@ -69,72 +161,74 @@ elabel "operator character" ] ) - describe "parseFixityMap" $ do - it "parses the empty input without choking" $ - parseFixityMap "" "" - `shouldParse` Map.empty - it "parses a collection of declarations" $ - -- The example is taken from base. - parseFixityMap - "" - ( T.unlines - [ "infixr 9 .", - "infixr 5 ++", - "infixl 4 <$", - "infixl 1 >>, >>=", - "infixr 1 =<<", - "infixr 0 $, $!", - "infixl 4 <*>, <*, *>, <**>" - ] - ) - `shouldParse` Map.fromList - [ ("$", FixityInfo (Just InfixR) 0 0), - ("$!", FixityInfo (Just InfixR) 0 0), - ("*>", FixityInfo (Just InfixL) 4 4), - ("++", FixityInfo (Just InfixR) 5 5), - (".", FixityInfo (Just InfixR) 9 9), - ("<$", FixityInfo (Just InfixL) 4 4), - ("<*", FixityInfo (Just InfixL) 4 4), - ("<**>", FixityInfo (Just InfixL) 4 4), - ("<*>", FixityInfo (Just InfixL) 4 4), - ("=<<", FixityInfo (Just InfixR) 1 1), - (">>", FixityInfo (Just InfixL) 1 1), - (">>=", FixityInfo (Just InfixL) 1 1) - ] - it "combines conflicting declarations correctly" $ - parseFixityMap - "" - ( T.unlines - [ "infixr 9 ., ^", - "infixr 7 ., $", - "infixr 9 ^ ", - "infixl 7 $" - ] - ) - `shouldParse` Map.fromList - [ ("$", FixityInfo Nothing 7 7), - (".", FixityInfo (Just InfixR) 7 9), - ("^", FixityInfo (Just InfixR) 9 9) - ] - it "handles CRLF line endings correctly" $ - parseFixityMap "" - `shouldSucceedOn` ( unlinesCrlf - [ "infixr 9 .", - "infixr 5 ++" - ] - ) - it "fails with correct parse error (keyword wrong second line)" $ - parseFixityMap "" "infixr 5 .\nfoobar 5 $" + it "fails with correct parse error (precedence greater than 9)" $ + parseFixityDeclaration "infixl 10 $" + `shouldFailWith` errFancy + 7 + (fancy (ErrorFail "precedence should not be greater than 9")) + describe "parseModuleReexportDeclaration" $ do + it "parses a re-export declaration" $ + parseModuleReexportDeclaration "module Control.Lens exports Control.Lens.Lens" + `shouldParse` ( "Control.Lens", + "Control.Lens.Lens" :| [] + ) + it "fails with correct parse error (keyword wrong)" $ + parseModuleReexportDeclaration "foo Control.Lens exports Control.Lens.Lens" `shouldFailWith` err - 11 + 0 ( mconcat - [ utok 'f', - etoks "infix", - etoks "infixl", - etoks "infixr", - eeof + [ utoks "foo Co", + etoks "module" ] ) + it "fails with correct parse error (module syntax)" $ + parseModuleReexportDeclaration "module control.Lens exports Control.Lens.Lens" + `shouldFailWith` err + 7 + ( mconcat + [ utok 'c', + elabel "module name" + ] + ) + it "fails with correct parse error (typo: export intead exports)" $ + parseModuleReexportDeclaration "module Control.Lens export Control.Lens.Lens" + `shouldFailWith` err + 20 + ( mconcat + [ utoks "export ", + etoks "exports" + ] + ) + +exampleFixityOverrides :: FixityOverrides +exampleFixityOverrides = + FixityOverrides + ( Map.fromList + [ ("$", FixityInfo InfixR 0), + ("$!", FixityInfo InfixR 0), + ("*>", FixityInfo InfixL 4), + ("++", FixityInfo InfixR 5), + (".", FixityInfo InfixR 9), + ("<$", FixityInfo InfixL 4), + ("<*", FixityInfo InfixL 4), + ("<**>", FixityInfo InfixL 4), + ("<*>", FixityInfo InfixL 4), + ("=<<", FixityInfo InfixR 1), + (">>", FixityInfo InfixL 1), + (">>=", FixityInfo InfixL 1) + ] + ) + +exampleModuleReexports :: ModuleReexports +exampleModuleReexports = + ModuleReexports . Map.fromList $ + [ ( "Control.Lens", + "Control.Lens.At" :| ["Control.Lens.Lens"] + ), + ( "Text.Megaparsec", + "Control.Monad.Combinators" :| [] + ) + ] unlinesCrlf :: [Text] -> Text unlinesCrlf = T.concat . fmap (<> "\r\n") diff --git a/tests/Ormolu/Fixity/PrinterSpec.hs b/tests/Ormolu/Fixity/PrinterSpec.hs --- a/tests/Ormolu/Fixity/PrinterSpec.hs +++ b/tests/Ormolu/Fixity/PrinterSpec.hs @@ -1,10 +1,15 @@ {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Ormolu.Fixity.PrinterSpec (spec) where -import Data.Char qualified as Char +import Data.List (intercalate) +import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map import Data.Text qualified as T +import Distribution.ModuleName (ModuleName) +import Distribution.ModuleName qualified as ModuleName +import Distribution.Types.PackageName (PackageName, mkPackageName) import Ormolu.Fixity import Ormolu.Fixity.Parser import Ormolu.Fixity.Printer @@ -12,41 +17,59 @@ import Test.Hspec.Megaparsec import Test.QuickCheck -newtype FixityMapWrapper = FixityMapWrapper FixityMap - deriving (Show) - -instance Arbitrary FixityMapWrapper where +instance Arbitrary FixityOverrides where arbitrary = - FixityMapWrapper . Map.fromListWith (<>) + FixityOverrides . Map.fromList <$> listOf ((,) <$> genOperator <*> genFixityInfo) where - scaleDown = scale (`div` 4) genOperator = OpName . T.pack <$> oneof [genNormalOperator, genIdentifier] genNormalOperator = listOf1 (scaleDown arbitrary `suchThat` isOperatorConstituent) - isOperatorConstituent x = - (Char.isSymbol x || Char.isPunctuation x) && x `notElem` ",`()" genIdentifier = do - x <- arbitrary `suchThat` Char.isLetter + x <- arbitrary `suchThat` isIdentifierFirstChar xs <- listOf1 (scaleDown arbitrary `suchThat` isIdentifierConstituent) return (x : xs) - isIdentifierConstituent x = Char.isAlphaNum x || x == '_' || x == '\'' genFixityInfo = do fiDirection <- elements - [ Nothing, - Just InfixL, - Just InfixR, - Just InfixN + [ InfixL, + InfixR, + InfixN ] - fiMinPrecedence <- chooseInt (0, 9) - fiMaxPrecedence <- chooseInt (0, 9) `suchThat` (>= fiMinPrecedence) + fiPrecedence <- chooseInt (0, 9) return FixityInfo {..} +instance Arbitrary ModuleReexports where + arbitrary = ModuleReexports . Map.fromListWith combine <$> listOf genReexport + where + combine x y = NE.sort (x <> y) + genReexport = do + exportingModule <- arbitrary + exports <- NE.sort . NE.fromList . getNonEmpty <$> scaleDown arbitrary + return (exportingModule, exports) + +instance Arbitrary PackageName where + arbitrary = + mkPackageName + <$> listOf1 (scaleDown arbitrary `suchThat` isPackageNameConstituent) + +instance Arbitrary ModuleName where + arbitrary = + ModuleName.fromString . intercalate "." <$> scaleDown (listOf1 genSegment) + where + genSegment = do + x <- arbitrary `suchThat` isModuleSegmentFirstChar + xs <- listOf (arbitrary `suchThat` isModuleSegmentConstituent) + return (x : xs) + +scaleDown :: Gen a -> Gen a +scaleDown = scale (`div` 4) + spec :: Spec spec = do - describe "parseFixityMap & printFixityMap" $ + describe "parseFixityOverrides & printFixityOverrides" $ it "arbitrary fixity maps are printed and parsed back correctly" $ - property $ \(FixityMapWrapper fixityMap) -> - parseFixityMap "" (printFixityMap fixityMap) `shouldParse` fixityMap + property $ \fixityOverrides moduleReexports -> + parseDotOrmolu "" (printDotOrmolu fixityOverrides moduleReexports) + `shouldParse` (fixityOverrides, moduleReexports) diff --git a/tests/Ormolu/FixitySpec.hs b/tests/Ormolu/FixitySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Ormolu/FixitySpec.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ormolu.FixitySpec (spec) where + +import Data.Function ((&)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Distribution.ModuleName (ModuleName) +import Distribution.Types.PackageName (PackageName) +import GHC.Types.Name (OccName) +import GHC.Types.Name.Occurrence (mkVarOcc) +import GHC.Types.Name.Reader +import Language.Haskell.Syntax.ImpExp (ImportListInterpretation (..)) +import Language.Haskell.Syntax.Module.Name (mkModuleName) +import Ormolu.Fixity +import Ormolu.Fixity.Imports +import Ormolu.Fixity.Internal +import Ormolu.Utils (showOutputable) +import Test.Hspec + +instance Show RdrName where + show = showOutputable + +spec :: Spec +spec = do + it "gives the correct fixity info for (:) (built-in)" $ + checkFixities + [] + [] + [(unqual ":", FixityApproximation (Just InfixR) 5 5)] + it "does not know operators from base if base is not a dependency" $ + checkFixities + [] + [] + [ (unqual "$", defaultFixityApproximation), + (unqual "+", defaultFixityApproximation), + (unqual "++", defaultFixityApproximation) + ] + it "does not know operators from base if Prelude is not imported" $ + checkFixities + [] + [] + [ (unqual "$", defaultFixityApproximation), + (unqual "+", defaultFixityApproximation), + (unqual "++", defaultFixityApproximation) + ] + it "infers fixities of operators from base correctly" $ + checkFixities + ["base"] + [import_ "Prelude"] + [ (unqual "$", FixityApproximation (Just InfixR) 0 0), + (unqual "+", FixityApproximation (Just InfixL) 6 6), + (unqual "++", FixityApproximation (Just InfixR) 5 5) + ] + it "does not know (>>>) when Control.Category is not imported" $ + checkFixities + ["base"] + [import_ "Prelude"] + [ (unqual ">>>", defaultFixityApproximation) + ] + it "infer correct fixity for (>>>) when Control.Category is imported" $ + checkFixities + ["base"] + [ import_ "Prelude", + import_ "Control.Category" + ] + [ (unqual ">>>", FixityApproximation (Just InfixR) 1 1) + ] + it "handles 'as' imports correctly" $ + checkFixities + ["base"] + [ import_ "Control.Category" & as_ "Foo" + ] + [ (unqual ">>>", FixityApproximation (Just InfixR) 1 1), + (qual "Foo" ">>>", FixityApproximation (Just InfixR) 1 1), + (qual "Bar" ">>>", defaultFixityApproximation) + ] + it "handles 'qualified' imports correctly" $ + checkFixities + ["base"] + [import_ "Control.Category" & qualified_] + [ (unqual ">>>", defaultFixityApproximation), + (qual "Control.Category" ">>>", FixityApproximation (Just InfixR) 1 1) + ] + it "handles 'qualified as' imports correctly" $ + checkFixities + ["base"] + [import_ "Control.Category" & qualified_ & as_ "Foo"] + [ (unqual ">>>", defaultFixityApproximation), + (qual "Control.Category" ">>>", defaultFixityApproximation), + (qual "Foo" ">>>", FixityApproximation (Just InfixR) 1 1) + ] + it "handles explicit import lists correctly" $ + checkFixities + ["base"] + [import_ "Prelude" & exactly_ ["$"]] + [ (unqual "$", FixityApproximation (Just InfixR) 0 0), + (unqual "+", defaultFixityApproximation) + ] + it "handles hiding import lists correctly" $ + checkFixities + ["base"] + [import_ "Prelude" & hiding_ ["$"]] + [ (unqual "$", defaultFixityApproximation), + (unqual "+", FixityApproximation (Just InfixL) 6 6), + (unqual "++", FixityApproximation (Just InfixR) 5 5) + ] + it "handles qualified imports with explicit import lists correctly" $ + checkFixities + ["base"] + [import_ "Prelude" & qualified_ & exactly_ ["$"]] + [ (unqual "$", defaultFixityApproximation), + (qual "Prelude" "$", FixityApproximation (Just InfixR) 0 0), + (unqual "+", defaultFixityApproximation), + (qual "Prelude" "+", defaultFixityApproximation) + ] + it "handles qualified import with hiding correctly" $ + checkFixities + ["base"] + [import_ "Prelude" & qualified_ & hiding_ ["$"]] + [ (unqual "$", defaultFixityApproximation), + (qual "Prelude" "$", defaultFixityApproximation), + (unqual "+", defaultFixityApproximation), + (qual "Prelude" "+", FixityApproximation (Just InfixL) 6 6) + ] + it "handles qualified import and explicit import lists correctly (1)" $ + checkFixities + ["base"] + [ import_ "Prelude" & qualified_, + import_ "Prelude" & exactly_ ["$"] + ] + [ (unqual "$", FixityApproximation (Just InfixR) 0 0), + (qual "Prelude" "$", FixityApproximation (Just InfixR) 0 0), + (unqual "+", defaultFixityApproximation), + (qual "Prelude" "+", FixityApproximation (Just InfixL) 6 6) + ] + it "handles qualified import and explicit import lists correctly (2)" $ + checkFixities + ["base"] + [ import_ "Prelude" & exactly_ ["$"], + import_ "Prelude" & qualified_ + ] + [ (unqual "$", FixityApproximation (Just InfixR) 0 0), + (qual "Prelude" "$", FixityApproximation (Just InfixR) 0 0), + (unqual "+", defaultFixityApproximation), + (qual "Prelude" "+", FixityApproximation (Just InfixL) 6 6) + ] + it "handles qualified import and hiding import correctly (1)" $ + checkFixities + ["base"] + [ import_ "Prelude" & qualified_, + import_ "Prelude" & hiding_ ["$"] + ] + [ (unqual "$", defaultFixityApproximation), + (qual "Prelude" "$", FixityApproximation (Just InfixR) 0 0), + (unqual "+", FixityApproximation (Just InfixL) 6 6), + (qual "Prelude" "+", FixityApproximation (Just InfixL) 6 6) + ] + it "handles qualified import and hiding import correctly (2)" $ + checkFixities + ["base"] + [ import_ "Prelude" & hiding_ ["$"], + import_ "Prelude" & qualified_ + ] + [ (unqual "$", defaultFixityApproximation), + (qual "Prelude" "$", FixityApproximation (Just InfixR) 0 0), + (unqual "+", FixityApproximation (Just InfixL) 6 6), + (qual "Prelude" "+", FixityApproximation (Just InfixL) 6 6) + ] + it "works for several imports from different packages" $ + checkFixities + ["base", "esqueleto"] + [ import_ "Prelude", + import_ "Database.Esqueleto.Experimental" & qualified_ & as_ "E" + ] + [ (unqual "$", FixityApproximation (Just InfixR) 0 0), + (qual "E" "++.", FixityApproximation (Just InfixR) 5 5), + (qual "E" "on", FixityApproximation (Just InfixN) 9 9) + ] + it "merges approximations in case of a conflict" $ + checkFixities + ["fclabels", "persistent"] + [ import_ "Data.Label.Monadic", + import_ "Database.Persist" + ] + [ (unqual "=.", FixityApproximation (Just InfixR) 2 3) + ] + it "correctly handles package-qualified imports (1)" $ + checkFixities + ["esqueleto"] + [package_ "esqueleto" $ import_ "Database.Esqueleto.Experimental"] + [(unqual "++.", FixityApproximation (Just InfixR) 5 5)] + it "correctly handles package-qualified imports (2)" $ + checkFixities + ["esqueleto"] + [package_ "bob" $ import_ "Database.Esqueleto.Experimental"] + [(unqual "++.", defaultFixityApproximation)] + it "default module re-exports: Control.Lens brings into scope Control.Lens.Lens" $ + checkFixities + ["lens"] + ( applyModuleReexports + defaultModuleReexports + [import_ "Control.Lens"] + ) + [(unqual "<+~", FixityApproximation (Just InfixR) 4 4)] + it "default module re-exports: Control.Lens qualified brings into scope Control.Lens.Lens" $ + checkFixities + ["lens"] + ( applyModuleReexports + defaultModuleReexports + [import_ "Control.Lens" & qualified_] + ) + [ (unqual "<+~", defaultFixityApproximation), + (qual "Control.Lens.Lens" "<+~", defaultFixityApproximation), + (qual "Control.Lens" "<+~", FixityApproximation (Just InfixR) 4 4) + ] + it "default module re-exports: Control.Lens qualified as brings into scope Control.Lens.Lens" $ + checkFixities + ["lens"] + ( applyModuleReexports + defaultModuleReexports + [import_ "Control.Lens" & qualified_ & as_ "L"] + ) + [ (unqual "<+~", defaultFixityApproximation), + (qual "Control.Lens.Lens" "<+~", defaultFixityApproximation), + (qual "Control.Lens" "<+~", defaultFixityApproximation), + (qual "L" "<+~", FixityApproximation (Just InfixR) 4 4) + ] + it "re-export chains: exported module can itself re-export another module" $ do + let reexports = + ModuleReexports $ + Map.insert + "Foo" + ("Control.Lens" :| []) + (unModuleReexports defaultModuleReexports) + checkFixities + ["lens"] + ( applyModuleReexports + reexports + [import_ "Foo"] + ) + [ (unqual "<+~", FixityApproximation (Just InfixR) 4 4) + ] + +-- | Build a fixity map using the Hoogle database and then check the fixity +-- of the specified subset of operators. +checkFixities :: + -- | List of dependencies + [PackageName] -> + -- | Imports + [FixityImport] -> + -- | Associative list representing a subset of the resulting fixity map + -- that should be checked. + [(RdrName, FixityApproximation)] -> + Expectation +checkFixities dependencies fixityImports expectedResult = + actualResult `shouldBe` expectedResult + where + actualResult = + fmap + (\(k, _) -> (k, inferFixity k resultMap)) + expectedResult + resultMap = + moduleFixityMap + (packageFixityMap (Set.fromList dependencies)) + fixityImports + +qual :: String -> OpName -> RdrName +qual moduleName opName = mkRdrQual (mkModuleName moduleName) (opNameToOccName opName) + +unqual :: OpName -> RdrName +unqual = mkRdrUnqual . opNameToOccName + +opNameToOccName :: OpName -> OccName +opNameToOccName = mkVarOcc . T.unpack . unOpName + +-- | Explicitly specify the package. +package_ :: PackageName -> FixityImport -> FixityImport +package_ packageName fixityImport = + fixityImport + { fimportPackage = Just packageName + } + +-- | Construct a simple 'FixityImport'. +import_ :: ModuleName -> FixityImport +import_ moduleName = + FixityImport + { fimportPackage = Nothing, + fimportModule = moduleName, + fimportQualified = UnqualifiedAndQualified moduleName, + fimportList = Nothing + } + +-- | Adds an alias for an import. +as_ :: ModuleName -> FixityImport -> FixityImport +as_ moduleName fixityImport = + fixityImport + { fimportQualified = case fimportQualified fixityImport of + UnqualifiedAndQualified _ -> UnqualifiedAndQualified moduleName + OnlyQualified _ -> OnlyQualified moduleName + } + +-- | Qualified imports. +qualified_ :: FixityImport -> FixityImport +qualified_ fixityImport = + fixityImport + { fimportQualified = case fimportQualified fixityImport of + UnqualifiedAndQualified m -> OnlyQualified m + OnlyQualified m -> OnlyQualified m + } + +-- | Exact import lists. +exactly_ :: [OpName] -> FixityImport -> FixityImport +exactly_ opNames fixityImports = + fixityImports + { fimportList = Just (Exactly, opNames) + } + +-- | Hiding. +hiding_ :: [OpName] -> FixityImport -> FixityImport +hiding_ opNames fixityImports = + fixityImports + { fimportList = Just (EverythingBut, opNames) + } diff --git a/tests/Ormolu/HackageInfoSpec.hs b/tests/Ormolu/HackageInfoSpec.hs deleted file mode 100644 --- a/tests/Ormolu/HackageInfoSpec.hs +++ /dev/null @@ -1,507 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Ormolu.HackageInfoSpec (spec) where - -import Data.Map.Strict qualified as Map -import Data.Maybe (mapMaybe) -import Data.Set qualified as Set -import Distribution.Types.PackageName (PackageName) -import Ormolu.Fixity -import Test.Hspec - --- | Build a fixity map using the Hackage/Hoogle database, and the boot --- package list, and then check the fixity of the specified subset of --- operators. -checkFixityMap :: - -- | List of dependencies - [PackageName] -> - -- | Threshold to choose the conflict resolution strategy - Float -> - -- | Associative list representing a subset of the resulting fixity map - -- that should be checked. - [(OpName, FixityInfo)] -> - Expectation -checkFixityMap - dependencies - threshold - expectedResult = - actualResult `shouldBe` expectedResult - where - actualResult = - mapMaybe - (\(k, _) -> (k,) <$> lookupFixity k resultMap) - expectedResult - resultMap = - buildFixityMap' - packageToOps - packageToPopularity - bootPackages - threshold - (Set.fromList dependencies) - --- | Build a fixity map from a custom package database, and then check the --- fixity of the specified subset of operators. -checkFixityMap' :: - -- | Associative list for packageToOps: - -- package name -map-> (operator -map-> fixity) - [(PackageName, [(OpName, FixityInfo)])] -> - -- | Associative list for packageToPopularity: - -- package name -map-> download count - [(PackageName, Int)] -> - -- | List of packages that should have a higher priority than - -- unspecified packages (boot packages) - [PackageName] -> - -- | List of dependencies - [PackageName] -> - -- | Threshold to choose the conflict resolution strategy - Float -> - -- | Associative list representing a subset of the resulting fixity map - -- that should be checked. - [(OpName, FixityInfo)] -> - Expectation -checkFixityMap' - lPackageToOps - lPackageToPopularity - highPrioPackages - dependencies - threshold - expectedResult = - actualResult `shouldBe` expectedResult - where - actualResult = - mapMaybe - (\(k, _) -> (k,) <$> lookupFixity k resultMap) - expectedResult - resultMap = - buildFixityMap' - lPackageToOps' - lPackageToPopularity' - (Set.fromList highPrioPackages) - threshold - (Set.fromList dependencies) - lPackageToOps' = - Map.map Map.fromList $ - Map.fromList lPackageToOps - lPackageToPopularity' = Map.fromList lPackageToPopularity - -spec :: Spec -spec = do - it - "correctly merges fixities when a conflict appears in unspecified \ - \packages, with max(pop) < threshold" - $ do - let operators = - [ ("A", [("+", FixityInfo (Just InfixL) 4 4)]), - ("B", [("+", FixityInfo (Just InfixR) 6 6)]) - ] - popularity = - [ ("A", 3), - ("B", 5) - ] - dependencies = [] - higherPriorityPackages = [] - threshold = 0.9 - result = - [ ("+", FixityInfo Nothing 4 6) - ] - checkFixityMap' - operators - popularity - higherPriorityPackages - dependencies - threshold - result - - it - "keeps only the most popular declaration when a conflict appears in \ - \unspecified packages, with max(pop) >= threshold" - $ do - let operators = - [ ("A", [("+", FixityInfo (Just InfixL) 4 4)]), - ("B", [("+", FixityInfo (Just InfixR) 6 6)]) - ] - popularity = - [ ("A", 5), - ("B", 103) - ] - dependencies = [] - higherPriorityPackages = [] - threshold = 0.9 - result = - [ ("+", FixityInfo (Just InfixR) 6 6) - ] - checkFixityMap' - operators - popularity - higherPriorityPackages - dependencies - threshold - result - - it - "merges the ex-aequo most popular declaration when a conflict appears \ - \in unspecified packages, with max(pop) >= threshold" - $ do - let operators = - [ ("A", [("+", FixityInfo (Just InfixL) 4 4)]), - ("B", [("+", FixityInfo (Just InfixR) 6 6)]), - ("C", [("+", FixityInfo (Just InfixR) 8 8)]) - ] - popularity = - [ ("A", 5), - ("B", 103), - ("C", 103) - ] - dependencies = [] - higherPriorityPackages = [] - threshold = 0.4 - result = - [ ("+", FixityInfo (Just InfixR) 6 8) - ] - checkFixityMap' - operators - popularity - higherPriorityPackages - dependencies - threshold - result - - it - "keeps only the most popular declaration when a conflict appears in \ - \unspecified packages, threshold == 0" - $ do - let operators = - [ ("A", [("+", FixityInfo (Just InfixL) 4 4)]), - ("B", [("+", FixityInfo (Just InfixR) 6 6)]) - ] - popularity = - [ ("A", 5), - ("B", 103) - ] - dependencies = [] - higherPriorityPackages = [] - threshold = 0.0 - result = - [ ("+", FixityInfo (Just InfixR) 6 6) - ] - checkFixityMap' - operators - popularity - higherPriorityPackages - dependencies - threshold - result - - it - "merges all declarations when a conflict appears in unspecified \ - \packages, threshold > 1" - $ do - let operators = - [ ("A", [("+", FixityInfo (Just InfixN) 4 4)]), - ("B", [("+", FixityInfo (Just InfixN) 6 6)]), - ("C", [("+", FixityInfo (Just InfixN) 8 8)]) - ] - popularity = - [ ("A", 0), - ("B", 0), - ("C", 11103) - ] - dependencies = [] - higherPriorityPackages = [] - threshold = 10.0 - result = - [ ("+", FixityInfo (Just InfixN) 4 8) - ] - checkFixityMap' - operators - popularity - higherPriorityPackages - dependencies - threshold - result - - it - "merges all declarations when a conflict appears in cabal \ - \dependencies" - $ do - let operators = - [ ( "A", - [ ("+", FixityInfo (Just InfixR) 4 4), - ("-", FixityInfo (Just InfixR) 2 2) - ] - ), - ( "B", - [ ("+", FixityInfo (Just InfixN) 6 6), - ("-", FixityInfo (Just InfixL) 4 4) - ] - ), - ("C", [("+", FixityInfo (Just InfixN) 8 8)]) - ] - popularity = - [ ("A", 0), - ("B", 0), - ("C", 11103) - ] - dependencies = ["B", "C"] - higherPriorityPackages = [] - threshold = 0.4 - result = - [ ("+", FixityInfo (Just InfixN) 6 8), - ("-", FixityInfo (Just InfixL) 4 4) - ] - checkFixityMap' - operators - popularity - higherPriorityPackages - dependencies - threshold - result - - it - "merges all declarations when a conflict appears in higher-priority \ - \packages" - $ do - let operators = - [ ( "A", - [ ("+", FixityInfo (Just InfixR) 4 4), - ("-", FixityInfo (Just InfixR) 2 2) - ] - ), - ( "B", - [ ("+", FixityInfo (Just InfixN) 6 6), - ("-", FixityInfo (Just InfixL) 4 4) - ] - ), - ("C", [("+", FixityInfo (Just InfixN) 8 8)]) - ] - popularity = - [ ("A", 0), - ("B", 0), - ("C", 11103) - ] - dependencies = [] - higherPriorityPackages = ["B", "C"] - threshold = 0.4 - result = - [ ("+", FixityInfo (Just InfixN) 6 8), - ("-", FixityInfo (Just InfixL) 4 4) - ] - checkFixityMap' - operators - popularity - higherPriorityPackages - dependencies - threshold - result - - it - "whitelists declarations from base even when it is not listed in \ - \cabal dependencies" - $ do - let operators = - [ ( "base", - [ ("+", FixityInfo (Just InfixR) 4 4), - ("-", FixityInfo (Just InfixR) 2 2) - ] - ), - ( "B", - [ ("+", FixityInfo (Just InfixN) 6 6), - ("-", FixityInfo (Just InfixL) 4 4) - ] - ), - ( "C", - [ ("+", FixityInfo (Just InfixN) 8 8), - ("|>", FixityInfo (Just InfixN) 1 1) - ] - ) - ] - popularity = - [ ("base", 0), - ("B", 2), - ("C", 11103) - ] - dependencies = ["B", "C"] - higherPriorityPackages = [] - threshold = 0.4 - result = - [ ("+", FixityInfo (Just InfixR) 4 4), - ("-", FixityInfo (Just InfixR) 2 2), - ("|>", FixityInfo (Just InfixN) 1 1) - ] - checkFixityMap' - operators - popularity - higherPriorityPackages - dependencies - threshold - result - - it - "whitelists declarations from base when base is also listed in cabal \ - \dependencies" - $ do - let operators = - [ ( "base", - [ ("+", FixityInfo (Just InfixR) 4 4), - ("-", FixityInfo (Just InfixR) 2 2) - ] - ), - ( "B", - [ ("+", FixityInfo (Just InfixN) 6 6), - ("?=", FixityInfo (Just InfixL) 4 4) - ] - ), - ( "C", - [ ("<|>", FixityInfo (Just InfixN) 8 8), - ("?=", FixityInfo (Just InfixN) 1 1) - ] - ) - ] - popularity = - [ ("base", 0), - ("B", 2), - ("C", 11103) - ] - dependencies = ["base", "B"] - higherPriorityPackages = [] - threshold = 0.6 - result = - [ ("+", FixityInfo (Just InfixR) 4 4), - ("-", FixityInfo (Just InfixR) 2 2), - ("?=", FixityInfo (Just InfixL) 4 4) - ] - checkFixityMap' - operators - popularity - higherPriorityPackages - dependencies - threshold - result - - it - "gives higher priority to declarations from cabal dependencies than \ - \declarations from both higher-priority & unspecified packages" - $ do - let operators = - [ ( "base", - [ ("+", FixityInfo (Just InfixR) 4 4), - ("-", FixityInfo (Just InfixR) 2 2) - ] - ), - ( "B", - [ ("+", FixityInfo (Just InfixN) 6 6), - ("?=", FixityInfo (Just InfixL) 4 4) - ] - ), - ( "C", - [ ("<|>", FixityInfo (Just InfixN) 8 8), - ("?=", FixityInfo (Just InfixN) 1 1) - ] - ), - ("D", [("+", FixityInfo (Just InfixR) 2 2)]) - ] - popularity = - [ ("base", 0), - ("B", 2), - ("C", 11103) - ] - dependencies = ["base", "B"] - higherPriorityPackages = ["D"] - threshold = 0.6 - result = - [ ("?=", FixityInfo (Just InfixL) 4 4), - ("<|>", FixityInfo (Just InfixN) 8 8) - ] - checkFixityMap' - operators - popularity - higherPriorityPackages - dependencies - threshold - result - - it - "gives higher priority to declarations from higher-priority packages \ - \than declarations from unspecified packages" - $ do - let operators = - [ ( "base", - [ ("+", FixityInfo (Just InfixR) 4 4), - ("-", FixityInfo (Just InfixR) 2 2) - ] - ), - ( "B", - [ ("+", FixityInfo (Just InfixN) 6 6), - ("?=", FixityInfo (Just InfixL) 4 4) - ] - ), - ( "C", - [ ("<|>", FixityInfo (Just InfixN) 8 8), - ("?=", FixityInfo (Just InfixN) 1 1) - ] - ), - ("D", [("+", FixityInfo (Just InfixR) 2 2)]) - ] - popularity = - [ ("base", 0), - ("B", 2), - ("C", 11103) - ] - dependencies = [] - higherPriorityPackages = ["B"] - threshold = 0.6 - result = - [ ("+", FixityInfo (Just InfixR) 4 4), - ("?=", FixityInfo (Just InfixL) 4 4), - ("<|>", FixityInfo (Just InfixN) 8 8) - ] - checkFixityMap' - operators - popularity - higherPriorityPackages - dependencies - threshold - result - - it "gives the correct fixity info for ':' (from base)" $ do - let dependencies = [] - threshold = 0.6 - result = - [ (":", FixityInfo (Just InfixR) 5 5) - ] - checkFixityMap dependencies threshold result - - it - "gives the base's fixity info for '<|>', even when a dependency has a \ - \conflicting declaration for it" - $ do - let dependencies = ["pandoc"] - threshold = 0.9 - result = - [ ("<|>", FixityInfo (Just InfixL) 3 3) - ] - checkFixityMap dependencies threshold result - - it - "gives the containers's fixity info for ':>' (because 'containers' is \ - \a higher-priority package), even though max(pop) < threshold for \ - \this operator)" - $ do - let dependencies = [] - threshold = 0.9 - result = - [ (":>", FixityInfo (Just InfixL) 5 5) - ] - checkFixityMap dependencies threshold result - - it - "gives the servant's fixity info for ':>' once servant is added as a \ - \dependency (although ':>' is also defined in 'containers', a \ - \higher-priority package)" - $ do - let dependencies = ["servant"] - threshold = 0.9 - result = - [ (":>", FixityInfo (Just InfixR) 4 4) - ] - checkFixityMap dependencies threshold result diff --git a/tests/Ormolu/OpTreeSpec.hs b/tests/Ormolu/OpTreeSpec.hs --- a/tests/Ormolu/OpTreeSpec.hs +++ b/tests/Ormolu/OpTreeSpec.hs @@ -3,13 +3,12 @@ module Ormolu.OpTreeSpec (spec) where import Data.Map.Strict qualified as Map -import Data.Maybe (fromJust) import Data.Text (Text) import Data.Text qualified as T import GHC.Types.Name (mkOccName, varName) import GHC.Types.Name.Reader (mkRdrUnqual) import Ormolu.Fixity -import Ormolu.Fixity.Internal (LazyFixityMap (..)) +import Ormolu.Fixity.Internal import Ormolu.Printer.Operators import Test.Hspec @@ -25,20 +24,16 @@ -- | Expected output tree OpTree Text OpName -> Expectation -checkReassociate lFixities inputTree expectedOutputTree = +checkReassociate fixities inputTree expectedOutputTree = removeOpInfo actualOutputTree `shouldBe` expectedOutputTree where removeOpInfo (OpNode x) = OpNode x removeOpInfo (OpBranches exprs ops) = OpBranches (removeOpInfo <$> exprs) (opiOp <$> ops) - actualOutputTree = reassociateOpTree convertName Map.empty fixityMap inputTree - fixityMap = LazyFixityMap [Map.fromList lFixities] + actualOutputTree = reassociateOpTree convertName modFixityMap inputTree + modFixityMap = ModuleFixityMap (Map.map Given (Map.fromList fixities)) convertName = Just . mkRdrUnqual . mkOccName varName . T.unpack . unOpName --- | Associative list of fixities for operators from "base" -baseFixities :: [(OpName, FixityInfo)] -baseFixities = Map.toList . fromJust $ Map.lookup "base" packageToOps - spec :: Spec spec = do it "flattens a tree correctly" $ do @@ -52,7 +47,7 @@ ["+"] outputTree = OpBranches [n "a", n "b", n "c", n "d"] ["+", "+", "+"] - fixities = [("+", FixityInfo (Just InfixL) 5 5)] + fixities = [("+", FixityInfo InfixL 5)] checkReassociate fixities inputTree outputTree it "uses 'minOps' strategy by default" $ do @@ -68,9 +63,9 @@ ] ["+", "-"] fixities = - [ ("+", FixityInfo (Just InfixL) 5 5), - ("*", FixityInfo (Just InfixL) 7 7), - ("-", FixityInfo (Just InfixL) 5 5) + [ ("+", FixityInfo InfixL 5), + ("*", FixityInfo InfixL 7), + ("-", FixityInfo InfixL 5) ] checkReassociate fixities inputTree outputTree @@ -87,9 +82,9 @@ ] ["+", "-"] fixities = - [ ("+", FixityInfo (Just InfixL) 5 7), - ("*", FixityInfo (Just InfixL) 8 8), - ("-", FixityInfo (Just InfixL) 4 6) + [ ("+", FixityInfo InfixL 5), + ("*", FixityInfo InfixL 8), + ("-", FixityInfo InfixL 5) ] checkReassociate fixities inputTree outputTree @@ -110,9 +105,9 @@ ] ["$"] fixities = - [ ("@", FixityInfo (Just InfixL) 0 5), - ("|", FixityInfo (Just InfixL) 4 8), - ("$", FixityInfo (Just InfixR) 0 0) + [ ("@", FixityInfo InfixL 4), + ("|", FixityInfo InfixL 4), + ("$", FixityInfo InfixR 0) ] checkReassociate fixities inputTree outputTree @@ -132,4 +127,9 @@ ["+"] ] ["$", "$"] - checkReassociate baseFixities inputTree outputTree + fixities = + [ ("$", FixityInfo InfixR 0), + ("+", FixityInfo InfixL 6), + ("*", FixityInfo InfixL 7) + ] + checkReassociate fixities inputTree outputTree diff --git a/tests/Ormolu/PrinterSpec.hs b/tests/Ormolu/PrinterSpec.hs --- a/tests/Ormolu/PrinterSpec.hs +++ b/tests/Ormolu/PrinterSpec.hs @@ -8,6 +8,7 @@ import Data.List (isSuffixOf) import Data.Map qualified as Map import Data.Maybe (isJust) +import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T @@ -25,13 +26,15 @@ es <- runIO locateExamples forM_ es checkExample --- | Fixities that are to be used with the test examples. -testsuiteFixities :: FixityMap -testsuiteFixities = - Map.fromList - [ (".=", FixityInfo (Just InfixR) 8 8), - ("#", FixityInfo (Just InfixR) 5 5) - ] +-- | Fixity overrides that are to be used with the test examples. +testsuiteOverrides :: FixityOverrides +testsuiteOverrides = + FixityOverrides + ( Map.fromList + [ (".=", FixityInfo InfixR 8), + ("#", FixityInfo InfixR 5) + ] + ) -- | Check a single given example. checkExample :: Path Rel File -> Spec @@ -41,7 +44,14 @@ config = defaultConfig { cfgSourceType = detectSourceType inputPath, - cfgFixityOverrides = testsuiteFixities + cfgFixityOverrides = testsuiteOverrides, + cfgDependencies = + Set.fromList + [ "base", + "esqueleto", + "lens", + "servant" + ] } expectedOutputPath <- deriveOutput srcPath -- 1. Given input snippet of source code parse it and pretty print it.