{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TemplateHaskell #-}
module Ormolu.Fixity
( FixityDirection (..),
FixityInfo (..),
FixityMap,
LazyFixityMap,
lookupFixity,
HackageInfo (..),
defaultStrategyThreshold,
defaultFixityInfo,
buildFixityMap,
buildFixityMap',
bootPackages,
packageToOps,
packageToPopularity,
)
where
import qualified Data.Aeson as A
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 (HasTrie, memo)
import Data.Semigroup (sconcat)
import Data.Set (Set)
import qualified Data.Set as Set
import Ormolu.Fixity.Internal
#if FIXITY_TH
import Control.Monad.IO.Class (MonadIO (liftIO))
import qualified Language.Haskell.TH.Syntax as TH
#else
import Data.FileEmbed (embedFile)
import Data.Maybe (fromJust)
#endif
packageToOps :: Map String FixityMap
packageToPopularity :: Map String Int
#if FIXITY_TH
HackageInfo Map String FixityMap
packageToOps Map String Int
packageToPopularity =
$( do
let path = "extract-hackage-info/hackage-info.json"
info <- liftIO $ either fail pure =<< A.eitherDecodeFileStrict' path
TH.lift (info :: HackageInfo)
)
#else
HackageInfo packageToOps packageToPopularity =
fromJust $ A.decodeStrict $(embedFile "extract-hackage-info/hackage-info.json")
#endif
bootPackages :: Set String
bootPackages :: Set String
bootPackages =
[String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList
[ String
"array",
String
"binary",
String
"bytestring",
String
"containers",
String
"deepseq",
String
"directory",
String
"exceptions",
String
"filepath",
String
"ghc-binary",
String
"mtl",
String
"parsec",
String
"process",
String
"stm",
String
"template-haskell",
String
"terminfo",
String
"text",
String
"time",
String
"transformers",
String
"unix",
String
"Win32"
]
defaultStrategyThreshold :: Float
defaultStrategyThreshold :: Float
defaultStrategyThreshold = Float
0.9
buildFixityMap ::
Float ->
Set String ->
LazyFixityMap
buildFixityMap :: Float -> Set String -> LazyFixityMap
buildFixityMap = Map String FixityMap
-> Map String Int
-> Set String
-> Float
-> Set String
-> LazyFixityMap
buildFixityMap' Map String FixityMap
packageToOps Map String Int
packageToPopularity Set String
bootPackages
buildFixityMap' ::
Map String FixityMap ->
Map String Int ->
Set String ->
Float ->
Set String ->
LazyFixityMap
buildFixityMap' :: Map String FixityMap
-> Map String Int
-> Set String
-> Float
-> Set String
-> LazyFixityMap
buildFixityMap'
Map String FixityMap
operatorMap
Map String Int
popularityMap
Set String
higherPriorityPackages
Float
strategyThreshold = (Set String -> LazyFixityMap) -> Set String -> LazyFixityMap
forall a v. (HasTrie a, Eq a) => (Set a -> v) -> Set a -> v
memoSet ((Set String -> LazyFixityMap) -> Set String -> LazyFixityMap)
-> (Set String -> LazyFixityMap) -> Set String -> LazyFixityMap
forall a b. (a -> b) -> a -> b
$ \Set String
dependencies ->
let baseFixityMap :: FixityMap
baseFixityMap =
String -> FixityInfo -> FixityMap -> FixityMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
":" 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
$
String -> Map String FixityMap -> Maybe FixityMap
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
"base" Map String FixityMap
operatorMap
cabalFixityMap :: FixityMap
cabalFixityMap =
[(String, FixityMap)] -> FixityMap
mergeAll (String -> (String, FixityMap)
buildPackageFixityMap (String -> (String, FixityMap))
-> [String] -> [(String, FixityMap)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
dependencies)
higherPriorityFixityMap :: FixityMap
higherPriorityFixityMap =
[(String, FixityMap)] -> FixityMap
mergeAll (String -> (String, FixityMap)
buildPackageFixityMap (String -> (String, FixityMap))
-> [String] -> [(String, FixityMap)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
higherPriorityPackages)
remainingFixityMap :: FixityMap
remainingFixityMap =
Map String Int -> Float -> [(String, FixityMap)] -> FixityMap
mergeFixityMaps
Map String Int
popularityMap
Float
strategyThreshold
(String -> (String, FixityMap)
buildPackageFixityMap (String -> (String, FixityMap))
-> [String] -> [(String, FixityMap)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
remainingPackages)
remainingPackages :: Set String
remainingPackages =
Map String FixityMap -> Set String
forall k a. Map k a -> Set k
Map.keysSet Map String FixityMap
operatorMap
Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set String
dependencies Set String
higherPriorityPackages
buildPackageFixityMap :: String -> (String, FixityMap)
buildPackageFixityMap String
packageName =
( String
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
$
String -> Map String FixityMap -> Maybe FixityMap
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
packageName Map String FixityMap
operatorMap
)
mergeAll :: [(String, FixityMap)] -> FixityMap
mergeAll = Map String Int -> Float -> [(String, FixityMap)] -> FixityMap
mergeFixityMaps Map String 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 :: (HasTrie a, Eq a) => (Set a -> v) -> Set a -> v
memoSet :: (Set a -> v) -> Set a -> v
memoSet Set a -> v
f = ([a] -> v) -> [a] -> v
forall t a. HasTrie t => (t -> a) -> t -> a
memo (Set a -> v
f (Set a -> v) -> ([a] -> Set a) -> [a] -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Set a
forall a. Eq a => [a] -> Set a
Set.fromAscList) ([a] -> v) -> (Set a -> [a]) -> Set a -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toAscList
mergeFixityMaps ::
Map String Int ->
Float ->
[(String, FixityMap)] ->
FixityMap
mergeFixityMaps :: Map String Int -> Float -> [(String, FixityMap)] -> FixityMap
mergeFixityMaps Map String Int
popularityMap Float
threshold [(String, FixityMap)]
packageMaps =
(Map FixityInfo Int -> FixityInfo)
-> Map String (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. [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 String (Map FixityInfo Int)
scoredMap
where
scoredMap :: Map String (Map FixityInfo Int)
scoredMap = (Map FixityInfo (NonEmpty String) -> Map FixityInfo Int)
-> Map String (Map FixityInfo (NonEmpty String))
-> Map String (Map FixityInfo Int)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Map FixityInfo (NonEmpty String) -> Map FixityInfo Int
getScores Map String (Map FixityInfo (NonEmpty String))
opFixityMap
opFixityMap :: Map String (Map FixityInfo (NonEmpty String))
opFixityMap =
(Map FixityInfo (NonEmpty String)
-> Map FixityInfo (NonEmpty String)
-> Map FixityInfo (NonEmpty String))
-> [Map String (Map FixityInfo (NonEmpty String))]
-> Map String (Map FixityInfo (NonEmpty String))
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith
((NonEmpty String -> NonEmpty String -> NonEmpty String)
-> Map FixityInfo (NonEmpty String)
-> Map FixityInfo (NonEmpty String)
-> Map FixityInfo (NonEmpty String)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith NonEmpty String -> NonEmpty String -> NonEmpty String
forall a. Semigroup a => a -> a -> a
(<>))
((String, FixityMap)
-> Map String (Map FixityInfo (NonEmpty String))
opFixityMapFrom ((String, FixityMap)
-> Map String (Map FixityInfo (NonEmpty String)))
-> [(String, FixityMap)]
-> [Map String (Map FixityInfo (NonEmpty String))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, 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 (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 (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 (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 String) ->
Map FixityInfo Int
getScores :: Map FixityInfo (NonEmpty String) -> Map FixityInfo Int
getScores =
(NonEmpty String -> Int)
-> Map FixityInfo (NonEmpty String) -> Map FixityInfo Int
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
(NonEmpty Int -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (NonEmpty Int -> Int)
-> (NonEmpty String -> NonEmpty Int) -> NonEmpty String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Int) -> NonEmpty String -> NonEmpty Int
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) -> (String -> Maybe Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Map String Int -> Maybe Int)
-> Map String Int -> String -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Map String Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map String Int
popularityMap))
opFixityMapFrom ::
(String, FixityMap) ->
Map String (Map FixityInfo (NonEmpty String))
opFixityMapFrom :: (String, FixityMap)
-> Map String (Map FixityInfo (NonEmpty String))
opFixityMapFrom (String
packageName, FixityMap
opsMap) =
(FixityInfo -> Map FixityInfo (NonEmpty String))
-> FixityMap -> Map String (Map FixityInfo (NonEmpty String))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
((FixityInfo -> NonEmpty String -> Map FixityInfo (NonEmpty String))
-> NonEmpty String
-> FixityInfo
-> Map FixityInfo (NonEmpty String)
forall a b c. (a -> b -> c) -> b -> a -> c
flip FixityInfo -> NonEmpty String -> Map FixityInfo (NonEmpty String)
forall k a. k -> a -> Map k a
Map.singleton (String
packageName String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| []))
FixityMap
opsMap
maxWith :: Ord b => (a -> b) -> NonEmpty a -> NonEmpty a
maxWith :: (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 (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)