mirror of
https://github.com/tweag/ormolu.git
synced 2024-10-05 17:37:11 +03:00
Implement a more precise inference of fixity information
This commit is contained in:
parent
db1ebbba2f
commit
badafc0452
@ -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
|
||||
|
@ -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
|
||||
|
@ -1,3 +1,5 @@
|
||||
import Servant.API
|
||||
|
||||
type Foo a b c =
|
||||
Bar c a b
|
||||
|
||||
|
@ -1,3 +1,5 @@
|
||||
import Servant.API
|
||||
|
||||
type Foo a b c
|
||||
= Bar c a b
|
||||
|
||||
|
@ -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"]
|
@ -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"]
|
@ -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
|
||||
)
|
@ -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
|
||||
)
|
@ -1,3 +1,5 @@
|
||||
import Control.Lens.Operators
|
||||
|
||||
lenses =
|
||||
Just $
|
||||
M.fromList $
|
||||
|
@ -1,3 +1,5 @@
|
||||
import Control.Lens.Operators
|
||||
|
||||
lenses = Just $ M.fromList
|
||||
$ "type" .= ("user.connection" :: Text)
|
||||
# "connection" .= uc
|
||||
|
@ -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
|
@ -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
|
@ -1,3 +1,5 @@
|
||||
import Control.Lens.Operators
|
||||
|
||||
a =
|
||||
b
|
||||
& c .~ d
|
||||
|
@ -1,3 +1,5 @@
|
||||
import Control.Lens.Operators
|
||||
|
||||
a =
|
||||
b & c .~ d
|
||||
& e %~ f
|
||||
|
@ -1,3 +1,5 @@
|
||||
import Control.Arrow
|
||||
|
||||
foo =
|
||||
op <> n
|
||||
<+> colon
|
||||
|
@ -1,3 +1,5 @@
|
||||
import Control.Arrow
|
||||
|
||||
foo =
|
||||
op <> n <+> colon <+> prettySe <+> text "=" <+>
|
||||
prettySe <> text sc
|
||||
|
@ -1,3 +1,5 @@
|
||||
import Control.Arrow
|
||||
|
||||
foo =
|
||||
line <> bindingOf
|
||||
<+> text "="
|
||||
|
@ -1,3 +1,5 @@
|
||||
import Control.Arrow
|
||||
|
||||
foo =
|
||||
line <> bindingOf <+> text "=" <+> tPretty <+> colon <+>
|
||||
align <> prettyPs
|
||||
|
@ -1,3 +1,5 @@
|
||||
import Servant.API
|
||||
|
||||
type PermuteRef =
|
||||
"a"
|
||||
:> ( "b" :> "c" :> End
|
||||
|
@ -1,3 +1,5 @@
|
||||
import Servant.API
|
||||
|
||||
type PermuteRef =
|
||||
"a" :> ( "b" :> "c" :> End
|
||||
:<|> "c" :> "b" :> End
|
||||
|
@ -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"
|
||||
|
||||
|
@ -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`
|
||||
|
||||
|
@ -7,6 +7,7 @@ author: Thomas Bagrel <thomas.bagrel@tweag.io>
|
||||
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
|
||||
|
Binary file not shown.
113
extract-hackage-info/src/Hoogle.hs
Normal file
113
extract-hackage-info/src/Hoogle.hs
Normal file
@ -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'))
|
@ -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'
|
||||
|
@ -1,2 +1,2 @@
|
||||
infixr 8 .=
|
||||
infixr 5 #
|
||||
infixr 5 #, :>
|
||||
|
@ -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"
|
||||
|
@ -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 ]
|
||||
|
@ -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]
|
||||
|
@ -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]
|
||||
|
@ -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
|
||||
# []
|
@ -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 []) "<input>" src
|
||||
O.parseModule cfgWithDeltas pfixityMap "<input>" src
|
||||
pure case eSnippets of
|
||||
Left e -> T.pack $ show e
|
||||
Right snippets -> T.unlines $ showSnippet <$> snippets
|
||||
|
@ -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,
|
||||
|
@ -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"
|
||||
|
@ -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
|
@ -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
|
@ -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
|
@ -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
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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,
|
||||
|
@ -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
|
||||
|
73
src/Ormolu/Fixity/Imports.hs
Normal file
73
src/Ormolu/Fixity/Imports.hs
Normal file
@ -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
|
||||
_ -> []
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 <> "`"
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -36,6 +36,5 @@ printSnippets = T.concat . fmap printSnippet
|
||||
prCommentStream
|
||||
prSourceType
|
||||
prExtensions
|
||||
prFixityOverrides
|
||||
prFixityMap
|
||||
prModuleFixityMap
|
||||
RawSnippet r -> r
|
||||
|
@ -22,10 +22,9 @@ module Ormolu.Printer.Combinators
|
||||
inci,
|
||||
inciIf,
|
||||
askSourceType,
|
||||
askFixityOverrides,
|
||||
encloseLocated,
|
||||
askFixityMap,
|
||||
askModuleFixityMap,
|
||||
located,
|
||||
encloseLocated,
|
||||
located',
|
||||
switchLayout,
|
||||
Layout (..),
|
||||
|
@ -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 ()
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
279
tests/Ormolu/FixitySpec.hs
Normal file
279
tests/Ormolu/FixitySpec.hs
Normal file
@ -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)
|
||||
}
|
@ -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
|
@ -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
|
||||
|
@ -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.
|
||||
|
Loading…
Reference in New Issue
Block a user