{-# LANGUAGE CPP #-}

#if __GLASGOW_HASKELL__ >= 900
#define FUNTYARG _ _
#elif __GLASGOW_HASKELL__ == 810
#define FUNTYARG _
#else
#define FUNTYARG
#endif

module Warn.Dictionary where

import Data.Foldable
import Data.Generics.Aliases
import Data.Generics.Schemes
import Data.Map (Map)
import Data.Ord
import Data.Set (Set)
import qualified Data.Set as Set

#if __GLASGOW_HASKELL__ >= 900
import GHC.Plugins hiding ((<>))
import GHC.Tc.Utils.TcType (tcSplitNestedSigmaTys)
import GHC.Core.TyCo.Rep
import GHC.Utils.Ppr.Colour
#else
import GhcPlugins hiding ((<>))
import TcType (tcSplitNestedSigmaTys)
import TyCoRep
import PprColour
#endif


------------------------------------------------------------------------------
-- | Build an adjacency map from core bindings to the core bindings they
-- reference.
mkCoreAdjacencyMap :: Map CoreBndr CoreExpr -> Map CoreBndr (Set CoreBndr)
mkCoreAdjacencyMap :: Map CoreBndr CoreExpr -> Map CoreBndr (Set CoreBndr)
mkCoreAdjacencyMap = (CoreExpr -> Set CoreBndr)
-> Map CoreBndr CoreExpr -> Map CoreBndr (Set CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> Set CoreBndr)
 -> Map CoreBndr CoreExpr -> Map CoreBndr (Set CoreBndr))
-> (CoreExpr -> Set CoreBndr)
-> Map CoreBndr CoreExpr
-> Map CoreBndr (Set CoreBndr)
forall a b. (a -> b) -> a -> b
$ (Set CoreBndr -> Set CoreBndr -> Set CoreBndr)
-> GenericQ (Set CoreBndr) -> GenericQ (Set CoreBndr)
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything Set CoreBndr -> Set CoreBndr -> Set CoreBndr
forall a. Monoid a => a -> a -> a
mappend (Set CoreBndr -> (CoreBndr -> Set CoreBndr) -> a -> Set CoreBndr
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Set CoreBndr
forall a. Monoid a => a
mempty CoreBndr -> Set CoreBndr
forall a. a -> Set a
Set.singleton)


------------------------------------------------------------------------------
-- | Get the biggest type (via 'typeSizeWithoutKinds') in a set.
biggestType :: Set CoreBndr -> Type
biggestType :: Set CoreBndr -> Type
biggestType = Type -> Type
rhsType (Type -> Type) -> (Set CoreBndr -> Type) -> Set CoreBndr -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Type
idType (CoreBndr -> Type)
-> (Set CoreBndr -> CoreBndr) -> Set CoreBndr -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBndr -> CoreBndr -> Ordering) -> Set CoreBndr -> CoreBndr
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((CoreBndr -> Int) -> CoreBndr -> CoreBndr -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Type -> Int
typeSizeWithoutKinds (Type -> Int) -> (CoreBndr -> Type) -> CoreBndr -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
rhsType (Type -> Type) -> (CoreBndr -> Type) -> CoreBndr -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Type
idType))


------------------------------------------------------------------------------
-- | Remove the forall quantifiers and contexts from a type.
rhsType :: Type -> Type
rhsType :: Type -> Type
rhsType ty :: Type
ty =
  case Type -> ([CoreBndr], ThetaType, Type)
tcSplitNestedSigmaTys Type
ty of
    (_, _, ty' :: Type
ty') -> Type
ty'


------------------------------------------------------------------------------
-- | Heuristic for whether we should show the "deep dicts" warning.
shouldWarnDeepDict :: Set CoreBndr -> Bool
shouldWarnDeepDict :: Set CoreBndr -> Bool
shouldWarnDeepDict coreBndrs :: Set CoreBndr
coreBndrs =
  let amountOfCoreBndrs :: Int
amountOfCoreBndrs = Set CoreBndr -> Int
forall a. Set a -> Int
Set.size Set CoreBndr
coreBndrs
      biggestTypeSize :: Int
biggestTypeSize = Type -> Int
typeSizeWithoutKinds (Set CoreBndr -> Type
biggestType Set CoreBndr
coreBndrs)
   in Int
biggestTypeSize Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
amountOfCoreBndrs
        Bool -> Bool -> Bool
&& Int
amountOfCoreBndrs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 4


------------------------------------------------------------------------------
-- | Pretty print a "deep dicts" warning.
pprDeepDict :: [SrcSpan] -> Set CoreBndr -> SDoc
pprDeepDict :: [SrcSpan] -> Set CoreBndr -> SDoc
pprDeepDict goodSpans :: [SrcSpan]
goodSpans vars :: Set CoreBndr
vars =
  let srcSpanList :: [SDoc]
srcSpanList = if [SrcSpan] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SrcSpan]
goodSpans 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]
goodSpans) [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]
goodSpans
   in [SDoc] -> SDoc
