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

-- | Definitions for fixity analysis.
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 =
  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
-- The GHC WASM backend does not yet support Template Haskell, so we instead
-- pass in the encoded fixity DB at runtime by storing the pointer and length of
-- the bytes in an environment variable.
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

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

-- | 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 PackageName ->
  -- | Resulting map
  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

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

-- | 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 PackageName Int ->
  -- | Popularity ratio threshold
  Float ->
  -- | List of (package name, package fixity map) to merge
  [(PackageName, FixityMap)] ->
  -- | Resulting fixity map
  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
    -- 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 PackageName))
    -- 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 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 ::
      -- 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 PackageName) ->
      -- 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 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, package fixity map)
      (PackageName, 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 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)