{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
module Ormolu.Fixity
( OpName,
pattern OpName,
unOpName,
occOpName,
FixityDirection (..),
FixityInfo (..),
FixityMap,
LazyFixityMap,
lookupFixity,
HackageInfo (..),
defaultStrategyThreshold,
defaultFixityInfo,
buildFixityMap,
buildFixityMap',
bootPackages,
packageToOps,
packageToPopularity,
)
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 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.Types.PackageName (PackageName, mkPackageName, unPackageName)
import Ormolu.Fixity.Internal
#if BUNDLE_FIXITIES
import Data.FileEmbed (embedFile)
#else
import qualified Data.ByteString as B
import System.IO.Unsafe (unsafePerformIO)
#endif
packageToOps :: Map PackageName FixityMap
packageToPopularity :: Map PackageName Int
#if BUNDLE_FIXITIES
HackageInfo Map PackageName FixityMap
packageToOps Map PackageName Int
packageToPopularity =
forall a. Get a -> ByteString -> a
Binary.runGet forall t. Binary t => Get t
Binary.get forall a b. (a -> b) -> a -> b
$
ByteString -> ByteString
BL.fromStrict $(embedFile "extract-hackage-info/hackage-info.bin")
#else
HackageInfo packageToOps packageToPopularity =
unsafePerformIO $
Binary.runGet Binary.get . BL.fromStrict <$> B.readFile "hackage-info.bin"
{-# NOINLINE packageToOps #-}
{-# NOINLINE packageToPopularity #-}
#endif
bootPackages :: Set PackageName
bootPackages :: Set PackageName
bootPackages =
forall a. Ord a => [a] -> Set a
Set.fromList
[ PackageName
"array",
PackageName
"binary",
PackageName
"bytestring",
PackageName
"containers",
PackageName
"deepseq",
PackageName
"directory",
PackageName
"exceptions",
PackageName
"filepath",
PackageName
"ghc-binary",
PackageName
"mtl",
PackageName
"parsec",
PackageName
"process",
PackageName
"stm",
PackageName
"template-haskell",
PackageName
"terminfo",
PackageName
"text",
PackageName
"time",
PackageName
"transformers",
PackageName
"unix",
PackageName
"Win32"
]
defaultStrategyThreshold :: Float
defaultStrategyThreshold :: Float
defaultStrategyThreshold = Float
0.9
buildFixityMap ::
Float ->
Set PackageName ->
LazyFixityMap
buildFixityMap :: Float -> Set PackageName -> LazyFixityMap
buildFixityMap = Map PackageName FixityMap
-> Map PackageName Int
-> Set PackageName
-> Float
-> Set PackageName
-> LazyFixityMap
buildFixityMap' Map PackageName FixityMap
packageToOps Map PackageName Int
packageToPopularity Set PackageName
bootPackages
buildFixityMap' ::
Map PackageName FixityMap ->
Map PackageName Int ->
Set PackageName ->
Float ->
Set PackageName ->
LazyFixityMap
buildFixityMap' :: Map PackageName FixityMap
-> Map PackageName Int
-> Set PackageName
-> Float
-> Set PackageName
-> LazyFixityMap
buildFixityMap'
Map PackageName FixityMap
operatorMap
Map PackageName Int
popularityMap
Set PackageName
higherPriorityPackages
Float
strategyThreshold = forall v. (Set PackageName -> v) -> Set PackageName -> v
memoSet forall a b. (a -> b) -> a -> b
$ \Set PackageName
dependencies ->
let baseFixityMap :: FixityMap
baseFixityMap =
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert OpName
":" FixityInfo
colonFixityInfo forall a b. (a -> b) -> a -> b
$
forall a. a -> Maybe a -> a
fromMaybe forall k a. Map k a
Map.empty forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
"base" Map PackageName FixityMap
operatorMap
cabalFixityMap :: FixityMap
cabalFixityMap =
[(PackageName, FixityMap)] -> FixityMap
mergeAll (PackageName -> (PackageName, FixityMap)
buildPackageFixityMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList Set PackageName
dependencies)
higherPriorityFixityMap :: FixityMap
higherPriorityFixityMap =
[(PackageName, FixityMap)] -> FixityMap
mergeAll (PackageName -> (PackageName, FixityMap)
buildPackageFixityMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList Set PackageName
higherPriorityPackages)
remainingFixityMap :: FixityMap
remainingFixityMap =
Map PackageName Int
-> Float -> [(PackageName, FixityMap)] -> FixityMap
mergeFixityMaps
Map PackageName Int
popularityMap
Float
strategyThreshold
(PackageName -> (PackageName, FixityMap)
buildPackageFixityMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList Set PackageName
remainingPackages)
remainingPackages :: Set PackageName
remainingPackages =
forall k a. Map k a -> Set k
Map.keysSet Map PackageName FixityMap
operatorMap
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` forall a. Ord a => Set a -> Set a -> Set a
Set.union Set PackageName
dependencies Set PackageName
higherPriorityPackages
buildPackageFixityMap :: PackageName -> (PackageName, FixityMap)
buildPackageFixityMap PackageName
packageName =
( PackageName
packageName,
forall a. a -> Maybe a -> a
fromMaybe forall k a. Map k a
Map.empty forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
packageName Map PackageName FixityMap
operatorMap
)
mergeAll :: [(PackageName, FixityMap)] -> FixityMap
mergeAll = Map PackageName Int
-> Float -> [(PackageName, FixityMap)] -> FixityMap
mergeFixityMaps forall k a. Map k a
Map.empty Float
10.0
in [FixityMap] -> LazyFixityMap
LazyFixityMap
[ FixityMap
baseFixityMap,
FixityMap
cabalFixityMap,
FixityMap
higherPriorityFixityMap,
FixityMap
remainingFixityMap
]
memoSet :: (Set PackageName -> v) -> Set PackageName -> v
memoSet :: forall v. (Set PackageName -> v) -> Set PackageName -> v
memoSet Set PackageName -> v
f = forall t a. HasTrie t => (t -> a) -> t -> a
memo (Set PackageName -> v
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> Set a
Set.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> PackageName
mkPackageName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageName -> String
unPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toAscList
mergeFixityMaps ::
Map PackageName Int ->
Float ->
[(PackageName, FixityMap)] ->
FixityMap
mergeFixityMaps :: Map PackageName Int
-> Float -> [(PackageName, FixityMap)] -> FixityMap
mergeFixityMaps Map PackageName Int
popularityMap Float
threshold [(PackageName, FixityMap)]
packageMaps =
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
(Float -> NonEmpty (FixityInfo, Int) -> FixityInfo
useThreshold Float
threshold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> NonEmpty a
NE.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList)
Map OpName (Map FixityInfo Int)
scoredMap
where
scoredMap :: Map OpName (Map FixityInfo Int)
scoredMap = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Map FixityInfo (NonEmpty PackageName) -> Map FixityInfo Int
getScores Map OpName (Map FixityInfo (NonEmpty PackageName))
opFixityMap
opFixityMap :: Map OpName (Map FixityInfo (NonEmpty PackageName))
opFixityMap =
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith
(forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Semigroup a => a -> a -> a
(<>))
((PackageName, FixityMap)
-> Map OpName (Map FixityInfo (NonEmpty PackageName))
opFixityMapFrom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PackageName, FixityMap)]
packageMaps)
useThreshold ::
Float ->
NonEmpty (FixityInfo, Int) ->
FixityInfo
useThreshold :: Float -> NonEmpty (FixityInfo, Int) -> FixityInfo
useThreshold Float
t NonEmpty (FixityInfo, Int)
fixScores =
if forall {a}. Integral a => a -> Float
toFloat Int
maxScore forall a. Fractional a => a -> a -> a
/ forall {a}. Integral a => a -> Float
toFloat Int
sumScores forall a. Ord a => a -> a -> Bool
>= Float
t
then forall a. Semigroup a => NonEmpty a -> a
sconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ NonEmpty (FixityInfo, Int)
maxs
else forall a. Semigroup a => NonEmpty a -> a
sconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ NonEmpty (FixityInfo, Int)
fixScores
where
toFloat :: a -> Float
toFloat a
x = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x :: Float
maxs :: NonEmpty (FixityInfo, Int)
maxs = forall b a. Ord b => (a -> b) -> NonEmpty a -> NonEmpty a
maxWith forall a b. (a, b) -> b
snd NonEmpty (FixityInfo, Int)
fixScores
maxScore :: Int
maxScore = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NE.head NonEmpty (FixityInfo, Int)
maxs
sumScores :: Int
sumScores = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Num a => a -> a -> a
(+) Int
0 (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (FixityInfo, Int)
fixScores)
getScores ::
Map FixityInfo (NonEmpty PackageName) ->
Map FixityInfo Int
getScores :: Map FixityInfo (NonEmpty PackageName) -> Map FixityInfo Int
getScores =
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
(forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map PackageName Int
popularityMap))
opFixityMapFrom ::
(PackageName, FixityMap) ->
Map OpName (Map FixityInfo (NonEmpty PackageName))
opFixityMapFrom :: (PackageName, FixityMap)
-> Map OpName (Map FixityInfo (NonEmpty PackageName))
opFixityMapFrom (PackageName
packageName, FixityMap
opsMap) =
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
(forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. k -> a -> Map k a
Map.singleton (PackageName
packageName forall a. a -> [a] -> NonEmpty a
:| []))
FixityMap
opsMap
maxWith :: (Ord b) => (a -> b) -> NonEmpty a -> NonEmpty a
maxWith :: forall b a. Ord b => (a -> b) -> NonEmpty a -> NonEmpty a
maxWith a -> b
f NonEmpty a
xs = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (b, NonEmpty a) -> a -> (b, NonEmpty a)
comp (a -> b
f a
h, a
h forall a. a -> [a] -> NonEmpty a
:| []) [a]
t
where
a
h :| [a]
t = NonEmpty a
xs
comp :: (b, NonEmpty a) -> a -> (b, NonEmpty a)
comp (b
fMax, NonEmpty a
maxs) a
x =
let fX :: b
fX = a -> b
f a
x
in if
| b
fMax forall a. Ord a => a -> a -> Bool
< b
fX -> (b
fX, a
x forall a. a -> [a] -> NonEmpty a
:| [])
| b
fMax forall a. Eq a => a -> a -> Bool
== b
fX -> (b
fMax, forall a. a -> NonEmpty a -> NonEmpty a
NE.cons a
x NonEmpty a
maxs)
| Bool
otherwise -> (b
fMax, NonEmpty a
maxs)