diff --git a/CHANGELOG.md b/CHANGELOG.md index 77818e1..a79ad60 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ ## Unreleased +* 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). + * 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 diff --git a/app/Main.hs b/app/Main.hs index 9ab525e..a84af6a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -20,7 +20,7 @@ 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 (FixityInfo, FixityOverrides (..), OpName) import Ormolu.Parser (manualExts) import Ormolu.Terminal import Ormolu.Utils (showOutputable) @@ -282,7 +282,7 @@ configParser = metavar "OPT", help "GHC options to enable (e.g. language extensions)" ] - <*> ( fmap (Map.fromListWith (<>) . mconcat) + <*> ( fmap (FixityOverrides . Map.fromList . mconcat) . many . option parseFixityDeclaration . mconcat diff --git a/data/examples/declaration/type-synonyms/multi-line-out.hs b/data/examples/declaration/type-synonyms/multi-line-out.hs index 919f5ad..777f91c 100644 --- 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 index ad914ad..022c773 100644 --- 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/infix/esqueleto-0-out.hs b/data/examples/declaration/value/function/infix/esqueleto-0-out.hs new file mode 100644 index 0000000..f0a0778 --- /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 index 0000000..d5bb884 --- /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 index 0000000..b21d236 --- /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 index 0000000..d95edfb --- /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 index d1e6dc8..13dc70e 100644 --- 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.Operators + lenses = Just $ M.fromList $ diff --git a/data/examples/declaration/value/function/infix/lenses.hs b/data/examples/declaration/value/function/infix/lenses.hs index 48db339..01078e0 100644 --- 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.Operators + 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 index 0000000..a5b4175 --- /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 index 0000000..62e3f04 --- /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/operators-0-out.hs b/data/examples/declaration/value/function/operators-0-out.hs index a43d1b7..d221252 100644 --- 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 index b77de91..bf636f9 100644 --- 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 index 46b21c6..b8ba48e 100644 --- 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 index 7ce6901..3e4af6c 100644 --- 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 index 625f4b0..ecb92d2 100644 --- 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 index b21890d..8cb7fb6 100644 --- 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 index dab41a8..559b168 100644 --- 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 index e9f76b5..f62959d 100644 --- 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/extract-hackage-info.sh b/extract-hackage-info.sh index 3033336..d33eb7f 100755 --- a/extract-hackage-info.sh +++ b/extract-hackage-info.sh @@ -4,7 +4,6 @@ set -e WDIR=$(mktemp -d) HOOGLE_DATABASE="$WDIR/hoogle-database/" -HACKAGE_DATABASE="$WDIR/hackage-database.html" OUTPUT="$WDIR/hackage-info.bin" trap cleanup 0 1 2 3 15 @@ -16,9 +15,8 @@ cleanup() mkdir "$HOOGLE_DATABASE" curl "https://hackage.haskell.org/packages/hoogle.tar.gz" | tar -xz -C "$HOOGLE_DATABASE" -curl "https://hackage.haskell.org/packages/top" -o "$HACKAGE_DATABASE" -nix run .#extract-hackage-info -- "$HOOGLE_DATABASE" "$HACKAGE_DATABASE" -o "$OUTPUT" +nix run .#extract-hackage-info -- "$HOOGLE_DATABASE" -o "$OUTPUT" cp "$OUTPUT" "extract-hackage-info/hackage-info.bin" diff --git a/extract-hackage-info/README.md b/extract-hackage-info/README.md index bf0b676..79bb108 100644 --- a/extract-hackage-info/README.md +++ b/extract-hackage-info/README.md @@ -34,16 +34,19 @@ only when there is no matching fixity declaration inside the package files that a symbol declaration indicates that the operator has the default fixity (`infixl 9`). -In addition to the extraction of operator fixities, we also scrap the -download count of the last 30 days for every package on Hackage, to get a -popularity metric for packages which will be used to arbitrate between -conflicting fixity declarations. +In general, correct resolution of fixities requires taking into account the +import section of a module that is being formatted, as well as knowing the +provenance (that is, module name) of each operator. Therefore, we also +collect and save this information. The `extract-hackage-info` executable takes care of everything listed above, -and generates a `hackage-info.bin` file containing two associative maps: +and generates a `hackage-info.bin` file containing multi-level map from +package names to module names to operators to their fixities: -+ package name → operator → fixity -+ package name → popularity score +```haskell +newtype HackageInfo + = HackageInfo (Map PackageName (Map ModuleName (Map OpName FixityInfo))) +``` ## How to use `extract-hackage-info` diff --git a/extract-hackage-info/extract-hackage-info.cabal b/extract-hackage-info/extract-hackage-info.cabal index 9c18ec8..4e7d7e1 100644 --- a/extract-hackage-info/extract-hackage-info.cabal +++ b/extract-hackage-info/extract-hackage-info.cabal @@ -7,6 +7,7 @@ author: Thomas Bagrel executable extract-hackage-info main-is: Main.hs hs-source-dirs: src + other-modules: Hoogle default-language: GHC2021 ghc-options: -O2 -Wall -rtsopts -Wunused-packages build-depends: @@ -19,7 +20,6 @@ executable extract-hackage-info filepath >=1.2 && <1.5, optparse-applicative >=0.14 && <0.18, ormolu, - tagsoup >=0.14 && <0.15, text >=2.0 && <3.0, formatting >=7.1 && <7.2, megaparsec >=9.0 diff --git a/extract-hackage-info/hackage-info.bin b/extract-hackage-info/hackage-info.bin index b1a77cd..277c9cc 100644 Binary files a/extract-hackage-info/hackage-info.bin and b/extract-hackage-info/hackage-info.bin differ diff --git a/extract-hackage-info/src/Hoogle.hs b/extract-hackage-info/src/Hoogle.hs new file mode 100644 index 0000000..f4fccf3 --- /dev/null +++ b/extract-hackage-info/src/Hoogle.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Parse Hoogle txt files. +module Hoogle + ( Package (..), + Module (..), + Declaration (..), + parsePackage, + ) +where + +import Control.Monad (void) +import Data.Char (isAlphaNum) +import Data.Foldable (asum) +import Data.Text (Text) +import Data.Void (Void) +import Distribution.ModuleName (ModuleName) +import Distribution.ModuleName qualified as ModuleName +import Distribution.Types.PackageName (PackageName, mkPackageName) +import Ormolu.Fixity +import Ormolu.Fixity.Parser (pFixity, pOperator) +import Text.Megaparsec +import Text.Megaparsec.Char + +type Parser = Parsec Void Text + +-- | Parsed Hoogle package. +data Package = Package + { packageName :: PackageName, + modules :: [Module] + } + deriving (Eq, Show) + +-- | Parsed Hoogle module. +data Module = Module + { hmModuleName :: ModuleName, + hmDeclarations :: [Declaration] + } + deriving (Eq, Show) + +-- | The types of declarations in the Hoogle files we are interested in. +data Declaration + = Symbol OpName + | Fixity OpName FixityInfo + deriving (Eq, Show) + +-- | Parse Hoogle package file. +parsePackage :: + -- | File name + FilePath -> + -- | Text to parse + Text -> + Either (ParseErrorBundle Text Void) Package +parsePackage = parse pPackage + +-- | Parse a package. It starts with the word @\@package@ followed by the +-- name of the package. A package contains zero or more modules. +pPackage :: Parser Package +pPackage = do + void (skipManyTill (pLineWithoutEol <* eol) (string "@package")) + hspace1 + let isPackageNameConstituent x = x == '-' || isAlphaNum x + packageName <- some (satisfy isPackageNameConstituent) "package name" + hspace + void eol + skipManyTill + (pLineWithoutEol <* eol) + (lookAhead (void (string "module ") <|> eof)) + modules <- many pModule + eof + return (Package (mkPackageName packageName) modules) + +-- | Match a module declaration. It starts with the word @module@ followed +-- by one or more spaces and a module identifier. A module contains +-- 'pDeclaration's and any other arbitrary lines. +pModule :: Parser Module +pModule = do + void (string "module") + hspace1 + let isModuleNameConstituent x = + x == '.' || x == '_' || x == '\'' || isAlphaNum x + moduleName <- some (satisfy isModuleNameConstituent) "module name" + hspace + void eol + declarations <- mconcat <$> sepEndBy pDeclaration eol + return (Module (ModuleName.fromString moduleName) declarations) + +-- | Here we are interested in two kinds of declarations: +-- +-- > Symbol declaration, e.g.: +-- > ($) :: (a -> b) -> a -> b +-- > +-- > Fixity declaration, e.g.: +-- > infixr 0 $ +-- +-- We discard everything else while being careful to stop in front of the +-- beginning of a new module. +pDeclaration :: Parser [Declaration] +pDeclaration = + asum + [ fmap (uncurry Fixity) <$> try pFixity, + pure . Symbol <$> try pSymbolDecl, + [] <$ (notFollowedBy (string "module ") *> pLineWithoutEol) + ] + where + pSymbolDecl = do + void (string "(") + r <- pOperator + void (string ") :: ") + r <$ pLineWithoutEol + +pLineWithoutEol :: Parser () +pLineWithoutEol = void (takeWhileP Nothing (/= '\n')) diff --git a/extract-hackage-info/src/Main.hs b/extract-hackage-info/src/Main.hs index e1e52a8..6f666d0 100644 --- a/extract-hackage-info/src/Main.hs +++ b/extract-hackage-info/src/Main.hs @@ -8,74 +8,39 @@ module Main (main) where import Control.Exception import Control.Monad -import Control.Monad.IO.Class (liftIO) import Data.Binary qualified as Binary import Data.Binary.Put qualified as Binary import Data.ByteString qualified as ByteString import Data.ByteString.Lazy qualified as BL import Data.List -import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe -import Data.Semigroup (sconcat) -import Data.Set qualified as Set import Data.Text (Text) -import Data.Text qualified as T import Data.Text.Encoding (decodeLatin1) import Data.Text.IO qualified as TIO -import Data.Void (Void) -import Distribution.Types.PackageName (PackageName, mkPackageName, unPackageName) +import Distribution.ModuleName (ModuleName) +import Distribution.Types.PackageName (PackageName) import Formatting +import Hoogle qualified import Options.Applicative -import Ormolu.Fixity hiding (packageToOps, packageToPopularity) -import Ormolu.Fixity.Parser +import Ormolu.Fixity import System.Directory (doesDirectoryExist, listDirectory) import System.Exit (ExitCode (ExitFailure), exitWith) -import System.FilePath (makeRelative, splitPath, ()) -import System.IO (stderr, stdout) -import Text.HTML.TagSoup (Tag (TagText), parseTags) -import Text.HTML.TagSoup.Match (tagCloseLit, tagOpenLit) -import Text.Megaparsec qualified as MP -import Text.Megaparsec.Char qualified as MP +import System.FilePath (()) +import System.IO (hPutStrLn, stderr, stdout) +import Text.Megaparsec.Error (errorBundlePretty) defaultOutputPath :: FilePath -defaultOutputPath = "extract-hackage-info/hackage-info.bin" - --- | This fixity info is used when we find an operator declaration in a --- package, but no matching fixity declaration. -unspecifiedFixityInfo :: FixityInfo -unspecifiedFixityInfo = FixityInfo (Just InfixL) 9 9 +defaultOutputPath = "hackage-info.bin" -- | Contains the database being constructed during the processing of Hoogle -- files. -data State = State - { -- | packageName -map-> (operatorName -map-> fixityDefinitions) - -- we keep a list of fixity definitions for each pair - -- (packageName, operatorName) because sometimes a package itself has - -- conflicting fixity declarations for a same operator - -- (called self-conflicts), and we want to emit a warning message later - -- for these - sPackageToOps :: Map PackageName (Map OpName [FixityInfo]), - -- | How many Hoogle files have been processed - sProcessedFiles :: Int +newtype State = State + { -- | Hackage info + sHackageInfo :: Map PackageName (Map ModuleName (Map OpName [FixityInfo])) } - deriving (Eq) - --- | Exit with an error message. -exitWithMsg :: Text -> IO () -exitWithMsg t = do - TIO.hPutStrLn stderr t - exitWith (ExitFailure 1) - -showT :: (Show a) => a -> Text -showT = T.pack . show - -readT :: (Read a) => Text -> a -readT = read . T.unpack - -indentLines :: [Text] -> [Text] -indentLines = fmap (" " <>) + deriving (Eq, Show) -- | Recursively list all files inside directory. walkDir :: @@ -91,33 +56,8 @@ walkDir top = do False -> return [path] return (concat paths) --- | Extract the package name from a path to a Hoogle file. -getPackageName :: - -- | Path to the Hoogle directory containing all package directories - FilePath -> - -- | Path to the Hoogle file - FilePath -> - -- | Package name extracted from the Hoogle file - IO PackageName -getPackageName rootPath filePath = do - unless (rootPath `isPrefixOf` filePath) $ - exitWithMsg $ - sformat (string % " does not start with " % string) rootPath filePath - let packageName = - stripSuffix' "/" $ - T.pack . head . splitPath $ - makeRelative rootPath filePath - stripSuffix' suffix txt = fromMaybe txt $ T.stripSuffix suffix txt - when (T.null packageName) $ - exitWithMsg $ - sformat - ("Extracted package name is empty for " % string % " (base path = " % string % ")") - filePath - rootPath - pure . mkPackageName . T.unpack $ packageName - --- | Try to read the specified file using utf-8 encoding first, --- and latin1 otherwise. +-- | Try to read the specified file using utf-8 encoding first, and latin1 +-- otherwise. readFileUtf8Latin1 :: FilePath -> IO Text readFileUtf8Latin1 filePath = catch @IOException (TIO.readFile filePath) $ \e -> do @@ -128,269 +68,115 @@ readFileUtf8Latin1 filePath = catch @IOException (TIO.readFile filePath) $ e decodeLatin1 <$> ByteString.readFile filePath --- | When a symbol declaration is encountered, --- e.g. @(+) :: Num a => a -> a -> a@, update the fixity map accordingly. -onSymbolDecl :: - -- | Name of the package in which the symbol declaration was found - PackageName -> - -- | Symbol name extracted from the symbol declaration in the Hoogle file - OpName -> - -- | Current state - State -> - -- | Updated state - State -onSymbolDecl packageName declOpName state@State {..} = - let sPackageToOps' = case Map.lookup packageName sPackageToOps of - Nothing -> - Map.insert - packageName - (Map.singleton declOpName []) - sPackageToOps - Just packageFixityMap -> - case Map.lookup declOpName packageFixityMap of - Nothing -> - Map.insert - packageName - (Map.insert declOpName [] packageFixityMap) - sPackageToOps - Just _ -> sPackageToOps - in state {sPackageToOps = sPackageToOps'} - --- | When a fixity declaration is encountered, e.g. @infixr 5 :@, update the --- fixity map accordingly. -onFixityDecl :: - -- | Name of the package in which the symbol declaration was found - PackageName -> - -- | Tuple of operator name and fixity info - (OpName, FixityInfo) -> - -- | Current state - State -> - -- | Updated state - State -onFixityDecl packageName (opName, fixDecl) state@State {..} = - let sPackageToOps' = case Map.lookup packageName sPackageToOps of - Nothing -> - Map.insert - packageName - (Map.singleton opName [fixDecl]) - sPackageToOps - Just packageFixityMap -> - case fromMaybe [] $ Map.lookup opName packageFixityMap of - fixDecls - | fixDecl `elem` fixDecls -> - sPackageToOps - fixDecls -> - Map.insert - packageName - ( Map.insert - opName - (fixDecl : fixDecls) - packageFixityMap - ) - sPackageToOps - in state {sPackageToOps = sPackageToOps'} - --- | Represent an operator for which we found conflicting definitions --- originating from the same package. -data SelfConflict = SelfConflict - { scPackageName :: PackageName, - scOperatorName :: OpName, - scConflictingDefs :: [FixityInfo] - } - --- | From a map allowing self conflicts, build the final map --- packageName -map-> (operatorName -map-> fixityInfo) --- (where conflicting definitions from self-conflicts are merged), and also --- return the list of self-conflicts -finalizePackageToOps :: - Map PackageName (Map OpName [FixityInfo]) -> - (Map PackageName (Map OpName FixityInfo), [SelfConflict]) -finalizePackageToOps hashmap = - ( Map.map (Map.map finalize) hashmap, - concatMap injectFst - . Map.toList - . Map.map (Map.toList . Map.filter hasConflict) - $ hashmap - ) - where - finalize = \case - [] -> unspecifiedFixityInfo - fs -> sconcat . NE.fromList $ fs - hasConflict = (> 1) . length - injectFst (packageName, opFixs) = - uncurry (SelfConflict packageName) <$> opFixs - -- | Scrap all fixity data from a Hoogle file, and update the state -- accordingly. extractFixitiesFromFile :: - -- | Path to the Hoogle directory containing all package directories - FilePath -> -- | Previous state State -> -- | Path of the Hoogle file to process FilePath -> -- | Updated state IO State -extractFixitiesFromFile - hoogleDatabasePath - state@State {sProcessedFiles} - filePath = do - fileContent <- liftIO . readFileUtf8Latin1 $ filePath - packageName <- liftIO $ getPackageName hoogleDatabasePath filePath - let onDecl (SymbolDecl opName) = onSymbolDecl packageName opName - onDecl (FixityDecl opInfo) = onFixityDecl packageName opInfo - state' = foldl' (flip onDecl) state $ parseDecls fileContent - return state' {sProcessedFiles = sProcessedFiles + 1} +extractFixitiesFromFile state filePath = do + fileContent <- readFileUtf8Latin1 filePath + case Hoogle.parsePackage filePath fileContent of + Left errorBundle -> do + hPutStrLn stderr (errorBundlePretty errorBundle) + exitWith (ExitFailure 1) + Right (Hoogle.Package packageName modules) -> + return $ + let handleModule st (Hoogle.Module moduleName decls) = + let onDecl = \case + Hoogle.Symbol opName -> + registerOp packageName moduleName opName Nothing + Hoogle.Fixity opName fixityInfo -> + registerOp packageName moduleName opName (Just fixityInfo) + in foldl' (flip onDecl) st decls + in foldl' handleModule state modules --- | The types of declarations in the Hoogle files we are interested in. -data DeclType - = -- | See third argument of 'onSymbolDecl'. - SymbolDecl OpName - | -- | See third argument of 'onFixityDecl'. - FixityDecl (OpName, FixityInfo) +-- | Add fixity info for an operator. +registerOp :: + -- | Name of the package in which the symbol declaration was found + PackageName -> + -- | Name of the module in which the symbol declaration was found + ModuleName -> + -- | Symbol name extracted from the symbol declaration in the Hoogle file + OpName -> + -- | Fixity info, if available + Maybe FixityInfo -> + -- | Current state + State -> + -- | Updated state + State +registerOp packageName moduleName opName fixityInfo state@State {..} = + let fixityInfoList = maybeToList fixityInfo + sHackageInfo' = Map.alter alterPackage packageName sHackageInfo + alterPackage = \case + Nothing -> + Just (Map.singleton moduleName (Map.singleton opName fixityInfoList)) + Just pkg -> Just (Map.alter alterModule moduleName pkg) + alterModule = \case + Nothing -> Just (Map.singleton opName fixityInfoList) + Just mdl -> Just (Map.alter alterOp opName mdl) + alterOp = \case + Nothing -> Just fixityInfoList + Just finfos -> Just (fixityInfoList ++ finfos) + in state {sHackageInfo = sHackageInfo'} --- | Parse all 'DeclType's in some file content. -parseDecls :: Text -> [DeclType] -parseDecls = either mempty id . MP.runParser pDecls "" +-- | Build the final operator map. +finalizePackageToOps :: + Map PackageName (Map ModuleName (Map OpName [FixityInfo])) -> + Map PackageName (Map ModuleName (Map OpName FixityInfo)) +finalizePackageToOps = Map.map (Map.map (Map.map finalize)) where - pDecls = mconcat <$> pDecl `MP.sepEndBy` MP.newline - pDecl :: MP.Parsec Void Text [DeclType] - pDecl = - asum - [ fmap FixityDecl <$> MP.try pFixity, - pure . SymbolDecl <$> MP.try pSymbolDecl, - [] <$ pRemainingLine - ] - where - pRemainingLine = MP.takeWhileP Nothing (/= '\n') - pSymbolDecl = - MP.char '(' *> pOperator <* MP.chunk ") :: " <* pRemainingLine + finalize = \case + [] -> defaultFixityInfo + -- In some very rare and exceptional cases there seem to be multiple + -- conflicting fixity definitions. I think it is acceptable to be + -- somewhat arbitrary in that case. + (x : _) -> x -- | Process the whole Hoogle database and return a map associating each -- package name to its fixity map. extractHoogleInfo :: - -- | Path to the hoogle directory containing all package directories + -- | Path to the Hoogle directory containing all package directories FilePath -> - IO (Map PackageName FixityMap) + IO (Map PackageName (Map ModuleName (Map OpName FixityInfo))) extractHoogleInfo hoogleDatabasePath = do hoogleFiles <- walkDir hoogleDatabasePath State {..} <- foldM - (extractFixitiesFromFile hoogleDatabasePath) - (State {sPackageToOps = Map.empty, sProcessedFiles = 0}) + extractFixitiesFromFile + (State Map.empty) hoogleFiles - hprintLn - stdout - (int % " Hoogle files processed!") - sProcessedFiles - let (packageToOps, selfConflicts) = finalizePackageToOps sPackageToOps - displayFixityStats packageToOps - displaySelfConflicts selfConflicts - return packageToOps - --- | Warn the user about self-conflicts. -displaySelfConflicts :: [SelfConflict] -> IO () -displaySelfConflicts selfConflicts = - unless (null selfConflicts) $ do - hprintLn - stdout - ("Found " % int % " conflicting declarations within packages themselves:") - (length selfConflicts) - TIO.putStrLn $ T.intercalate "\n" selfConflictLines - where - selfConflictLines = concat $ showSc <$> sortedSelfConflicts - sortedSelfConflicts = - sortBy - ( \(SelfConflict p1 o1 _) (SelfConflict p2 o2 _) -> - compare (p1, o1) (p2, o2) - ) - selfConflicts - showSc SelfConflict {scPackageName, scOperatorName, scConflictingDefs} = - sformat - ("(in " % string % ") " % string) - (unPackageName scPackageName) - (T.unpack $ unOpName scOperatorName) - : indentLines (showT <$> scConflictingDefs) + let sHackageInfoFinalized = finalizePackageToOps sHackageInfo + displayFixityStats sHackageInfoFinalized + return sHackageInfoFinalized -- | Display stats about the Hoogle database processing. -displayFixityStats :: Map PackageName FixityMap -> IO () -displayFixityStats packageToOps = +displayFixityStats :: + Map PackageName (Map ModuleName (Map OpName FixityInfo)) -> + IO () +displayFixityStats packages = hprintLn stdout ( "Found " % int % " operator declarations across " % int - % " packages for a total of " - % int - % " distinct operators" + % " packages" ) - declCount - packagesCount - distinctOpCount + declarationCount + packageCount where - packagesCount = Map.size packageToOps - declCount = sum $ Map.size <$> fixityMaps - distinctOpCount = - Set.size . Set.fromList . concat $ - Map.keys <$> fixityMaps - fixityMaps = Map.elems packageToOps - --- | Extract package download counts from the hackage HTML page. -extractHackageInfo :: - -- | Path to the Hackage HTML page - FilePath -> - -- | Map packageName -> download count - IO (Map PackageName Int) -extractHackageInfo filePath = do - content <- TIO.readFile filePath - let soup = filterBlankTags $ parseTags content - tableBody = - drop 7 $ - takeWhile (not . tagCloseLit "table") $ - dropWhile (not . tagOpenLit "table" (const True)) soup - processRow tags = case extractText <$> groupOn "td" tags of - rawName : rawDlCount : _ -> return $ Just (mkPackageName name, dlCount) - where - name = T.unpack . T.strip . head $ T.split (== ' ') rawName - dlCount = readT $ T.strip rawDlCount :: Int - _ -> do - hprintLn - stdout - ("Invalid line: " % stext) - (T.intercalate " " $ showT <$> tags) - return Nothing - extractText tags = T.intercalate "" $ extractText' <$> tags - extractText' = \case - TagText t -> t - _ -> "" - groupOn _ [] = [] - groupOn selector (_ : ts) = - let (tags, remTags) = break (tagOpenLit selector (const True)) ts - in init tags : groupOn selector remTags - filterBlankTags = - filter - ( \case - TagText t | isBlank t -> False - _ -> True - ) - isBlank t = null $ dropWhile (`elem` [' ', '\t', '\n']) (T.unpack t) - result <- Map.fromList . catMaybes <$> traverse processRow (groupOn "tr" tableBody) - hprintLn - stdout - ("Found popularity information for " % int % " packages") - (Map.size result) - return result - --- | Limit the number of items in a map. -limitMap :: (Ord k) => Int -> Map k v -> Map k v -limitMap n = Map.fromList . take n . Map.toList + packageCount = Map.size packages + modulesPerPackage = Map.elems packages + declarationsPerModule = concatMap Map.elems modulesPerPackage + declarationCount = sum (Map.size <$> declarationsPerModule) data Config = Config { cfgHoogleDatabasePath :: FilePath, - cfgHackageDatabasePath :: FilePath, - cfgOutputPath :: FilePath, - cfgDebugLimit :: Maybe Int + cfgOutputPath :: FilePath } deriving (Eq, Show) @@ -407,35 +193,16 @@ configParserInfo = info (helper <*> configParser) fullDesc \curl https://hackage.haskell.org/packages/hoogle.tar.gz | \ \tar -xz -C hoogle-database" ] - <*> (strArgument . mconcat) - [ metavar "HACKAGE_DATABASE_PATH", - help - "Download: curl https://hackage.haskell.org/packages/browse \ - \ -o hackage-database.html" - ] <*> (strOption . mconcat) [ short 'o', long "output-path", metavar "OUTPUT_PATH", value defaultOutputPath ] - <*> (option (Just <$> auto) . mconcat) - [ short 'd', - long "debug-limit", - metavar "N", - value Nothing - ] main :: IO () main = do Config {..} <- execParser configParserInfo - packageToOps <- extractHoogleInfo cfgHoogleDatabasePath - packageToPop <- extractHackageInfo cfgHackageDatabasePath - let (packageToOps', packageToPop') = case cfgDebugLimit of - Nothing -> (packageToOps, packageToPop) - Just n -> - ( limitMap n <$> limitMap n packageToOps, - limitMap n packageToPop - ) + hackageInfo' <- extractHoogleInfo cfgHoogleDatabasePath BL.writeFile cfgOutputPath . Binary.runPut . Binary.put $ - HackageInfo packageToOps' packageToPop' + HackageInfo hackageInfo' diff --git a/fixity-tests/.ormolu b/fixity-tests/.ormolu index 7299a3b..04a1f76 100644 --- a/fixity-tests/.ormolu +++ b/fixity-tests/.ormolu @@ -1,2 +1,2 @@ infixr 8 .= -infixr 5 # +infixr 5 #, :> diff --git a/fixity-tests/default.nix b/fixity-tests/default.nix index 6d7b20e..19226b5 100644 --- a/fixity-tests/default.nix +++ b/fixity-tests/default.nix @@ -13,15 +13,17 @@ cp test-0-input.hs test-0-no-extra-info.hs ormolu --check-idempotence --mode inplace --no-cabal test-0-no-extra-info.hs cp test-0-input.hs test-0-with-fixity-info-manual.hs - ormolu --check-idempotence --mode inplace --no-cabal --fixity 'infixr 8 .=' test-0-with-fixity-info-manual.hs + ormolu --check-idempotence --mode inplace --no-cabal --fixity 'infixr 8 .=' --fixity 'infixr 5 :>' test-0-with-fixity-info-manual.hs cp test-0-input.hs test-0-with-fixity-info-dotormolu.hs - ormolu --check-idempotence --mode inplace test-0-with-fixity-info-dotormolu.hs + ormolu --check-idempotence --mode inplace -p base test-0-with-fixity-info-dotormolu.hs cp test-1-input.hs test-1-no-extra-info.hs ormolu --check-idempotence --mode inplace --no-cabal test-1-no-extra-info.hs cp test-1-input.hs test-1-with-fixity-info-manual.hs ormolu --check-idempotence --mode inplace --no-cabal --fixity 'infixr 8 .=' --fixity 'infixr 5 #' test-1-with-fixity-info-manual.hs cp test-1-input.hs test-1-with-fixity-info-dotormolu.hs - ormolu --check-idempotence --mode inplace test-1-with-fixity-info-dotormolu.hs + ormolu --check-idempotence --mode inplace -p base test-1-with-fixity-info-dotormolu.hs + cp test-1-input.hs test-1-with-fixity-info-weird-overwrite.hs + ormolu --check-idempotence --mode inplace -p base --fixity "infixr 5 $" test-1-with-fixity-info-weird-overwrite.hs ''; checkPhase = '' echo test-0-no-extra-info.hs @@ -36,6 +38,8 @@ diff --color=always test-1-with-fixity-info-expected.hs test-1-with-fixity-info-manual.hs echo test-1-with-fixity-info-dotormolu.hs diff --color=always test-1-with-fixity-info-expected.hs test-1-with-fixity-info-dotormolu.hs + echo test-1-with-fixity-info-weird-overwrite.hs + diff --color=always test-1-with-fixity-info-weird-overwrite-expected.hs test-1-with-fixity-info-weird-overwrite.hs ''; installPhase = '' mkdir "$out" diff --git a/fixity-tests/test-0-input.hs b/fixity-tests/test-0-input.hs index c6d5dfe..a01573d 100644 --- a/fixity-tests/test-0-input.hs +++ b/fixity-tests/test-0-input.hs @@ -1,7 +1,7 @@ instance A.ToJSON UpdateTable where toJSON a = A.object $ "TableName" .= updateTableName a - : "ProvisionedThroughput" .= updateProvisionedThroughput a - : case updateGlobalSecondaryIndexUpdates a of + :> "ProvisionedThroughput" .= updateProvisionedThroughput a + :> case updateGlobalSecondaryIndexUpdates a of [] -> [] l -> [ "GlobalSecondaryIndexUpdates" .= l ] diff --git a/fixity-tests/test-0-no-extra-info-expected.hs b/fixity-tests/test-0-no-extra-info-expected.hs index 838ecd7..c262974 100644 --- a/fixity-tests/test-0-no-extra-info-expected.hs +++ b/fixity-tests/test-0-no-extra-info-expected.hs @@ -3,8 +3,8 @@ instance A.ToJSON UpdateTable where A.object $ "TableName" .= updateTableName a - : "ProvisionedThroughput" + :> "ProvisionedThroughput" .= updateProvisionedThroughput a - : case updateGlobalSecondaryIndexUpdates a of + :> case updateGlobalSecondaryIndexUpdates a of [] -> [] l -> ["GlobalSecondaryIndexUpdates" .= l] diff --git a/fixity-tests/test-0-with-fixity-info-expected.hs b/fixity-tests/test-0-with-fixity-info-expected.hs index b3fec19..a40aaee 100644 --- a/fixity-tests/test-0-with-fixity-info-expected.hs +++ b/fixity-tests/test-0-with-fixity-info-expected.hs @@ -2,7 +2,7 @@ instance A.ToJSON UpdateTable where toJSON a = A.object $ "TableName" .= updateTableName a - : "ProvisionedThroughput" .= updateProvisionedThroughput a - : case updateGlobalSecondaryIndexUpdates a of + :> "ProvisionedThroughput" .= updateProvisionedThroughput a + :> case updateGlobalSecondaryIndexUpdates a of [] -> [] l -> ["GlobalSecondaryIndexUpdates" .= l] diff --git a/fixity-tests/test-1-with-fixity-info-weird-overwrite-expected.hs b/fixity-tests/test-1-with-fixity-info-weird-overwrite-expected.hs new file mode 100644 index 0000000..6a1b3be --- /dev/null +++ b/fixity-tests/test-1-with-fixity-info-weird-overwrite-expected.hs @@ -0,0 +1,9 @@ +lenses = + Just + $ M.fromList + $ "type" .= ("user.connection" :: Text) + # "connection" .= uc + # "user" .= case name of + Just n -> Just $ object ["name" .= n] + Nothing -> Nothing + # [] diff --git a/ormolu-live/app/Main.hs b/ormolu-live/app/Main.hs index 7c110cd..afa2b35 100644 --- a/ormolu-live/app/Main.hs +++ b/ormolu-live/app/Main.hs @@ -24,7 +24,6 @@ import Ormolu import Ormolu.Config qualified as O import Ormolu.Exception qualified as O import Ormolu.Fixity qualified as O -import Ormolu.Fixity.Internal qualified as O import Ormolu.Parser qualified as O import Ormolu.Parser.Result as O import Ormolu.Terminal qualified as O @@ -56,7 +55,7 @@ foreign export ccall evaluateFixityInfo :: IO () evaluateFixityInfo :: IO () evaluateFixityInfo = - void . E.evaluate $ force (O.packageToOps, O.packageToPopularity) + void . E.evaluate $ force O.hackageInfo -- actual logic @@ -97,8 +96,9 @@ format Input {..} = do prettyAST :: Config RegionIndices -> Text -> IO Text prettyAST cfg src = do + let pfixityMap = O.packageFixityMap O.defaultDependencies (_, eSnippets) <- - O.parseModule cfgWithDeltas (O.LazyFixityMap []) "" src + O.parseModule cfgWithDeltas pfixityMap "" src pure case eSnippets of Left e -> T.pack $ show e Right snippets -> T.unlines $ showSnippet <$> snippets diff --git a/ormolu.cabal b/ormolu.cabal index 379f3b6..2e66179 100644 --- a/ormolu.cabal +++ b/ormolu.cabal @@ -78,6 +78,7 @@ library Ormolu.Printer.Meat.Type Ormolu.Printer.Operators Ormolu.Fixity + Ormolu.Fixity.Imports Ormolu.Fixity.Internal Ormolu.Fixity.Parser Ormolu.Fixity.Printer @@ -161,7 +162,7 @@ test-suite tests Ormolu.Diff.TextSpec Ormolu.Fixity.ParserSpec Ormolu.Fixity.PrinterSpec - Ormolu.HackageInfoSpec + Ormolu.FixitySpec Ormolu.OpTreeSpec Ormolu.Parser.OptionsSpec Ormolu.Parser.ParseFailureSpec @@ -179,6 +180,7 @@ test-suite tests 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/region-tests/default.nix b/region-tests/default.nix index 54b9961..fe04d0f 100644 --- a/region-tests/default.nix +++ b/region-tests/default.nix @@ -13,19 +13,19 @@ cp src.hs result-all-implicit.hs ormolu --check-idempotence --mode inplace result-all-implicit.hs cp src.hs result-all-explicit.hs - ormolu --check-idempotence --mode inplace --start-line 1 --end-line 18 result-all-explicit.hs + ormolu --check-idempotence --mode inplace --start-line 1 --end-line 23 result-all-explicit.hs cp src.hs result-only-start.hs ormolu --check-idempotence --mode inplace --start-line 1 result-only-start.hs cp src.hs result-only-end.hs - ormolu --check-idempotence --mode inplace --end-line 18 result-only-end.hs - cp src.hs result-6-7.hs - ormolu --check-idempotence --mode inplace --start-line 6 --end-line 7 result-6-7.hs - cp src.hs result-6-8.hs - ormolu --check-idempotence --mode inplace --start-line 6 --end-line 8 result-6-8.hs - cp src.hs result-9-12.hs - ormolu --check-idempotence --mode inplace --start-line 9 --end-line 12 result-9-12.hs - cp src.hs result-17-18.hs - ormolu --check-idempotence --mode inplace --start-line 17 --end-line 18 result-17-18.hs + ormolu --check-idempotence --mode inplace --end-line 23 result-only-end.hs + cp src.hs result-8-9.hs + ormolu --check-idempotence --mode inplace --start-line 8 --end-line 9 result-8-9.hs + cp src.hs result-8-10.hs + ormolu --check-idempotence --mode inplace --start-line 8 --end-line 10 result-8-10.hs + cp src.hs result-11-14.hs + ormolu --check-idempotence --mode inplace --start-line 11 --end-line 14 result-11-14.hs + cp src.hs result-19-23.hs + ormolu --check-idempotence --mode inplace --start-line 19 --end-line 23 result-19-23.hs ''; checkPhase = '' echo result-all-implicit.hs @@ -36,14 +36,14 @@ diff --color=always expected-result-all.hs result-only-start.hs echo result-only-end.hs diff --color=always expected-result-all.hs result-only-end.hs - echo result-6-7.hs - diff --color=always expected-result-6-7.hs result-6-7.hs - echo result-6-8.hs - diff --color=always expected-result-6-8.hs result-6-8.hs - echo result-9-12.hs - diff --color=always expected-result-9-12.hs result-9-12.hs - echo result-17-18.hs - diff --color=always expected-result-17-18.hs result-17-18.hs + echo result-8-9.hs + diff --color=always expected-result-8-9.hs result-8-9.hs + echo result-8-10.hs + diff --color=always expected-result-8-10.hs result-8-10.hs + echo result-11-14.hs + diff --color=always expected-result-11-14.hs result-11-14.hs + echo result-19-23.hs + diff --color=always expected-result-19-23.hs result-19-23.hs ''; installPhase = '' mkdir "$out" diff --git a/region-tests/expected-result-9-12.hs b/region-tests/expected-result-11-14.hs similarity index 67% rename from region-tests/expected-result-9-12.hs rename to region-tests/expected-result-11-14.hs index ad791d8..f6c9710 100644 --- a/region-tests/expected-result-9-12.hs +++ b/region-tests/expected-result-11-14.hs @@ -3,6 +3,8 @@ module Foo ( foo, bar, baz) where +import Control.Category + foo :: Int foo = 5 @@ -14,4 +16,7 @@ bar = \case baz :: Int -> Int baz = gege where - gege = 1 + 2 + gege = 1 + >>> zeze + + 2 + >>> nona diff --git a/region-tests/expected-result-17-18.hs b/region-tests/expected-result-19-23.hs similarity index 68% rename from region-tests/expected-result-17-18.hs rename to region-tests/expected-result-19-23.hs index a07a660..3297acf 100644 --- a/region-tests/expected-result-17-18.hs +++ b/region-tests/expected-result-19-23.hs @@ -3,6 +3,8 @@ module Foo ( foo, bar, baz) where +import Control.Category + foo :: Int foo = 5 @@ -14,4 +16,8 @@ bar = \case baz :: Int -> Int baz = gege where - gege = 1 + 2 + gege = + 1 + >>> zeze + + 2 + >>> nona diff --git a/region-tests/expected-result-6-7.hs b/region-tests/expected-result-8-10.hs similarity index 68% rename from region-tests/expected-result-6-7.hs rename to region-tests/expected-result-8-10.hs index 13b09b2..147655b 100644 --- a/region-tests/expected-result-6-7.hs +++ b/region-tests/expected-result-8-10.hs @@ -3,6 +3,8 @@ module Foo ( foo, bar, baz) where +import Control.Category + foo :: Int foo = 5 @@ -14,4 +16,7 @@ bar = \case baz :: Int -> Int baz = gege where - gege = 1 + 2 + gege = 1 + >>> zeze + + 2 + >>> nona diff --git a/region-tests/expected-result-6-8.hs b/region-tests/expected-result-8-9.hs similarity index 68% rename from region-tests/expected-result-6-8.hs rename to region-tests/expected-result-8-9.hs index 13b09b2..147655b 100644 --- a/region-tests/expected-result-6-8.hs +++ b/region-tests/expected-result-8-9.hs @@ -3,6 +3,8 @@ module Foo ( foo, bar, baz) where +import Control.Category + foo :: Int foo = 5 @@ -14,4 +16,7 @@ bar = \case baz :: Int -> Int baz = gege where - gege = 1 + 2 + gege = 1 + >>> zeze + + 2 + >>> nona diff --git a/region-tests/expected-result-all.hs b/region-tests/expected-result-all.hs index 65b2f01..e8a60b4 100644 --- a/region-tests/expected-result-all.hs +++ b/region-tests/expected-result-all.hs @@ -7,6 +7,8 @@ module Foo ) where +import Control.Category + foo :: Int foo = 5 @@ -18,4 +20,8 @@ bar = \case baz :: Int -> Int baz = gege where - gege = 1 + 2 + gege = + 1 + >>> zeze + + 2 + >>> nona diff --git a/region-tests/src.hs b/region-tests/src.hs index 99730ff..059f4f8 100644 --- a/region-tests/src.hs +++ b/region-tests/src.hs @@ -3,6 +3,8 @@ module Foo ( foo, bar, baz) where +import Control.Category + foo :: Int foo = 5 @@ -14,4 +16,7 @@ bar = \case baz :: Int -> Int baz = gege where - gege = 1 + 2 + gege = 1 + >>> zeze + + 2 + >>> nona diff --git a/src/Ormolu.hs b/src/Ormolu.hs index 616ad1f..9a1dec2 100644 --- a/src/Ormolu.hs +++ b/src/Ormolu.hs @@ -25,7 +25,7 @@ module Ormolu CabalUtils.getCabalInfoForSourceFile, -- * Fixity overrides - FixityMap, + FixityOverrides, getFixityOverridesForSourceFile, -- * Working with exceptions @@ -38,6 +38,7 @@ import Control.Exception import Control.Monad import Control.Monad.IO.Class (MonadIO (..)) import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T @@ -85,11 +86,7 @@ ormolu cfgWithIndices path originalInput = do 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,7 +177,7 @@ refineConfig :: -- | Cabal info for the file, if available Maybe CabalUtils.CabalInfo -> -- | Fixity overrides, if available - Maybe FixityMap -> + Maybe FixityOverrides -> -- | 'Config' to refine Config region -> -- | Refined 'Config' @@ -189,23 +186,25 @@ refineConfig sourceType mcabalInfo mfixityOverrides rawConfig = rawConfig { cfgDynOptions = cfgDynOptions rawConfig ++ dynOptsFromCabal, cfgFixityOverrides = - Map.unionWith (<>) (cfgFixityOverrides rawConfig) fixityOverrides, + FixityOverrides $ + Map.union + (unFixityOverrides fixityOverrides) + (unFixityOverrides (cfgFixityOverrides rawConfig)), cfgDependencies = Set.union (cfgDependencies rawConfig) depsFromCabal, cfgSourceType = sourceType } where - fixityOverrides = - case mfixityOverrides of - Nothing -> Map.empty - Just x -> x + fixityOverrides = fromMaybe (FixityOverrides Map.empty) mfixityOverrides (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 +216,7 @@ parseModule' :: -- | 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 index be7250f..e85699c 100644 --- a/src/Ormolu/Config.hs +++ b/src/Ormolu/Config.hs @@ -20,7 +20,7 @@ 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 (FixityOverrides (..)) import Ormolu.Terminal (ColorMode (..)) -- | Type of sources that can be formatted by Ormolu. @@ -36,7 +36,7 @@ data Config region = Config { -- | Dynamic options to pass to GHC parser cfgDynOptions :: ![DynOption], -- | Fixity overrides - cfgFixityOverrides :: FixityMap, + cfgFixityOverrides :: FixityOverrides, -- | Known dependencies, if any cfgDependencies :: !(Set PackageName), -- | Do formatting faster but without automatic detection of defects @@ -78,7 +78,7 @@ defaultConfig :: Config RegionIndices defaultConfig = Config { cfgDynOptions = [], - cfgFixityOverrides = Map.empty, + cfgFixityOverrides = FixityOverrides Map.empty, cfgDependencies = Set.empty, cfgUnsafe = False, cfgDebug = False, diff --git a/src/Ormolu/Fixity.hs b/src/Ormolu/Fixity.hs index 3bfc1e5..c1a3e9a 100644 --- 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,36 @@ module Ormolu.Fixity occOpName, FixityDirection (..), FixityInfo (..), - FixityMap, - LazyFixityMap, - lookupFixity, - HackageInfo (..), - defaultStrategyThreshold, defaultFixityInfo, - buildFixityMap, - buildFixityMap', - bootPackages, - packageToOps, - packageToPopularity, + FixityApproximation (..), + defaultFixityApproximation, + FixityOverrides (..), + 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 +50,131 @@ import qualified Data.ByteString as B 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" - ] +-- | 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") --- | 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 +-- | Compute the fixity map that is specific to the package we are formatting. +packageFixityMap :: + -- | Set of packages to select + Set PackageName -> + -- | 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. -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 +-- | 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 = buildFixityMap' packageToOps packageToPopularity bootPackages + -- | 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) --- | 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 - 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 - ] +-- | 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 + 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 = + fimportModuleName == 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 - --- | 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 - 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) +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 index 0000000..5d56803 --- /dev/null +++ b/src/Ormolu/Fixity/Imports.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Simplified representation of the import list for the purposes of fixity +-- inference. +module Ormolu.Fixity.Imports + ( FixityImport (..), + extractFixityImports, + ) +where + +import Data.Bifunctor (second) +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), + fimportModuleName :: !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, + fimportModuleName = 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 + _ -> [] diff --git a/src/Ormolu/Fixity/Internal.hs b/src/Ormolu/Fixity/Internal.hs index f14b4d2..c184ee7 100644 --- a/src/Ormolu/Fixity/Internal.hs +++ b/src/Ormolu/Fixity/Internal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} module Ormolu.Fixity.Internal @@ -10,12 +11,17 @@ module Ormolu.Fixity.Internal occOpName, FixityDirection (..), FixityInfo (..), - defaultFixityInfo, colonFixityInfo, + defaultFixityInfo, + FixityApproximation (..), + defaultFixityApproximation, HackageInfo (..), - FixityMap, - LazyFixityMap (..), - lookupFixity, + FixityOverrides (..), + PackageFixityMap (..), + ModuleFixityMap (..), + FixityProvenance (..), + FixityQualification (..), + inferFixity, ) where @@ -23,73 +29,22 @@ import Control.DeepSeq (NFData) 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)) - --- | Fixity direction. -data FixityDirection - = InfixL - | InfixR - | InfixN - 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. -data FixityInfo = FixityInfo - { -- | Fixity direction if it is known - fiDirection :: Maybe FixityDirection, - -- | Minimum precedence level found in the (maybe conflicting) - -- definitions for the operator (inclusive) - fiMinPrecedence :: Int, - -- | Maximum precedence level found in the (maybe conflicting) - -- definitions for the operator (inclusive) - fiMaxPrecedence :: 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 - } - where - dir' = case (dir1, dir2) of - (Just a, Just b) | a == b -> Just a - _ -> Nothing +import GHC.Types.Name.Reader (RdrName (..), rdrNameOcc) +import Ormolu.Utils (ghcModuleNameToCabal) -- | An operator name. newtype OpName = MkOpName @@ -119,26 +74,134 @@ instance Show OpName where instance IsString OpName where fromString = OpName . T.pack --- | Map from the operator name to its 'FixityInfo'. -type FixityMap = Map OpName FixityInfo +-- | Fixity direction. +data FixityDirection + = InfixL + | InfixR + | InfixN + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (Binary, NFData) --- | A variant of 'FixityMap', represented as a lazy union of several --- 'FixityMap's. -newtype LazyFixityMap = LazyFixityMap [FixityMap] - deriving (Show) +-- | 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) --- | 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) +-- | Fixity info of the built-in colon data constructor. +colonFixityInfo :: FixityInfo +colonFixityInfo = FixityInfo InfixR 5 --- | 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) +-- | 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 + faDirection :: Maybe FixityDirection, + -- | Minimum precedence level found in the (maybe conflicting) + -- definitions for the operator (inclusive) + faMinPrecedence :: Int, + -- | Maximum precedence level found in the (maybe conflicting) + -- definitions for the operator (inclusive) + faMaxPrecedence :: Int + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (Binary, NFData) + +-- | Gives the ability to merge two (maybe conflicting) definitions for an +-- operator, keeping the higher level of compatible information from both. +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 + +-- | The lowest level of information we can have about an operator. +defaultFixityApproximation :: FixityApproximation +defaultFixityApproximation = fixityInfoToApproximation defaultFixityInfo + +-- | Convert from 'FixityInfo' to 'FixityApproximation'. +fixityInfoToApproximation :: FixityInfo -> FixityApproximation +fixityInfoToApproximation FixityInfo {..} = + FixityApproximation + { faDirection = Just fiDirection, + faMinPrecedence = fiPrecedence, + faMaxPrecedence = fiPrecedence + } + +-- | 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) + deriving anyclass (Binary, NFData) + +-- | Map from the operator name to its 'FixityInfo'. +newtype FixityOverrides = FixityOverrides + { unFixityOverrides :: Map OpName FixityInfo + } + deriving stock (Eq, Show) + +-- | 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) + +-- | Fixity map that takes into account imports in a particular module. +newtype ModuleFixityMap + = ModuleFixityMap (Map OpName FixityProvenance) + deriving stock (Eq, Show) + +-- | 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) + +-- | 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 index 9c71bae..d34d4bb 100644 --- a/src/Ormolu/Fixity/Parser.hs +++ b/src/Ormolu/Fixity/Parser.hs @@ -3,7 +3,7 @@ -- | Parser for fixity maps. module Ormolu.Fixity.Parser - ( parseFixityMap, + ( parseFixityOverrides, parseFixityDeclaration, -- * Raw parsers @@ -12,6 +12,7 @@ module Ormolu.Fixity.Parser ) where +import Control.Monad (when) import Data.Char qualified as Char import Data.Map.Strict qualified as Map import Data.Text (Text) @@ -24,15 +25,15 @@ import Text.Megaparsec.Char.Lexer qualified as L type Parser = Parsec Void Text --- | Parse textual representation of a 'FixityMap'. -parseFixityMap :: +-- | Parse textual representation of 'FixityOverrides'. +parseFixityOverrides :: -- | 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 +parseFixityOverrides = runParser pFixityOverrides -- | Parse a single self-contained fixity declaration. parseFixityDeclaration :: @@ -42,9 +43,9 @@ parseFixityDeclaration :: Either (ParseErrorBundle Text Void) [(OpName, FixityInfo)] parseFixityDeclaration = runParser (pFixity <* eof) "" -pFixityMap :: Parser FixityMap -pFixityMap = - Map.fromListWith (<>) . mconcat +pFixityOverrides :: Parser FixityOverrides +pFixityOverrides = + FixityOverrides . Map.fromList . mconcat <$> many (pFixity <* eol <* hidden space) <* eof @@ -53,10 +54,14 @@ pFixityMap = -- > 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 diff --git a/src/Ormolu/Fixity/Printer.hs b/src/Ormolu/Fixity/Printer.hs index 29734c2..fe1d378 100644 --- a/src/Ormolu/Fixity/Printer.hs +++ b/src/Ormolu/Fixity/Printer.hs @@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} --- | Printer for fixity maps. +-- | Printer for fixity overrides. module Ormolu.Fixity.Printer - ( printFixityMap, + ( printFixityOverrides, ) where @@ -17,35 +17,24 @@ import Data.Text.Lazy.Builder qualified as B import Data.Text.Lazy.Builder.Int qualified as B import Ormolu.Fixity --- | Print out a textual representation of a 'FixityMap'. -printFixityMap :: FixityMap -> Text -printFixityMap = +-- | Print out a textual representation of 'FixityOverrides'. +printFixityOverrides :: FixityOverrides -> Text +printFixityOverrides (FixityOverrides m) = TL.toStrict . B.toLazyText . mconcat . fmap renderOne - . concatMap decompose - . Map.toList + $ Map.toList m 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) = + renderOne :: (OpName, FixityInfo) -> Builder + renderOne (OpName operator, FixityInfo {..}) = mconcat - [ case fixityDirection of + [ case fiDirection of InfixL -> "infixl" InfixR -> "infixr" InfixN -> "infix", " ", - B.decimal n, + B.decimal fiPrecedence, " ", if isTickedOperator operator then "`" <> B.fromText operator <> "`" diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs index d6c813d..7d2f174 100644 --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -18,31 +18,38 @@ import Control.Monad.Except (ExceptT (..), runExceptT) 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 (extractFixityImports) import Ormolu.Imports (normalizeImports) import Ormolu.Parser.CommentStream import Ormolu.Parser.Result @@ -50,13 +57,13 @@ import Ormolu.Processing.Common 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 @@ parseModule :: ( [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,44 @@ parseModule config@Config {..} fixityMap path rawInput = liftIO $ do 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 (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 +132,7 @@ parseModuleSnippet Config {..} fixityMap dynFlags path rawInput = liftIO $ do msg = showOutputable . formatBulleted defaultSDocContext - . diagnosticMessage NoDiagnosticOpts + . diagnosticMessage GHC.NoDiagnosticOpts $ err in case L.sortOn (rateSeverity . errMsgSeverity) errs of [] -> Nothing @@ -148,8 +164,7 @@ parseModuleSnippet Config {..} fixityMap dynFlags path rawInput = liftIO $ do prPragmas = pragmas, prCommentStream = comments, prExtensions = GHC.extensionFlags dynFlags, - prFixityOverrides = cfgFixityOverrides, - prFixityMap = fixityMap, + prModuleFixityMap = modFixityMap, prIndent = indent } return r @@ -253,6 +268,8 @@ runParser parser flags filename input = GHC.unP parser parseState ---------------------------------------------------------------------------- -- 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 +278,14 @@ parsePragmasIntoDynFlags :: -- | 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 +295,45 @@ parsePragmasIntoDynFlags flags extraOpts filepath str = 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 + 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 - catchErrors act = - GHC.handleGhcException - reportErr - (GHC.handleSourceError reportErr act) reportErr e = return $ Left (show e) diff --git a/src/Ormolu/Parser/Result.hs b/src/Ormolu/Parser/Result.hs index efd51a0..31d7690 100644 --- a/src/Ormolu/Parser/Result.hs +++ b/src/Ormolu/Parser/Result.hs @@ -11,7 +11,7 @@ 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) @@ -32,10 +32,8 @@ data ParseResult = ParseResult 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 index fd984d7..3b36bd5 100644 --- a/src/Ormolu/Printer.hs +++ b/src/Ormolu/Printer.hs @@ -36,6 +36,5 @@ printSnippets = T.concat . fmap printSnippet prCommentStream prSourceType prExtensions - prFixityOverrides - prFixityMap + prModuleFixityMap RawSnippet r -> r diff --git a/src/Ormolu/Printer/Combinators.hs b/src/Ormolu/Printer/Combinators.hs index 9b4142d..9a9f227 100644 --- a/src/Ormolu/Printer/Combinators.hs +++ b/src/Ormolu/Printer/Combinators.hs @@ -22,10 +22,9 @@ module Ormolu.Printer.Combinators inci, inciIf, askSourceType, - askFixityOverrides, - encloseLocated, - askFixityMap, + askModuleFixityMap, located, + encloseLocated, located', switchLayout, Layout (..), diff --git a/src/Ormolu/Printer/Internal.hs b/src/Ormolu/Printer/Internal.hs index 8f73d34..7c9eaa9 100644 --- a/src/Ormolu/Printer/Internal.hs +++ b/src/Ormolu/Printer/Internal.hs @@ -17,8 +17,7 @@ module Ormolu.Printer.Internal space, newline, askSourceType, - askFixityOverrides, - askFixityMap, + askModuleFixityMap, inci, sitcc, Layout (..), @@ -58,6 +57,7 @@ import Control.Monad.Reader 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 @@ -69,7 +69,7 @@ import GHC.LanguageExtensions.Type 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) @@ -98,12 +98,8 @@ data RC = RC 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'. @@ -171,13 +167,11 @@ runR :: 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 = @@ -188,8 +182,7 @@ runR (R m) sstream cstream sourceType extensions fixityOverrides fixityMap = rcCanUseBraces = False, rcExtensions = extensions, rcSourceType = sourceType, - rcFixityOverrides = fixityOverrides, - rcFixityMap = fixityMap + rcModuleFixityMap = moduleFixityMap } sc = SC @@ -386,13 +379,9 @@ newlineRaw = R . modify $ \sc -> 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) @@ -514,7 +503,7 @@ getEnclosingSpan :: (RealSrcSpan -> Bool) -> R (Maybe RealSrcSpan) getEnclosingSpan f = - listToMaybe . filter f <$> R (asks rcEnclosingSpans) + 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/Declaration/OpTree.hs b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs index 410249e..0d53f0f 100644 --- a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs +++ b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs @@ -115,7 +115,7 @@ p_exprOpTree s t@(OpBranches exprs ops) = do 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 index 70c0fdb..e1df3d8 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs @@ -340,12 +340,11 @@ p_hsCmd' isApp s = \case 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' Applicand s) @@ -663,12 +662,11 @@ p_hsExpr' isApp s = \case _ -> 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 diff --git a/src/Ormolu/Printer/Meat/Type.hs b/src/Ormolu/Printer/Meat/Type.hs index bbdd453..e6e7b5b 100644 --- a/src/Ormolu/Printer/Meat/Type.hs +++ b/src/Ormolu/Printer/Meat/Type.hs @@ -110,11 +110,10 @@ p_hsType' multilineArgs = \case 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 index 9369a32..362a330 100644 --- a/src/Ormolu/Printer/Operators.hs +++ b/src/Ormolu/Printer/Operators.hs @@ -11,10 +11,7 @@ module Ormolu.Printer.Operators ) 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 OpTree ty op 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,8 +54,8 @@ data OpInfo op = OpInfo -- 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 @@ -89,48 +86,40 @@ opTreeLoc (OpBranches exprs _) = 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 @@ reassociateFlatOpTree tree@(OpBranches noptExprs noptOps) = 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 @@ reassociateFlatOpTree tree@(OpBranches noptExprs noptOps) = -- 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 index d34dd87..acf1c5f 100644 --- a/src/Ormolu/Utils.hs +++ b/src/Ormolu/Utils.hs @@ -17,6 +17,7 @@ module Ormolu.Utils getLoc', matchAddEpAnn, textToStringBuffer, + ghcModuleNameToCabal, ) where @@ -27,16 +28,19 @@ import Data.Maybe (fromMaybe) 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 @@ textToStringBuffer txt = unsafePerformIO $ do 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/Fixity.hs b/src/Ormolu/Utils/Fixity.hs index 645b7d9..0495a33 100644 --- a/src/Ormolu/Utils/Fixity.hs +++ b/src/Ormolu/Utils/Fixity.hs @@ -24,7 +24,7 @@ import System.IO.Unsafe (unsafePerformIO) import Text.Megaparsec (errorBundlePretty) -- | Cache ref that stores fixity overrides per cabal file. -cacheRef :: IORef (Map FilePath FixityMap) +cacheRef :: IORef (Map FilePath FixityOverrides) cacheRef = unsafePerformIO (newIORef Map.empty) {-# NOINLINE cacheRef #-} @@ -35,7 +35,7 @@ getFixityOverridesForSourceFile :: (MonadIO m) => -- | 'CabalInfo' already obtained for this source file CabalInfo -> - m FixityMap + m FixityOverrides getFixityOverridesForSourceFile CabalInfo {..} = liftIO $ do cache <- readIORef cacheRef case Map.lookup ciCabalFilePath cache of @@ -46,13 +46,13 @@ getFixityOverridesForSourceFile CabalInfo {..} = liftIO $ do then do dotOrmoluRelative <- makeRelativeToCurrentDirectory dotOrmolu contents <- readFileUtf8 dotOrmolu - case parseFixityMap dotOrmoluRelative contents of + case parseFixityOverrides dotOrmoluRelative contents of Left errorBundle -> throwIO (OrmoluFixityOverridesParseError errorBundle) Right x -> do modifyIORef' cacheRef (Map.insert ciCabalFilePath x) return x - else return Map.empty + else return (FixityOverrides Map.empty) Just x -> return x -- | A wrapper around 'parseFixityDeclaration' for parsing individual fixity diff --git a/tests/Ormolu/CabalInfoSpec.hs b/tests/Ormolu/CabalInfoSpec.hs index 0ce356f..f3008f0 100644 --- a/tests/Ormolu/CabalInfoSpec.hs +++ b/tests/Ormolu/CabalInfoSpec.hs @@ -44,7 +44,7 @@ spec = do 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 index eb9cec1..d4ef83f 100644 --- a/tests/Ormolu/Fixity/ParserSpec.hs +++ b/tests/Ormolu/Fixity/ParserSpec.hs @@ -9,35 +9,36 @@ import Ormolu.Fixity import Ormolu.Fixity.Parser import Test.Hspec import Test.Hspec.Megaparsec +import Text.Megaparsec.Error (ErrorFancy (..)) spec :: Spec spec = do 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,13 +70,18 @@ spec = do elabel "operator character" ] ) - describe "parseFixityMap" $ do + 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 "parseFixityOverrides" $ do it "parses the empty input without choking" $ - parseFixityMap "" "" - `shouldParse` Map.empty + parseFixityOverrides "" "" + `shouldParse` FixityOverrides Map.empty it "parses a collection of declarations" $ -- The example is taken from base. - parseFixityMap + parseFixityOverrides "" ( T.unlines [ "infixr 9 .", @@ -87,22 +93,24 @@ spec = do "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) - ] + `shouldParse` 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) + ] + ) it "combines conflicting declarations correctly" $ - parseFixityMap + parseFixityOverrides "" ( T.unlines [ "infixr 9 ., ^", @@ -111,20 +119,21 @@ spec = do "infixl 7 $" ] ) - `shouldParse` Map.fromList - [ ("$", FixityInfo Nothing 7 7), - (".", FixityInfo (Just InfixR) 7 9), - ("^", FixityInfo (Just InfixR) 9 9) - ] + `shouldParse` FixityOverrides + ( Map.fromList + [ ("$", FixityInfo InfixL 7), + (".", FixityInfo InfixR 7), + ("^", FixityInfo InfixR 9) + ] + ) it "handles CRLF line endings correctly" $ - parseFixityMap "" - `shouldSucceedOn` ( unlinesCrlf - [ "infixr 9 .", - "infixr 5 ++" - ] - ) + parseFixityOverrides "" + `shouldSucceedOn` unlinesCrlf + [ "infixr 9 .", + "infixr 5 ++" + ] it "fails with correct parse error (keyword wrong second line)" $ - parseFixityMap "" "infixr 5 .\nfoobar 5 $" + parseFixityOverrides "" "infixr 5 .\nfoobar 5 $" `shouldFailWith` err 11 ( mconcat diff --git a/tests/Ormolu/Fixity/PrinterSpec.hs b/tests/Ormolu/Fixity/PrinterSpec.hs index 76c9796..f6baea0 100644 --- a/tests/Ormolu/Fixity/PrinterSpec.hs +++ b/tests/Ormolu/Fixity/PrinterSpec.hs @@ -12,12 +12,12 @@ import Test.Hspec import Test.Hspec.Megaparsec import Test.QuickCheck -newtype FixityMapWrapper = FixityMapWrapper FixityMap +newtype FixityMapWrapper = FixityMapWrapper FixityOverrides deriving (Show) instance Arbitrary FixityMapWrapper where arbitrary = - FixityMapWrapper . Map.fromListWith (<>) + FixityMapWrapper . FixityOverrides . Map.fromList <$> listOf ((,) <$> genOperator <*> genFixityInfo) where scaleDown = scale (`div` 4) @@ -35,18 +35,16 @@ instance Arbitrary FixityMapWrapper where 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 {..} 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 + parseFixityOverrides "" (printFixityOverrides fixityMap) `shouldParse` fixityMap diff --git a/tests/Ormolu/FixitySpec.hs b/tests/Ormolu/FixitySpec.hs new file mode 100644 index 0000000..7ec8659 --- /dev/null +++ b/tests/Ormolu/FixitySpec.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ormolu.FixitySpec (spec) where + +import Data.Function ((&)) +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)] + +-- | 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, + fimportModuleName = 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 index d5ee2a7..0000000 --- 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 index 9860670..fd66eeb 100644 --- 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 @@ checkReassociate :: -- | 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 @@ spec = do ["+"] 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 @@ spec = do ] ["+", "-"] 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 @@ spec = do ] ["+", "-"] 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 @@ spec = do ] ["$"] 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 @@ spec = do ["+"] ] ["$", "$"] - 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 index afb28a5..de04d39 100644 --- a/tests/Ormolu/PrinterSpec.hs +++ b/tests/Ormolu/PrinterSpec.hs @@ -8,6 +8,7 @@ import Control.Monad 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 @@ spec = do 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 @@ checkExample srcPath' = it (fromRelFile srcPath' ++ " works") . withNiceExceptio 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.