{-# 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 =
  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 = forall a v. (HasTrie a, Eq a) => (Set a -> v) -> Set a -> v
memoSet forall a b. (a -> b) -> a -> b
$ \Set String
dependencies ->
    let baseFixityMap :: FixityMap
baseFixityMap =
          forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
":" 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 String
"base" Map String FixityMap
operatorMap
        cabalFixityMap :: FixityMap
cabalFixityMap =
          [(String, FixityMap)] -> FixityMap
mergeAll (String -> (String, FixityMap)
buildPackageFixityMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList Set String
dependencies)
        higherPriorityFixityMap :: FixityMap
higherPriorityFixityMap =
          [(String, FixityMap)] -> FixityMap
mergeAll (String -> (String, FixityMap)
buildPackageFixityMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList Set String
remainingPackages)
        remainingPackages :: Set String
remainingPackages =
          forall k a. Map k a -> Set k
Map.keysSet Map String 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 String
dependencies Set String
higherPriorityPackages
        buildPackageFixityMap :: String -> (String, FixityMap)
buildPackageFixityMap String
packageName =
          ( String
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 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 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 :: forall a v. (HasTrie a, Eq a) => (Set a -> v) -> Set a -> v
memoSet Set a -> v
f = forall t a. HasTrie t => (t -> a) -> t -> a
memo (Set a -> 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 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 =
  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 String (Map FixityInfo Int)
scoredMap
  where
    scoredMap :: Map String (Map FixityInfo Int)
scoredMap = 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 =
      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
(<>))
        ((String, FixityMap)
-> Map String (Map FixityInfo (NonEmpty String))
opFixityMapFrom 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 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 -- merge potential ex-aequo winners
        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 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 =
      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 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) =
      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 (String
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)