{-# LANGUAGE CPP            #-}
{-# LANGUAGE NamedFieldPuns #-}

module Warn.Coercion where

#if __GLASGOW_HASKELL__ >= 900
import GHC.Core.Stats
import GHC.Plugins hiding ((<>))
import GHC.Utils.Ppr.Colour
#else
import CoreStats
import GhcPlugins hiding ((<>))
import PprColour
#endif

------------------------------------------------------------------------------
-- | Pretty print a "large number of coercions" warning.
pprWarnLargeCoerce :: [SrcSpan] -> CoreBndr -> CoreStats -> SDoc
pprWarnLargeCoerce :: [SrcSpan] -> CoreBndr -> CoreStats -> SDoc
pprWarnLargeCoerce refs :: [SrcSpan]
refs bind :: CoreBndr
bind stats :: CoreStats
stats =
  let srcSpanList :: [SDoc]
srcSpanList = if [SrcSpan] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SrcSpan]
refs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 3
                       then Int -> [SDoc] -> [SDoc]
forall a. Int -> [a] -> [a]
take 3 ((SDoc
bullet SDoc -> SDoc -> SDoc
<+>) (SDoc -> SDoc) -> (SrcSpan -> SDoc) -> SrcSpan -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SDoc) -> [SrcSpan] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SrcSpan]
refs) [SDoc] -> [SDoc] -> [SDoc]
forall a. Semigroup a => a -> a -> a
<> [String -> SDoc
text "..."]
                       else (SDoc
bullet SDoc -> SDoc -> SDoc
<+>) (SDoc -> SDoc) -> (SrcSpan -> SDoc) -> SrcSpan -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SDoc) -> [SrcSpan] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SrcSpan]
refs
      CS{..} = CoreStats
stats
   in [SDoc] -> SDoc
vcat [ String -> SDoc
text "Found a large number of coercions in GHC Core."
           , Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$  String -> SDoc
text " GHC produced a a quadratic number of coercions relative to the number of terms."
                    SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "This can happen for expensive type families that are used outside of phantom contexts."
           , SDoc
blankLine
           , [SDoc] -> SDoc
hsep [ String -> SDoc
text "These coercions were introduced in"
                 , PprColour -> SDoc -> SDoc
coloured PprColour
colBlueFg (SDoc -> SDoc) -> (CoreBndr -> SDoc) -> CoreBndr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OccName -> SDoc) -> (CoreBndr -> OccName) -> CoreBndr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> OccName
forall a. NamedThing a => a -> OccName
getOccName (CoreBndr -> SDoc) -> CoreBndr -> SDoc
forall a b. (a -> b) -> a -> b
$ CoreBndr
bind
                 , String -> SDoc
text "at these locations:"
                 ]
           , Int -> SDoc -> SDoc
nest 4 ([SDoc] -> SDoc
vcat [SDoc]
srcSpanList)
           , SDoc
blankLine
           , [SDoc] -> SDoc
sep [ String -> SDoc
text "Terms:",     PprColour -> SDoc -> SDoc
coloured PprColour
colBlueFg (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
cs_tm
                 , String -> SDoc
text "Types:",     PprColour -> SDoc -> SDoc
coloured PprColour
colBlueFg (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
cs_ty
                 , String -> SDoc
text "Coercions:", PprColour -> SDoc -> SDoc
coloured PprColour
colBlueFg (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
cs_co
                 ]
           , String -> SDoc
text ""
           ]


------------------------------------------------------------------------------
-- | Heuristic for whether we should show a "large number of coercions"
-- warning.
shouldWarnLargeCoercion :: CoreStats -> Bool
shouldWarnLargeCoercion :: CoreStats -> Bool
shouldWarnLargeCoercion CS {Int
cs_tm :: Int
cs_tm :: CoreStats -> Int
cs_tm, Int
cs_co :: Int
cs_co :: CoreStats -> Int
cs_co} =
  let quad :: Int
quad = Int
cs_tm Int -> Int -> Int
forall a. Num a => a -> a -> a
* Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase @Double 2 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cs_tm)
   in Int
cs_co Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
quad Bool -> Bool -> Bool
&& Int
cs_co Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 100