vcat [ String -> SDoc
text "Found a large chain of dictionaries produced in GHC Core."
           , Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$  String -> SDoc
text "A big instance chain that is generating a linear amount of core dictionaries."
                    SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "This is probably caused by instance induction on an unbalanced structure (like a type-level list)."
                    SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "Consider using a balanced structure (like a type-level tree)."
           , SDoc
blankLine
           , String -> SDoc
text "Arising from:"
           , Int -> SDoc -> SDoc
nest 4 ([SDoc] -> SDoc
vcat [SDoc]
srcSpanList)
           , SDoc
blankLine
           , String -> SDoc
text "Biggest dictionary: " SDoc -> SDoc -> SDoc
<+> PprColour -> SDoc -> SDoc
coloured PprColour
colBlueFg (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> SDoc) -> Type -> SDoc
forall a b. (a -> b) -> a -> b
$ Set CoreBndr -> Type
biggestType Set CoreBndr
vars)
           , String -> SDoc
text "Size of type: " SDoc -> SDoc -> SDoc
<+> PprColour -> SDoc -> SDoc
coloured PprColour
colBlueFg (Int -> SDoc
int (Int -> SDoc) -> Int -> SDoc
forall a b. (a -> b) -> a -> b
$ Type -> Int
typeSizeWithoutKinds (Type -> Int) -> Type -> Int
forall a b. (a -> b) -> a -> b
$ Set CoreBndr -> Type
biggestType Set CoreBndr
vars)
           , String -> SDoc
text "Number of dictionaries: " SDoc -> SDoc -> SDoc
<+> PprColour -> SDoc -> SDoc
coloured PprColour
colBlueFg (Int -> SDoc
int (Int -> SDoc) -> Int -> SDoc
forall a b. (a -> b) -> a -> b
$ Set CoreBndr -> Int
forall a. Set a -> Int
Set.size Set CoreBndr
vars)
           , SDoc
blankLine
           ]


------------------------------------------------------------------------------
-- | Attempts to measure "how big" a type is. We count terminal type
-- constructors, and type literals as 1. Kinds are right out. Chosen so that
-- @'[1, 2, 3, 4]@ has size 4.
typeSizeWithoutKinds :: Type -> Int
typeSizeWithoutKinds :: Type -> Int
typeSizeWithoutKinds LitTy {} = 1
typeSizeWithoutKinds TyVarTy {} = 1
typeSizeWithoutKinds (AppTy t1 :: Type
t1 t2 :: Type
t2) = Type -> Int
typeSizeWithoutKinds Type
t1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type -> Int
typeSizeWithoutKinds Type
t2
typeSizeWithoutKinds (FunTy FUNTYARG t1 t2) = typeSizeWithoutKinds t1 + typeSizeWithoutKinds t2
typeSizeWithoutKinds (ForAllTy (Bndr tv :: CoreBndr
tv _) t :: Type
t) = Type -> Int
typeSizeWithoutKinds (CoreBndr -> Type
varType CoreBndr
tv) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type -> Int
typeSizeWithoutKinds Type
t
typeSizeWithoutKinds (TyConApp tc :: TyCon
tc []) =
  let (kind_vars :: [CoreBndr]
kind_vars, _, _) = Type -> ([CoreBndr], ThetaType, Type)
tcSplitNestedSigmaTys (Type -> ([CoreBndr], ThetaType, Type))
-> Type -> ([CoreBndr], ThetaType, Type)
forall a b. (a -> b) -> a -> b
$ TyCon -> Type
tyConKind TyCon
tc
   in 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [CoreBndr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreBndr]
kind_vars
typeSizeWithoutKinds (TyConApp tc :: TyCon
tc ts :: ThetaType
ts) =
  let (kind_vars :: [CoreBndr]
kind_vars, _, _) = Type -> ([CoreBndr], ThetaType, Type)
tcSplitNestedSigmaTys (Type -> ([CoreBndr], ThetaType, Type))
-> Type -> ([CoreBndr], ThetaType, Type)
forall a b. (a -> b) -> a -> b
$ TyCon -> Type
tyConKind TyCon
tc
   in [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Type -> Int) -> ThetaType -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Int
typeSizeWithoutKinds ThetaType
ts) Int -> Int -> Int
forall a. Num a => a -> a -> a
- [CoreBndr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreBndr]
kind_vars
typeSizeWithoutKinds (CastTy ty :: Type
ty _) = Type -> Int
typeSizeWithoutKinds Type
ty
typeSizeWithoutKinds (CoercionTy _) = 0