{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# 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 qualified Data.Binary as Binary
import qualified Data.Binary.Get as Binary
import qualified Data.ByteString.Lazy as BL
import Data.Foldable (foldl')
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.MemoTrie (memo)
import Data.Semigroup (sconcat)
import Data.Set (Set)
import qualified Data.Set 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.Unsafe as BU
import Foreign.Ptr
import System.Environment (getEnv)
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 =
Get HackageInfo -> ByteString -> HackageInfo
forall a. Get a -> ByteString -> a
Binary.runGet Get HackageInfo
forall t. Binary t => Get t
Binary.get (ByteString -> HackageInfo) -> ByteString -> HackageInfo
forall a b. (a -> b) -> a -> b
$
ByteString -> ByteString
BL.fromStrict $(embedFile "extract-hackage-info/hackage-info.bin")
#else
HackageInfo packageToOps packageToPopularity = unsafePerformIO $ do
(ptr, len) <- read <$> getEnv "ORMOLU_HACKAGE_INFO"
Binary.runGet Binary.get . BL.fromStrict
<$> BU.unsafePackMallocCStringLen (intPtrToPtr $ IntPtr ptr, len)
{-# NOINLINE packageToOps #-}
{-# NOINLINE packageToPopularity #-}
#endif
bootPackages :: Set PackageName
bootPackages :: Set PackageName
bootPackages =
[PackageName] -> Set PackageName
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 = (Set PackageName -> LazyFixityMap)
-> Set PackageName -> LazyFixityMap
forall v. (Set PackageName -> v) -> Set PackageName -> v
memoSet ((Set PackageName -> LazyFixityMap)
-> Set PackageName -> LazyFixityMap)
-> (Set PackageName -> LazyFixityMap)
-> Set PackageName
-> LazyFixityMap
forall a b. (a -> b) -> a -> b
$ \Set PackageName
dependencies ->
let baseFixityMap :: FixityMap
baseFixityMap =
OpName -> FixityInfo -> FixityMap -> FixityMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert OpName
":" FixityInfo
colonFixityInfo (FixityMap -> FixityMap) -> FixityMap -> FixityMap
forall a b. (a -> b) -> a -> b
$
FixityMap -> Maybe FixityMap -> FixityMap
forall a. a -> Maybe a -> a
fromMaybe FixityMap
forall k a. Map k a
Map.empty (Maybe FixityMap -> FixityMap) -> Maybe FixityMap -> FixityMap
forall a b. (a -> b) -> a -> b
$
PackageName -> Map PackageName FixityMap -> Maybe FixityMap
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 (PackageName -> (PackageName, FixityMap))
-> [PackageName] -> [(PackageName, FixityMap)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set PackageName -> [PackageName]
forall a. Set a -> [a]
Set.toList Set PackageName
dependencies)
higherPriorityFixityMap :: FixityMap
higherPriorityFixityMap =
[(PackageName, FixityMap)] -> FixityMap
mergeAll (PackageName -> (PackageName, FixityMap)
buildPackageFixityMap (PackageName -> (PackageName, FixityMap))
-> [PackageName] -> [(PackageName, FixityMap)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set PackageName -> [PackageName]
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 (PackageName -> (PackageName, FixityMap))
-> [PackageName] -> [(PackageName, FixityMap)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set PackageName -> [PackageName]
forall a. Set a -> [a]
Set.toList Set PackageName
remainingPackages)
remainingPackages :: Set PackageName
remainingPackages =
Map PackageName FixityMap -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName FixityMap
operatorMap
Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set PackageName -> Set PackageName -> Set PackageName
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,
FixityMap -> Maybe FixityMap -> FixityMap
forall a. a -> Maybe a -> a
fromMaybe FixityMap
forall k a. Map k a
Map.empty (Maybe FixityMap -> FixityMap) -> Maybe FixityMap -> FixityMap
forall a b. (a -> b) -> a -> b
$
PackageName -> Map PackageName FixityMap -> Maybe FixityMap
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 Map PackageName Int
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 = ([String] -> v) -> [String] -> v
forall t a. HasTrie t => (t -> a) -> t -> a
memo (Set PackageName -> v
f (Set PackageName -> v)
-> ([String] -> Set PackageName) -> [String] -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackageName] -> Set PackageName
forall a. Eq a => [a] -> Set a
Set.fromAscList ([PackageName] -> Set PackageName)
-> ([String] -> [PackageName]) -> [String] -> Set PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> PackageName) -> [String] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> PackageName
mkPackageName) ([String] -> v)
-> (Set PackageName -> [String]) -> Set PackageName -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageName -> String
unPackageName ([PackageName] -> [String])
-> (Set PackageName -> [PackageName])
-> Set PackageName
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set PackageName -> [PackageName]
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 =
(Map FixityInfo Int -> FixityInfo)
-> Map OpName (Map FixityInfo Int) -> FixityMap
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
(Float -> NonEmpty (FixityInfo, Int) -> FixityInfo
useThreshold Float
threshold (NonEmpty (FixityInfo, Int) -> FixityInfo)
-> (Map FixityInfo Int -> NonEmpty (FixityInfo, Int))
-> Map FixityInfo Int
-> FixityInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FixityInfo, Int)] -> NonEmpty (FixityInfo, Int)
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([(FixityInfo, Int)] -> NonEmpty (FixityInfo, Int))
-> (Map FixityInfo Int -> [(FixityInfo, Int)])
-> Map FixityInfo Int
-> NonEmpty (FixityInfo, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FixityInfo Int -> [(FixityInfo, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList)
Map OpName (Map FixityInfo Int)
scoredMap
where
scoredMap :: Map OpName (Map FixityInfo Int)
scoredMap = (Map FixityInfo (NonEmpty PackageName) -> Map FixityInfo Int)
-> Map OpName (Map FixityInfo (NonEmpty PackageName))
-> Map OpName (Map FixityInfo Int)
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 =
(Map FixityInfo (NonEmpty PackageName)
-> Map FixityInfo (NonEmpty PackageName)
-> Map FixityInfo (NonEmpty PackageName))
-> [Map OpName (Map FixityInfo (NonEmpty PackageName))]
-> Map OpName (Map FixityInfo (NonEmpty PackageName))
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith
((NonEmpty PackageName
-> NonEmpty PackageName -> NonEmpty PackageName)
-> Map FixityInfo (NonEmpty PackageName)
-> Map FixityInfo (NonEmpty PackageName)
-> Map FixityInfo (NonEmpty PackageName)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith NonEmpty PackageName
-> NonEmpty PackageName -> NonEmpty PackageName
forall a. Semigroup a => a -> a -> a
(<>))
((PackageName, FixityMap)
-> Map OpName (Map FixityInfo (NonEmpty PackageName))
opFixityMapFrom ((PackageName, FixityMap)
-> Map OpName (Map FixityInfo (NonEmpty PackageName)))
-> [(PackageName, FixityMap)]
-> [Map OpName (Map FixityInfo (NonEmpty PackageName))]
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 Int -> Float
forall {a}. Integral a => a -> Float
toFloat Int
maxScore Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall {a}. Integral a => a -> Float
toFloat Int
sumScores Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
t
then NonEmpty FixityInfo -> FixityInfo
forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty FixityInfo -> FixityInfo)
-> (NonEmpty (FixityInfo, Int) -> NonEmpty FixityInfo)
-> NonEmpty (FixityInfo, Int)
-> FixityInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FixityInfo, Int) -> FixityInfo)
-> NonEmpty (FixityInfo, Int) -> NonEmpty FixityInfo
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FixityInfo, Int) -> FixityInfo
forall a b. (a, b) -> a
fst (NonEmpty (FixityInfo, Int) -> FixityInfo)
-> NonEmpty (FixityInfo, Int) -> FixityInfo
forall a b. (a -> b) -> a -> b
$ NonEmpty (FixityInfo, Int)
maxs
else NonEmpty FixityInfo -> FixityInfo
forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty FixityInfo -> FixityInfo)
-> (NonEmpty (FixityInfo, Int) -> NonEmpty FixityInfo)
-> NonEmpty (FixityInfo, Int)
-> FixityInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FixityInfo, Int) -> FixityInfo)
-> NonEmpty (FixityInfo, Int) -> NonEmpty FixityInfo
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FixityInfo, Int) -> FixityInfo
forall a b. (a, b) -> a
fst (NonEmpty (FixityInfo, Int) -> FixityInfo)
-> NonEmpty (FixityInfo, Int) -> FixityInfo
forall a b. (a -> b) -> a -> b
$ NonEmpty (FixityInfo, Int)
fixScores
where
toFloat :: a -> Float
toFloat a
x = a -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x :: Float
maxs :: NonEmpty (FixityInfo, Int)
maxs = ((FixityInfo, Int) -> Int)
-> NonEmpty (FixityInfo, Int) -> NonEmpty (FixityInfo, Int)
forall b a. Ord b => (a -> b) -> NonEmpty a -> NonEmpty a
maxWith (FixityInfo, Int) -> Int
forall a b. (a, b) -> b
snd NonEmpty (FixityInfo, Int)
fixScores
maxScore :: Int
maxScore = (FixityInfo, Int) -> Int
forall a b. (a, b) -> b
snd ((FixityInfo, Int) -> Int) -> (FixityInfo, Int) -> Int
forall a b. (a -> b) -> a -> b
$ NonEmpty (FixityInfo, Int) -> (FixityInfo, Int)
forall a. NonEmpty a -> a
NE.head NonEmpty (FixityInfo, Int)
maxs
sumScores :: Int
sumScores = (Int -> Int -> Int) -> Int -> NonEmpty Int -> Int
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 ((FixityInfo, Int) -> Int
forall a b. (a, b) -> b
snd ((FixityInfo, Int) -> Int)
-> NonEmpty (FixityInfo, Int) -> NonEmpty Int
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 =
(NonEmpty PackageName -> Int)
-> Map FixityInfo (NonEmpty PackageName) -> Map FixityInfo Int
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
(NonEmpty Int -> Int
forall a. Num a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (NonEmpty Int -> Int)
-> (NonEmpty PackageName -> NonEmpty Int)
-> NonEmpty PackageName
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName -> Int) -> NonEmpty PackageName -> NonEmpty Int
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int)
-> (PackageName -> Maybe Int) -> PackageName -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName -> Map PackageName Int -> Maybe Int)
-> Map PackageName Int -> PackageName -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageName -> Map PackageName Int -> Maybe Int
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) =
(FixityInfo -> Map FixityInfo (NonEmpty PackageName))
-> FixityMap -> Map OpName (Map FixityInfo (NonEmpty PackageName))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
((FixityInfo
-> NonEmpty PackageName -> Map FixityInfo (NonEmpty PackageName))
-> NonEmpty PackageName
-> FixityInfo
-> Map FixityInfo (NonEmpty PackageName)
forall a b c. (a -> b -> c) -> b -> a -> c
flip FixityInfo
-> NonEmpty PackageName -> Map FixityInfo (NonEmpty PackageName)
forall k a. k -> a -> Map k a
Map.singleton (PackageName
packageName PackageName -> [PackageName] -> NonEmpty 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 = (b, NonEmpty a) -> NonEmpty a
forall a b. (a, b) -> b
snd ((b, NonEmpty a) -> NonEmpty a) -> (b, NonEmpty a) -> NonEmpty a
forall a b. (a -> b) -> a -> b
$ ((b, NonEmpty a) -> a -> (b, NonEmpty a))
-> (b, NonEmpty a) -> [a] -> (b, NonEmpty a)
forall b a. (b -> a -> b) -> 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 a -> [a] -> NonEmpty a
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 b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< b
fX -> (b
fX, a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [])
| b
fMax b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
fX -> (b
fMax, a -> NonEmpty a -> NonEmpty a
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons a
x NonEmpty a
maxs)
| Bool
otherwise -> (b
fMax, NonEmpty a
maxs)