{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Definitions for fixity analysis.
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

-- | 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 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"
    ]

-- | 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 :: Float
defaultStrategyThreshold = Float
0.9

-- | 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
  Set String ->
  -- | Resulting map
  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

-- | 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 String FixityMap ->
  -- | Map from package to popularity
  Map String Int ->
  -- | Higher priority packages
  Set String ->
  -- | 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 String ->
  -- | Resulting map
  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
          )
        -- we need a threshold > 1.0 so that no dependency can reach the
        -- threshold
        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

-- | 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 String Int ->
  -- | Popularity ratio threshold
  Float ->
  -- | List of (package name, package fixity map) to merge
  [(String, FixityMap)] ->
  -- | Resulting fixity map
  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
    -- 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 String))
    -- 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 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 ::
      -- 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 :: 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 -- merge potential ex-aequo winners
        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 for a given operator associating each of its conflicting
      -- definitions with the packages that define it
      Map FixityInfo (NonEmpty String) ->
      -- 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 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 ::
      -- (packageName, package fixity map)
      (String, 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 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)