packages feed

ghc-lib-parser 0.20200301 → 0.20200401

raw patch · 253 files changed

+49709/−49530 lines, 253 files

Files

compiler/GHC/ByteCode/Types.hs view
@@ -16,14 +16,14 @@ import GhcPrelude  import FastString-import Id-import Name-import NameEnv+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Name.Env import Outputable import PrimOp import SizedSeq-import Type-import SrcLoc+import GHC.Core.Type+import GHC.Types.SrcLoc import GHCi.BreakArray import GHCi.RemoteTypes import GHCi.FFI
compiler/GHC/Cmm.hs view
@@ -26,8 +26,8 @@  import GhcPrelude -import Id-import CostCentre+import GHC.Types.Id+import GHC.Types.CostCentre import GHC.Cmm.CLabel import GHC.Cmm.BlockId import GHC.Cmm.Node
compiler/GHC/Cmm/BlockId.hs view
@@ -11,10 +11,10 @@ import GhcPrelude  import GHC.Cmm.CLabel-import IdInfo-import Name-import Unique-import UniqSupply+import GHC.Types.Id.Info+import GHC.Types.Name+import GHC.Types.Unique+import GHC.Types.Unique.Supply  import GHC.Cmm.Dataflow.Label (Label, mkHooplLabel)
compiler/GHC/Cmm/BlockId.hs-boot view
@@ -1,7 +1,7 @@ module GHC.Cmm.BlockId (BlockId, mkBlockId) where  import GHC.Cmm.Dataflow.Label (Label)-import Unique (Unique)+import GHC.Types.Unique (Unique)  type BlockId = Label
compiler/GHC/Cmm/CLabel.hs view
@@ -115,20 +115,20 @@  import GhcPrelude -import IdInfo-import BasicTypes+import GHC.Types.Id.Info+import GHC.Types.Basic import {-# SOURCE #-} GHC.Cmm.BlockId (BlockId, mkBlockId) import GHC.Driver.Packages-import Module-import Name-import Unique+import GHC.Types.Module+import GHC.Types.Name+import GHC.Types.Unique import PrimOp-import CostCentre+import GHC.Types.CostCentre import Outputable import FastString import GHC.Driver.Session import GHC.Platform-import UniqSet+import GHC.Types.Unique.Set import Util import GHC.Core.Ppr ( {- instances -} ) @@ -1029,7 +1029,7 @@      externalDynamicRefs && (this_pkg /= rtsUnitId)     IdLabel n _ _ ->-     isDllName dflags this_mod n+     isDynLinkName dflags this_mod n     -- When compiling in the "dyn" way, each package is to be linked into    -- its own shared library.@@ -1355,18 +1355,18 @@ internalNamePrefix :: Name -> SDoc internalNamePrefix name = getPprStyle $ \ sty ->   if asmStyle sty && isRandomGenerated then-    sdocWithPlatform $ \platform ->-      ptext (asmTempLabelPrefix platform)+    sdocWithDynFlags $ \dflags ->+      ptext (asmTempLabelPrefix (targetPlatform dflags))   else     empty   where     isRandomGenerated = not $ isExternalName name  tempLabelPrefixOrUnderscore :: SDoc-tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform ->+tempLabelPrefixOrUnderscore = sdocWithDynFlags $ \dflags ->   getPprStyle $ \ sty ->    if asmStyle sty then-      ptext (asmTempLabelPrefix platform)+      ptext (asmTempLabelPrefix (targetPlatform dflags))    else       char '_'
compiler/GHC/Cmm/Dataflow/Block.hs view
@@ -66,13 +66,7 @@   JustO    :: t -> MaybeO O t   NothingO ::      MaybeO C t --- | Maybe type indexed by closed/open-data MaybeC ex t where-  JustC    :: t -> MaybeC C t-  NothingC ::      MaybeC O t- deriving instance Functor (MaybeO ex)-deriving instance Functor (MaybeC ex)  -- ----------------------------------------------------------------------------- -- The Block type
compiler/GHC/Cmm/Dataflow/Label.hs view
@@ -20,7 +20,7 @@ -- TODO: This should really just use GHC's Unique and Uniq{Set,FM} import GHC.Cmm.Dataflow.Collections -import Unique (Uniquable(..))+import GHC.Types.Unique (Uniquable(..)) import TrieMap
compiler/GHC/Cmm/Expr.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -32,18 +33,19 @@  import GhcPrelude +import GHC.Platform import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm.MachOp import GHC.Cmm.Type import GHC.Driver.Session import Outputable (panic)-import Unique+import GHC.Types.Unique  import Data.Set (Set) import qualified Data.Set as Set -import BasicTypes (Alignment, mkAlignment, alignmentOf)+import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf)  ----------------------------------------------------------------------------- --              CmmExpr@@ -209,37 +211,39 @@                      -- of bytes used   deriving Eq -cmmExprType :: DynFlags -> CmmExpr -> CmmType-cmmExprType dflags (CmmLit lit)        = cmmLitType dflags lit-cmmExprType _      (CmmLoad _ rep)     = rep-cmmExprType dflags (CmmReg reg)        = cmmRegType dflags reg-cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args)-cmmExprType dflags (CmmRegOff reg _)   = cmmRegType dflags reg-cmmExprType dflags (CmmStackSlot _ _)  = bWord dflags -- an address--- Careful though: what is stored at the stack slot may be bigger than--- an address+cmmExprType :: Platform -> CmmExpr -> CmmType+cmmExprType platform = \case+   (CmmLit lit)        -> cmmLitType platform lit+   (CmmLoad _ rep)     -> rep+   (CmmReg reg)        -> cmmRegType platform reg+   (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args)+   (CmmRegOff reg _)   -> cmmRegType platform reg+   (CmmStackSlot _ _)  -> bWord platform -- an address+   -- Careful though: what is stored at the stack slot may be bigger than+   -- an address -cmmLitType :: DynFlags -> CmmLit -> CmmType-cmmLitType _      (CmmInt _ width)     = cmmBits  width-cmmLitType _      (CmmFloat _ width)   = cmmFloat width-cmmLitType _      (CmmVec [])          = panic "cmmLitType: CmmVec []"-cmmLitType cflags (CmmVec (l:ls))      = let ty = cmmLitType cflags l-                                         in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls)-                                            then cmmVec (1+length ls) ty-                                            else panic "cmmLitType: CmmVec"-cmmLitType dflags (CmmLabel lbl)       = cmmLabelType dflags lbl-cmmLitType dflags (CmmLabelOff lbl _)  = cmmLabelType dflags lbl-cmmLitType _      (CmmLabelDiffOff _ _ _ width) = cmmBits width-cmmLitType dflags (CmmBlock _)         = bWord dflags-cmmLitType dflags (CmmHighStackMark)   = bWord dflags+cmmLitType :: Platform -> CmmLit -> CmmType+cmmLitType platform = \case+   (CmmInt _ width)     -> cmmBits  width+   (CmmFloat _ width)   -> cmmFloat width+   (CmmVec [])          -> panic "cmmLitType: CmmVec []"+   (CmmVec (l:ls))      -> let ty = cmmLitType platform l+                          in if all (`cmmEqType` ty) (map (cmmLitType platform) ls)+                               then cmmVec (1+length ls) ty+                               else panic "cmmLitType: CmmVec"+   (CmmLabel lbl)       -> cmmLabelType platform lbl+   (CmmLabelOff lbl _)  -> cmmLabelType platform lbl+   (CmmLabelDiffOff _ _ _ width) -> cmmBits width+   (CmmBlock _)         -> bWord platform+   (CmmHighStackMark)   -> bWord platform -cmmLabelType :: DynFlags -> CLabel -> CmmType-cmmLabelType dflags lbl- | isGcPtrLabel lbl = gcWord dflags- | otherwise        = bWord dflags+cmmLabelType :: Platform -> CLabel -> CmmType+cmmLabelType platform lbl+ | isGcPtrLabel lbl = gcWord platform+ | otherwise        = bWord platform -cmmExprWidth :: DynFlags -> CmmExpr -> Width-cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)+cmmExprWidth :: Platform -> CmmExpr -> Width+cmmExprWidth platform e = typeWidth (cmmExprType platform e)  -- | Returns an alignment in bytes of a CmmExpr when it's a statically -- known integer constant, otherwise returns an alignment of 1 byte.@@ -278,12 +282,12 @@ instance Uniquable LocalReg where   getUnique (LocalReg uniq _) = uniq -cmmRegType :: DynFlags -> CmmReg -> CmmType-cmmRegType _      (CmmLocal  reg) = localRegType reg-cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg+cmmRegType :: Platform -> CmmReg -> CmmType+cmmRegType _        (CmmLocal  reg) = localRegType reg+cmmRegType platform (CmmGlobal reg) = globalRegType platform reg -cmmRegWidth :: DynFlags -> CmmReg -> Width-cmmRegWidth dflags = typeWidth . cmmRegType dflags+cmmRegWidth :: Platform -> CmmReg -> Width+cmmRegWidth platform = typeWidth . cmmRegType platform  localRegType :: LocalReg -> CmmType localRegType (LocalReg _ rep) = rep@@ -590,23 +594,23 @@ node :: GlobalReg node = VanillaReg 1 VGcPtr -globalRegType :: DynFlags -> GlobalReg -> CmmType-globalRegType dflags (VanillaReg _ VGcPtr)    = gcWord dflags-globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags-globalRegType _      (FloatReg _)      = cmmFloat W32-globalRegType _      (DoubleReg _)     = cmmFloat W64-globalRegType _      (LongReg _)       = cmmBits W64--- TODO: improve the internal model of SIMD/vectorized registers--- the right design SHOULd improve handling of float and double code too.--- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim-globalRegType _      (XmmReg _)        = cmmVec 4 (cmmBits W32)-globalRegType _      (YmmReg _)        = cmmVec 8 (cmmBits W32)-globalRegType _      (ZmmReg _)        = cmmVec 16 (cmmBits W32)+globalRegType :: Platform -> GlobalReg -> CmmType+globalRegType platform = \case+   (VanillaReg _ VGcPtr)    -> gcWord platform+   (VanillaReg _ VNonGcPtr) -> bWord platform+   (FloatReg _)             -> cmmFloat W32+   (DoubleReg _)            -> cmmFloat W64+   (LongReg _)              -> cmmBits W64+   -- TODO: improve the internal model of SIMD/vectorized registers+   -- the right design SHOULd improve handling of float and double code too.+   -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim+   (XmmReg _) -> cmmVec 4 (cmmBits W32)+   (YmmReg _) -> cmmVec 8 (cmmBits W32)+   (ZmmReg _) -> cmmVec 16 (cmmBits W32) -globalRegType dflags Hp                = gcWord dflags-                                            -- The initialiser for all-                                            -- dynamically allocated closures-globalRegType dflags _                 = bWord dflags+   Hp         -> gcWord platform -- The initialiser for all+                                 -- dynamically allocated closures+   _          -> bWord platform  isArgReg :: GlobalReg -> Bool isArgReg (VanillaReg {}) = True
compiler/GHC/Cmm/MachOp.hs view
@@ -30,9 +30,9 @@  import GhcPrelude +import GHC.Platform import GHC.Cmm.Type import Outputable-import GHC.Driver.Session  ----------------------------------------------------------------------------- --              MachOp@@ -172,60 +172,60 @@     , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr     , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord     , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64-    :: DynFlags -> MachOp+    :: Platform -> MachOp  mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32     , mo_32To8, mo_32To16     :: MachOp -mo_wordAdd      dflags = MO_Add (wordWidth dflags)-mo_wordSub      dflags = MO_Sub (wordWidth dflags)-mo_wordEq       dflags = MO_Eq  (wordWidth dflags)-mo_wordNe       dflags = MO_Ne  (wordWidth dflags)-mo_wordMul      dflags = MO_Mul (wordWidth dflags)-mo_wordSQuot    dflags = MO_S_Quot (wordWidth dflags)-mo_wordSRem     dflags = MO_S_Rem (wordWidth dflags)-mo_wordSNeg     dflags = MO_S_Neg (wordWidth dflags)-mo_wordUQuot    dflags = MO_U_Quot (wordWidth dflags)-mo_wordURem     dflags = MO_U_Rem (wordWidth dflags)+mo_wordAdd      platform = MO_Add (wordWidth platform)+mo_wordSub      platform = MO_Sub (wordWidth platform)+mo_wordEq       platform = MO_Eq  (wordWidth platform)+mo_wordNe       platform = MO_Ne  (wordWidth platform)+mo_wordMul      platform = MO_Mul (wordWidth platform)+mo_wordSQuot    platform = MO_S_Quot (wordWidth platform)+mo_wordSRem     platform = MO_S_Rem (wordWidth platform)+mo_wordSNeg     platform = MO_S_Neg (wordWidth platform)+mo_wordUQuot    platform = MO_U_Quot (wordWidth platform)+mo_wordURem     platform = MO_U_Rem (wordWidth platform) -mo_wordSGe      dflags = MO_S_Ge  (wordWidth dflags)-mo_wordSLe      dflags = MO_S_Le  (wordWidth dflags)-mo_wordSGt      dflags = MO_S_Gt  (wordWidth dflags)-mo_wordSLt      dflags = MO_S_Lt  (wordWidth dflags)+mo_wordSGe      platform = MO_S_Ge  (wordWidth platform)+mo_wordSLe      platform = MO_S_Le  (wordWidth platform)+mo_wordSGt      platform = MO_S_Gt  (wordWidth platform)+mo_wordSLt      platform = MO_S_Lt  (wordWidth platform) -mo_wordUGe      dflags = MO_U_Ge  (wordWidth dflags)-mo_wordULe      dflags = MO_U_Le  (wordWidth dflags)-mo_wordUGt      dflags = MO_U_Gt  (wordWidth dflags)-mo_wordULt      dflags = MO_U_Lt  (wordWidth dflags)+mo_wordUGe      platform = MO_U_Ge  (wordWidth platform)+mo_wordULe      platform = MO_U_Le  (wordWidth platform)+mo_wordUGt      platform = MO_U_Gt  (wordWidth platform)+mo_wordULt      platform = MO_U_Lt  (wordWidth platform) -mo_wordAnd      dflags = MO_And (wordWidth dflags)-mo_wordOr       dflags = MO_Or  (wordWidth dflags)-mo_wordXor      dflags = MO_Xor (wordWidth dflags)-mo_wordNot      dflags = MO_Not (wordWidth dflags)-mo_wordShl      dflags = MO_Shl (wordWidth dflags)-mo_wordSShr     dflags = MO_S_Shr (wordWidth dflags)-mo_wordUShr     dflags = MO_U_Shr (wordWidth dflags)+mo_wordAnd      platform = MO_And (wordWidth platform)+mo_wordOr       platform = MO_Or  (wordWidth platform)+mo_wordXor      platform = MO_Xor (wordWidth platform)+mo_wordNot      platform = MO_Not (wordWidth platform)+mo_wordShl      platform = MO_Shl (wordWidth platform)+mo_wordSShr     platform = MO_S_Shr (wordWidth platform)+mo_wordUShr     platform = MO_U_Shr (wordWidth platform) -mo_u_8To32             = MO_UU_Conv W8 W32-mo_s_8To32             = MO_SS_Conv W8 W32-mo_u_16To32            = MO_UU_Conv W16 W32-mo_s_16To32            = MO_SS_Conv W16 W32+mo_u_8To32               = MO_UU_Conv W8 W32+mo_s_8To32               = MO_SS_Conv W8 W32+mo_u_16To32              = MO_UU_Conv W16 W32+mo_s_16To32              = MO_SS_Conv W16 W32 -mo_u_8ToWord    dflags = MO_UU_Conv W8  (wordWidth dflags)-mo_s_8ToWord    dflags = MO_SS_Conv W8  (wordWidth dflags)-mo_u_16ToWord   dflags = MO_UU_Conv W16 (wordWidth dflags)-mo_s_16ToWord   dflags = MO_SS_Conv W16 (wordWidth dflags)-mo_s_32ToWord   dflags = MO_SS_Conv W32 (wordWidth dflags)-mo_u_32ToWord   dflags = MO_UU_Conv W32 (wordWidth dflags)+mo_u_8ToWord    platform = MO_UU_Conv W8  (wordWidth platform)+mo_s_8ToWord    platform = MO_SS_Conv W8  (wordWidth platform)+mo_u_16ToWord   platform = MO_UU_Conv W16 (wordWidth platform)+mo_s_16ToWord   platform = MO_SS_Conv W16 (wordWidth platform)+mo_s_32ToWord   platform = MO_SS_Conv W32 (wordWidth platform)+mo_u_32ToWord   platform = MO_UU_Conv W32 (wordWidth platform) -mo_WordTo8      dflags = MO_UU_Conv (wordWidth dflags) W8-mo_WordTo16     dflags = MO_UU_Conv (wordWidth dflags) W16-mo_WordTo32     dflags = MO_UU_Conv (wordWidth dflags) W32-mo_WordTo64     dflags = MO_UU_Conv (wordWidth dflags) W64+mo_WordTo8      platform = MO_UU_Conv (wordWidth platform) W8+mo_WordTo16     platform = MO_UU_Conv (wordWidth platform) W16+mo_WordTo32     platform = MO_UU_Conv (wordWidth platform) W32+mo_WordTo64     platform = MO_UU_Conv (wordWidth platform) W64 -mo_32To8               = MO_UU_Conv W32 W8-mo_32To16              = MO_UU_Conv W32 W16+mo_32To8                 = MO_UU_Conv W32 W8+mo_32To16                = MO_UU_Conv W32 W16   -- ----------------------------------------------------------------------------@@ -365,8 +365,8 @@ {- | Returns the MachRep of the result of a MachOp. -}-machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType-machOpResultType dflags mop tys =+machOpResultType :: Platform -> MachOp -> [CmmType] -> CmmType+machOpResultType platform mop tys =   case mop of     MO_Add {}           -> ty1  -- Preserve GC-ptr-hood     MO_Sub {}           -> ty1  -- of first arg@@ -379,29 +379,29 @@     MO_U_Quot r         -> cmmBits r     MO_U_Rem  r         -> cmmBits r -    MO_Eq {}            -> comparisonResultRep dflags-    MO_Ne {}            -> comparisonResultRep dflags-    MO_S_Ge {}          -> comparisonResultRep dflags-    MO_S_Le {}          -> comparisonResultRep dflags-    MO_S_Gt {}          -> comparisonResultRep dflags-    MO_S_Lt {}          -> comparisonResultRep dflags+    MO_Eq {}            -> comparisonResultRep platform+    MO_Ne {}            -> comparisonResultRep platform+    MO_S_Ge {}          -> comparisonResultRep platform+    MO_S_Le {}          -> comparisonResultRep platform+    MO_S_Gt {}          -> comparisonResultRep platform+    MO_S_Lt {}          -> comparisonResultRep platform -    MO_U_Ge {}          -> comparisonResultRep dflags-    MO_U_Le {}          -> comparisonResultRep dflags-    MO_U_Gt {}          -> comparisonResultRep dflags-    MO_U_Lt {}          -> comparisonResultRep dflags+    MO_U_Ge {}          -> comparisonResultRep platform+    MO_U_Le {}          -> comparisonResultRep platform+    MO_U_Gt {}          -> comparisonResultRep platform+    MO_U_Lt {}          -> comparisonResultRep platform      MO_F_Add r          -> cmmFloat r     MO_F_Sub r          -> cmmFloat r     MO_F_Mul r          -> cmmFloat r     MO_F_Quot r         -> cmmFloat r     MO_F_Neg r          -> cmmFloat r-    MO_F_Eq  {}         -> comparisonResultRep dflags-    MO_F_Ne  {}         -> comparisonResultRep dflags-    MO_F_Ge  {}         -> comparisonResultRep dflags-    MO_F_Le  {}         -> comparisonResultRep dflags-    MO_F_Gt  {}         -> comparisonResultRep dflags-    MO_F_Lt  {}         -> comparisonResultRep dflags+    MO_F_Eq  {}         -> comparisonResultRep platform+    MO_F_Ne  {}         -> comparisonResultRep platform+    MO_F_Ge  {}         -> comparisonResultRep platform+    MO_F_Le  {}         -> comparisonResultRep platform+    MO_F_Gt  {}         -> comparisonResultRep platform+    MO_F_Lt  {}         -> comparisonResultRep platform      MO_And {}           -> ty1  -- Used for pointer masking     MO_Or {}            -> ty1@@ -445,7 +445,7 @@   where     (ty1:_) = tys -comparisonResultRep :: DynFlags -> CmmType+comparisonResultRep :: Platform -> CmmType comparisonResultRep = bWord  -- is it?  @@ -457,8 +457,8 @@ -- its arguments are the same as the MachOp expects.  This is used when -- linting a CmmExpr. -machOpArgReps :: DynFlags -> MachOp -> [Width]-machOpArgReps dflags op =+machOpArgReps :: Platform -> MachOp -> [Width]+machOpArgReps platform op =   case op of     MO_Add    r         -> [r,r]     MO_Sub    r         -> [r,r]@@ -499,9 +499,9 @@     MO_Or    r          -> [r,r]     MO_Xor   r          -> [r,r]     MO_Not   r          -> [r]-    MO_Shl   r          -> [r, wordWidth dflags]-    MO_U_Shr r          -> [r, wordWidth dflags]-    MO_S_Shr r          -> [r, wordWidth dflags]+    MO_Shl   r          -> [r, wordWidth platform]+    MO_U_Shr r          -> [r, wordWidth platform]+    MO_S_Shr r          -> [r, wordWidth platform]      MO_SS_Conv from _   -> [from]     MO_UU_Conv from _   -> [from]@@ -510,8 +510,8 @@     MO_FS_Conv from _   -> [from]     MO_FF_Conv from _   -> [from] -    MO_V_Insert  l r    -> [typeWidth (vec l (cmmBits r)),r,wordWidth dflags]-    MO_V_Extract l r    -> [typeWidth (vec l (cmmBits r)),wordWidth dflags]+    MO_V_Insert  l r    -> [typeWidth (vec l (cmmBits r)),r,wordWidth platform]+    MO_V_Extract l r    -> [typeWidth (vec l (cmmBits r)),wordWidth platform]      MO_V_Add _ r        -> [r,r]     MO_V_Sub _ r        -> [r,r]@@ -524,8 +524,8 @@     MO_VU_Quot _ r      -> [r,r]     MO_VU_Rem  _ r      -> [r,r] -    MO_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags]-    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags]+    MO_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,wordWidth platform]+    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),wordWidth platform]      MO_VF_Add  _ r      -> [r,r]     MO_VF_Sub  _ r      -> [r,r]
compiler/GHC/Cmm/Node.hs view
@@ -33,11 +33,11 @@ import GHC.Cmm.Switch import GHC.Driver.Session import FastString-import ForeignCall+import GHC.Types.ForeignCall import Outputable import GHC.Runtime.Heap.Layout import GHC.Core (Tickish)-import qualified Unique as U+import qualified GHC.Types.Unique as U  import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph@@ -45,7 +45,7 @@ import GHC.Cmm.Dataflow.Label import Data.Maybe import Data.List (tails,sortBy)-import Unique (nonDetCmpUnique)+import GHC.Types.Unique (nonDetCmpUnique) import Util
compiler/GHC/Cmm/Type.hs view
@@ -31,6 +31,7 @@  import GhcPrelude +import GHC.Platform import GHC.Driver.Session import FastString import Outputable@@ -120,14 +121,14 @@ f64    = cmmFloat W64  -- CmmTypes of native word widths-bWord :: DynFlags -> CmmType-bWord dflags = cmmBits (wordWidth dflags)+bWord :: Platform -> CmmType+bWord platform = cmmBits (wordWidth platform) -bHalfWord :: DynFlags -> CmmType-bHalfWord dflags = cmmBits (halfWordWidth dflags)+bHalfWord :: Platform -> CmmType+bHalfWord platform = cmmBits (halfWordWidth platform) -gcWord :: DynFlags -> CmmType-gcWord dflags = CmmType GcPtrCat (wordWidth dflags)+gcWord :: Platform -> CmmType+gcWord platform = CmmType GcPtrCat (wordWidth platform)  cInt :: DynFlags -> CmmType cInt dflags = cmmBits (cIntWidth  dflags)@@ -179,23 +180,20 @@   -------- Common Widths  -------------wordWidth :: DynFlags -> Width-wordWidth dflags- | wORD_SIZE dflags == 4 = W32- | wORD_SIZE dflags == 8 = W64- | otherwise             = panic "MachOp.wordRep: Unknown word size"+wordWidth :: Platform -> Width+wordWidth platform = case platformWordSize platform of+ PW4 -> W32+ PW8 -> W64 -halfWordWidth :: DynFlags -> Width-halfWordWidth dflags- | wORD_SIZE dflags == 4 = W16- | wORD_SIZE dflags == 8 = W32- | otherwise             = panic "MachOp.halfWordRep: Unknown word size"+halfWordWidth :: Platform -> Width+halfWordWidth platform = case platformWordSize platform of+ PW4 -> W16+ PW8 -> W32 -halfWordMask :: DynFlags -> Integer-halfWordMask dflags- | wORD_SIZE dflags == 4 = 0xFFFF- | wORD_SIZE dflags == 8 = 0xFFFFFFFF- | otherwise             = panic "MachOp.halfWordMask: Unknown word size"+halfWordMask :: Platform -> Integer+halfWordMask platform = case platformWordSize platform of+ PW4 -> 0xFFFF+ PW8 -> 0xFFFFFFFF  -- cIntRep is the Width for a C-language 'int' cIntWidth :: DynFlags -> Width
compiler/GHC/Core.hs view
@@ -89,7 +89,7 @@         -- * Core rule data types         CoreRule(..), RuleBase,         RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,-        RuleEnv(..), mkRuleEnv, emptyRuleEnv,+        RuleEnv(..), RuleOpts(..), mkRuleEnv, emptyRuleEnv,          -- ** Operations on 'CoreRule's         ruleArity, ruleName, ruleIdName, ruleActivation,@@ -100,24 +100,24 @@ #include "HsVersions.h"  import GhcPrelude+import GHC.Platform -import CostCentre-import VarEnv( InScopeSet )-import Var-import Type-import Coercion-import Name-import NameSet-import NameEnv( NameEnv, emptyNameEnv )-import Literal-import DataCon-import Module-import BasicTypes-import GHC.Driver.Session+import GHC.Types.CostCentre+import GHC.Types.Var.Env( InScopeSet )+import GHC.Types.Var+import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Name.Env( NameEnv, emptyNameEnv )+import GHC.Types.Literal+import GHC.Core.DataCon+import GHC.Types.Module+import GHC.Types.Basic import Outputable import Util-import UniqSet-import SrcLoc     ( RealSrcSpan, containsSpan )+import GHC.Types.Unique.Set+import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan ) import Binary  import Data.Data hiding (TyCon)@@ -354,7 +354,7 @@  Also, we do not permit case analysis with literal patterns on floating-point types. See #9238 and Note [Rules for floating-point comparisons] in-PrelRules for the rationale for this restriction.+GHC.Core.Op.ConstantFold for the rationale for this restriction.  -------------------------- GHC.Core INVARIANTS --------------------------- @@ -508,7 +508,7 @@  5. Floating-point values must not be scrutinised against literals.    See #9238 and Note [Rules for floating-point comparisons]-   in PrelRules for rationale.  Checked in lintCaseExpr;+   in GHC.Core.Op.ConstantFold for rationale.  Checked in lintCaseExpr;    see the call to isFloatingTy.  6. The 'ty' field of (Case scrut bndr ty alts) is the type of the@@ -783,8 +783,8 @@     "" -> True     _  -> False -The simplifier will pull the case into the join point (see Note [Case-of-case-and join points] in Simplify):+The simplifier will pull the case into the join point (see Note [Join points+and case-of-case] in GHC.Core.Op.Simplify):    join     j :: Int -> Bool -> Bool -- changed!@@ -879,7 +879,7 @@  ===>    join go @a n f x = case n of 0 -> case x of True -> e1; False -> e2-                          n -> go @a (n-1) f (f x)+                               n -> go @a (n-1) f (f x)   in go @Bool n neg True  but that is ill-typed, as `x` is type `a`, not `Bool`.@@ -1276,7 +1276,7 @@    In contrast, orphans are all fingerprinted together in the    mi_orph_hash field of the ModIface. -   See GHC.Iface.Utils.addFingerprints.+   See GHC.Iface.Recomp.addFingerprints.  Orphan-hood is computed   * For class instances:@@ -1284,8 +1284,8 @@     (because it is needed during instance lookup)    * For rules and family instances:-       when we generate an IfaceRule (GHC.Iface.Utils.coreRuleToIfaceRule)-                     or IfaceFamInst (GHC.Iface.Utils.instanceToIfaceInst)+       when we generate an IfaceRule (GHC.Iface.Make.coreRuleToIfaceRule)+                     or IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst) -}  {-@@ -1384,7 +1384,14 @@     }                 -- See Note [Extra args in rule matching] in GHC.Core.Rules -type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr+-- | Rule options+data RuleOpts = RuleOpts+   { roPlatform                :: !Platform -- ^ Target platform+   , roNumConstantFolding      :: !Bool     -- ^ Enable more advanced numeric constant folding+   , roExcessRationalPrecision :: !Bool     -- ^ Cut down precision of Rational values to that of Float/Double if disabled+   }++type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr type InScopeEnv = (InScopeSet, IdUnfoldingFun)  type IdUnfoldingFun = Id -> Unfolding@@ -1810,9 +1817,9 @@ -}  -- The Ord is needed for the FiniteMap used in the lookForConstructor--- in SimplEnv.  If you declared that lookForConstructor *ignores*--- constructor-applications with LitArg args, then you could get--- rid of this Ord.+-- in GHC.Core.Op.Simplify.Env.  If you declared that lookForConstructor+-- *ignores* constructor-applications with LitArg args, then you could get rid+-- of this Ord.  instance Outputable AltCon where   ppr (DataAlt dc) = ppr dc@@ -1963,23 +1970,23 @@  -- | Create a machine integer literal expression of type @Int#@ from an @Integer@. -- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'-mkIntLit      :: DynFlags -> Integer -> Expr b+mkIntLit      :: Platform -> Integer -> Expr b -- | Create a machine integer literal expression of type @Int#@ from an @Int@. -- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'-mkIntLitInt   :: DynFlags -> Int     -> Expr b+mkIntLitInt   :: Platform -> Int     -> Expr b -mkIntLit    dflags n = Lit (mkLitInt dflags n)-mkIntLitInt dflags n = Lit (mkLitInt dflags (toInteger n))+mkIntLit    platform n = Lit (mkLitInt platform n)+mkIntLitInt platform n = Lit (mkLitInt platform (toInteger n))  -- | Create a machine word literal expression of type  @Word#@ from an @Integer@. -- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'-mkWordLit     :: DynFlags -> Integer -> Expr b+mkWordLit     :: Platform -> Integer -> Expr b -- | Create a machine word literal expression of type  @Word#@ from a @Word@. -- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'-mkWordLitWord :: DynFlags -> Word -> Expr b+mkWordLitWord :: Platform -> Word -> Expr b -mkWordLit     dflags w = Lit (mkLitWord dflags w)-mkWordLitWord dflags w = Lit (mkLitWord dflags (toInteger w))+mkWordLit     platform w = Lit (mkLitWord platform w)+mkWordLitWord platform w = Lit (mkLitWord platform (toInteger w))  mkWord64LitWord64 :: Word64 -> Expr b mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w))
compiler/GHC/Core/Arity.hs view
@@ -27,16 +27,16 @@ import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Subst-import Demand-import Var-import VarEnv-import Id-import Type-import TyCon    ( initRecTc, checkRecTc )-import Predicate ( isDictTy )-import Coercion-import BasicTypes-import Unique+import GHC.Types.Demand+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Id+import GHC.Core.Type as Type+import GHC.Core.TyCon     ( initRecTc, checkRecTc )+import GHC.Core.Predicate ( isDictTy )+import GHC.Core.Coercion as Coercion+import GHC.Types.Basic+import GHC.Types.Unique import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt ) import Outputable import FastString@@ -130,7 +130,7 @@       | Just (tc,tys) <- splitTyConApp_maybe ty       , Just (ty', _) <- instNewTyCon_maybe tc tys       , Just rec_nts' <- checkRecTc rec_nts tc  -- See Note [Expanding newtypes]-                                                -- in TyCon+                                                -- in GHC.Core.TyCon --   , not (isClassTyCon tc)    -- Do not eta-expand through newtype classes --                              -- See Note [Newtype classes and eta expansion] --                              (no longer required)
+ compiler/GHC/Core/Class.hs view
@@ -0,0 +1,360 @@+-- (c) The University of Glasgow 2006+-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998+--+-- The @Class@ datatype++{-# LANGUAGE CPP #-}++module GHC.Core.Class (+        Class,+        ClassOpItem,+        ClassATItem(..),+        ClassMinimalDef,+        DefMethInfo, pprDefMethInfo,++        FunDep, pprFundeps, pprFunDep,++        mkClass, mkAbstractClass, classTyVars, classArity,+        classKey, className, classATs, classATItems, classTyCon, classMethods,+        classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,+        classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds,+        isAbstractClass,+    ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon )+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, PredType )+import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType )+import GHC.Types.Var+import GHC.Types.Name+import GHC.Types.Basic+import GHC.Types.Unique+import Util+import GHC.Types.SrcLoc+import Outputable+import BooleanFormula (BooleanFormula, mkTrue)++import qualified Data.Data as Data++{-+************************************************************************+*                                                                      *+\subsection[Class-basic]{@Class@: basic definition}+*                                                                      *+************************************************************************++A @Class@ corresponds to a Greek kappa in the static semantics:+-}++data Class+  = Class {+        classTyCon :: TyCon,    -- The data type constructor for+                                -- dictionaries of this class+                                -- See Note [ATyCon for classes] in GHC.Core.TyCo.Rep++        className :: Name,              -- Just the cached name of the TyCon+        classKey  :: Unique,            -- Cached unique of TyCon++        classTyVars  :: [TyVar],        -- The class kind and type variables;+                                        -- identical to those of the TyCon+           -- If you want visibility info, look at the classTyCon+           -- This field is redundant because it's duplicated in the+           -- classTyCon, but classTyVars is used quite often, so maybe+           -- it's a bit faster to cache it here++        classFunDeps :: [FunDep TyVar],  -- The functional dependencies++        classBody :: ClassBody -- Superclasses, ATs, methods++     }++--  | e.g.+--+-- >  class C a b c | a b -> c, a c -> b where...+--+--  Here fun-deps are [([a,b],[c]), ([a,c],[b])]+--+--  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'',++-- For details on above see note [Api annotations] in ApiAnnotation+type FunDep a = ([a],[a])++type ClassOpItem = (Id, DefMethInfo)+        -- Selector function; contains unfolding+        -- Default-method info++type DefMethInfo = Maybe (Name, DefMethSpec Type)+   -- Nothing                    No default method+   -- Just ($dm, VanillaDM)      A polymorphic default method, name $dm+   -- Just ($gm, GenericDM ty)   A generic default method, name $gm, type ty+   --                              The generic dm type is *not* quantified+   --                              over the class variables; ie has the+   --                              class variables free++data ClassATItem+  = ATI TyCon         -- See Note [Associated type tyvar names]+        (Maybe (Type, SrcSpan))+                      -- Default associated type (if any) from this template+                      -- Note [Associated type defaults]++type ClassMinimalDef = BooleanFormula Name -- Required methods++data ClassBody+  = AbstractClass+  | ConcreteClass {+        -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)+        -- We need value-level selectors for both the dictionary+        -- superclasses and the equality superclasses+        cls_sc_theta :: [PredType],     -- Immediate superclasses,+        cls_sc_sel_ids :: [Id],          -- Selector functions to extract the+                                        --   superclasses from a+                                        --   dictionary of this class+        -- Associated types+        cls_ats :: [ClassATItem],  -- Associated type families++        -- Class operations (methods, not superclasses)+        cls_ops :: [ClassOpItem],  -- Ordered by tag++        -- Minimal complete definition+        cls_min_def :: ClassMinimalDef+    }+    -- TODO: maybe super classes should be allowed in abstract class definitions++classMinimalDef :: Class -> ClassMinimalDef+classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d+classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction++{-+Note [Associated type defaults]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The following is an example of associated type defaults:+   class C a where+     data D a r++     type F x a b :: *+     type F p q r = (p,q)->r    -- Default++Note that++ * The TyCons for the associated types *share type variables* with the+   class, so that we can tell which argument positions should be+   instantiated in an instance decl.  (The first for 'D', the second+   for 'F'.)++ * We can have default definitions only for *type* families,+   not data families++ * In the default decl, the "patterns" should all be type variables,+   but (in the source language) they don't need to be the same as in+   the 'type' decl signature or the class.  It's more like a+   free-standing 'type instance' declaration.++ * HOWEVER, in the internal ClassATItem we rename the RHS to match the+   tyConTyVars of the family TyCon.  So in the example above we'd get+   a ClassATItem of+        ATI F ((x,a) -> b)+   So the tyConTyVars of the family TyCon bind the free vars of+   the default Type rhs++The @mkClass@ function fills in the indirect superclasses.++The SrcSpan is for the entire original declaration.+-}++mkClass :: Name -> [TyVar]+        -> [FunDep TyVar]+        -> [PredType] -> [Id]+        -> [ClassATItem]+        -> [ClassOpItem]+        -> ClassMinimalDef+        -> TyCon+        -> Class++mkClass cls_name tyvars fds super_classes superdict_sels at_stuff+        op_stuff mindef tycon+  = Class { classKey     = nameUnique cls_name,+            className    = cls_name,+                -- NB:  tyConName tycon = cls_name,+                -- But it takes a module loop to assert it here+            classTyVars  = tyvars,+            classFunDeps = fds,+            classBody = ConcreteClass {+                    cls_sc_theta = super_classes,+                    cls_sc_sel_ids = superdict_sels,+                    cls_ats  = at_stuff,+                    cls_ops  = op_stuff,+                    cls_min_def = mindef+                },+            classTyCon   = tycon }++mkAbstractClass :: Name -> [TyVar]+        -> [FunDep TyVar]+        -> TyCon+        -> Class++mkAbstractClass cls_name tyvars fds tycon+  = Class { classKey     = nameUnique cls_name,+            className    = cls_name,+                -- NB:  tyConName tycon = cls_name,+                -- But it takes a module loop to assert it here+            classTyVars  = tyvars,+            classFunDeps = fds,+            classBody = AbstractClass,+            classTyCon   = tycon }++{-+Note [Associated type tyvar names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The TyCon of an associated type should use the same variable names as its+parent class. Thus+    class C a b where+      type F b x a :: *+We make F use the same Name for 'a' as C does, and similarly 'b'.++The reason for this is when checking instances it's easier to match+them up, to ensure they match.  Eg+    instance C Int [d] where+      type F [d] x Int = ....+we should make sure that the first and third args match the instance+header.++Having the same variables for class and tycon is also used in checkValidRoles+(in TcTyClsDecls) when checking a class's roles.+++************************************************************************+*                                                                      *+\subsection[Class-selectors]{@Class@: simple selectors}+*                                                                      *+************************************************************************++The rest of these functions are just simple selectors.+-}++classArity :: Class -> Arity+classArity clas = length (classTyVars clas)+        -- Could memoise this++classAllSelIds :: Class -> [Id]+-- Both superclass-dictionary and method selectors+classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }})+  = sc_sels ++ classMethods c+classAllSelIds c = ASSERT( null (classMethods c) ) []++classSCSelIds :: Class -> [Id]+-- Both superclass-dictionary and method selectors+classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }})+  = sc_sels+classSCSelIds c = ASSERT( null (classMethods c) ) []++classSCSelId :: Class -> Int -> Id+-- Get the n'th superclass selector Id+-- where n is 0-indexed, and counts+--    *all* superclasses including equalities+classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n+  = ASSERT( n >= 0 && lengthExceeds sc_sels n )+    sc_sels !! n+classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n)++classMethods :: Class -> [Id]+classMethods (Class { classBody = ConcreteClass { cls_ops = op_stuff } })+  = [op_sel | (op_sel, _) <- op_stuff]+classMethods _ = []++classOpItems :: Class -> [ClassOpItem]+classOpItems (Class { classBody = ConcreteClass { cls_ops = op_stuff }})+  = op_stuff+classOpItems _ = []++classATs :: Class -> [TyCon]+classATs (Class { classBody = ConcreteClass { cls_ats = at_stuff } })+  = [tc | ATI tc _ <- at_stuff]+classATs _ = []++classATItems :: Class -> [ClassATItem]+classATItems (Class { classBody = ConcreteClass { cls_ats = at_stuff }})+  = at_stuff+classATItems _ = []++classSCTheta :: Class -> [PredType]+classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }})+  = theta_stuff+classSCTheta _ = []++classTvsFds :: Class -> ([TyVar], [FunDep TyVar])+classTvsFds c = (classTyVars c, classFunDeps c)++classHasFds :: Class -> Bool+classHasFds (Class { classFunDeps = fds }) = not (null fds)++classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])+classBigSig (Class {classTyVars = tyvars,+                    classBody = AbstractClass})+  = (tyvars, [], [], [])+classBigSig (Class {classTyVars = tyvars,+                    classBody = ConcreteClass {+                        cls_sc_theta = sc_theta,+                        cls_sc_sel_ids = sc_sels,+                        cls_ops  = op_stuff+                    }})+  = (tyvars, sc_theta, sc_sels, op_stuff)++classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem])+classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,+                         classBody = AbstractClass})+  = (tyvars, fundeps, [], [], [], [])+classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,+                         classBody = ConcreteClass {+                             cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels,+                             cls_ats = ats, cls_ops = op_stuff+                         }})+  = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)++isAbstractClass :: Class -> Bool+isAbstractClass Class{ classBody = AbstractClass } = True+isAbstractClass _ = False++{-+************************************************************************+*                                                                      *+\subsection[Class-instances]{Instance declarations for @Class@}+*                                                                      *+************************************************************************++We compare @Classes@ by their keys (which include @Uniques@).+-}++instance Eq Class where+    c1 == c2 = classKey c1 == classKey c2+    c1 /= c2 = classKey c1 /= classKey c2++instance Uniquable Class where+    getUnique c = classKey c++instance NamedThing Class where+    getName clas = className clas++instance Outputable Class where+    ppr c = ppr (getName c)++pprDefMethInfo :: DefMethInfo -> SDoc+pprDefMethInfo Nothing                  = empty   -- No default method+pprDefMethInfo (Just (n, VanillaDM))    = text "Default method" <+> ppr n+pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method"+                                          <+> ppr n <+> dcolon <+> pprType ty++pprFundeps :: Outputable a => [FunDep a] -> SDoc+pprFundeps []  = empty+pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds))++pprFunDep :: Outputable a => FunDep a -> SDoc+pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs]++instance Data.Data Class where+    -- don't traverse?+    toConstr _   = abstractConstr "Class"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "Class"
+ compiler/GHC/Core/Coercion.hs view
@@ -0,0 +1,2947 @@+{-+(c) The University of Glasgow 2006+-}++{-# LANGUAGE RankNTypes, CPP, MultiWayIf, FlexibleContexts, BangPatterns,+             ScopedTypeVariables #-}++-- | Module for (a) type kinds and (b) type coercions,+-- as used in System FC. See 'GHC.Core.Expr' for+-- more on System FC and how coercions fit into it.+--+module GHC.Core.Coercion (+        -- * Main data type+        Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR,+        UnivCoProvenance, CoercionHole(..), BlockSubstFlag(..),+        coHoleCoVar, setCoHoleCoVar,+        LeftOrRight(..),+        Var, CoVar, TyCoVar,+        Role(..), ltRole,++        -- ** Functions over coercions+        coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole,+        coercionType, mkCoercionType,+        coercionKind, coercionLKind, coercionRKind,coercionKinds,+        coercionRole, coercionKindRole,++        -- ** Constructing coercions+        mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo,+        mkCoVarCo, mkCoVarCos,+        mkAxInstCo, mkUnbranchedAxInstCo,+        mkAxInstRHS, mkUnbranchedAxInstRHS,+        mkAxInstLHS, mkUnbranchedAxInstLHS,+        mkPiCo, mkPiCos, mkCoCast,+        mkSymCo, mkTransCo, mkTransMCo,+        mkNthCo, nthCoRole, mkLRCo,+        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo,+        mkForAllCo, mkForAllCos, mkHomoForAllCos,+        mkPhantomCo,+        mkHoleCo, mkUnivCo, mkSubCo,+        mkAxiomInstCo, mkProofIrrelCo,+        downgradeRole, mkAxiomRuleCo,+        mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,+        mkKindCo, castCoercionKind, castCoercionKindI,++        mkHeteroCoercionType,+        mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,+        mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,++        -- ** Decomposition+        instNewTyCon_maybe,++        NormaliseStepper, NormaliseStepResult(..), composeSteppers,+        mapStepResult, unwrapNewTypeStepper,+        topNormaliseNewType_maybe, topNormaliseTypeX,++        decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe,+        splitTyConAppCo_maybe,+        splitAppCo_maybe,+        splitFunCo_maybe,+        splitForAllCo_maybe,+        splitForAllCo_ty_maybe, splitForAllCo_co_maybe,++        nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,++        pickLR,++        isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,+        isReflCoVar_maybe, isGReflMCo, coToMCo,++        -- ** Coercion variables+        mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,+        isCoVar_maybe,++        -- ** Free variables+        tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo,+        tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet,+        coercionSize,++        -- ** Substitution+        CvSubstEnv, emptyCvSubstEnv,+        lookupCoVar,+        substCo, substCos, substCoVar, substCoVars, substCoWith,+        substCoVarBndr,+        extendTvSubstAndInScope, getCvSubstEnv,++        -- ** Lifting+        liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,+        emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,+        liftCoSubstVarBndrUsing, isMappedByLC,++        mkSubstLiftingContext, zapLiftingContext,+        substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet,++        LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,+        substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,++        -- ** Comparison+        eqCoercion, eqCoercionX,++        -- ** Forcing evaluation of coercions+        seqCo,++        -- * Pretty-printing+        pprCo, pprParendCo,+        pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS,+        pprCoAxBranchUser, tidyCoAxBndrsForUser,+        etaExpandCoAxBranch,++        -- * Tidying+        tidyCo, tidyCos,++        -- * Other+        promoteCoercion, buildCoercion,++        simplifyArgsWorker,++        badCoercionHole, badCoercionHoleCo+       ) where++#include "HsVersions.h"++import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs)++import GhcPrelude++import GHC.Iface.Type+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.FVs+import GHC.Core.TyCo.Ppr+import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.Tidy+import GHC.Core.Type+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name hiding ( varName )+import Util+import GHC.Types.Basic+import Outputable+import GHC.Types.Unique+import Pair+import GHC.Types.SrcLoc+import PrelNames+import TysPrim+import ListSetOps+import Maybes+import GHC.Types.Unique.FM++import Control.Monad (foldM, zipWithM)+import Data.Function ( on )+import Data.Char( isDigit )+import qualified Data.Monoid as Monoid++{-+%************************************************************************+%*                                                                      *+     -- The coercion arguments always *precisely* saturate+     -- arity of (that branch of) the CoAxiom.  If there are+     -- any left over, we use AppCo.  See+     -- See [Coercion axioms applied to coercions] in GHC.Core.TyCo.Rep++\subsection{Coercion variables}+%*                                                                      *+%************************************************************************+-}++coVarName :: CoVar -> Name+coVarName = varName++setCoVarUnique :: CoVar -> Unique -> CoVar+setCoVarUnique = setVarUnique++setCoVarName :: CoVar -> Name -> CoVar+setCoVarName   = setVarName++{-+%************************************************************************+%*                                                                      *+                   Pretty-printing CoAxioms+%*                                                                      *+%************************************************************************++Defined here to avoid module loops. CoAxiom is loaded very early on.++-}++etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type)+-- Return the (tvs,lhs,rhs) after eta-expanding,+-- to the way in which the axiom was originally written+-- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom+etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs+                                , cab_eta_tvs = eta_tvs+                                , cab_lhs = lhs+                                , cab_rhs = rhs })+  -- ToDo: what about eta_cvs?+  = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys)+ where+    eta_tys = mkTyVarTys eta_tvs++pprCoAxiom :: CoAxiom br -> SDoc+-- Used in debug-printing only+pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches })+  = hang (text "axiom" <+> ppr ax <+> dcolon)+       2 (vcat (map (pprCoAxBranchUser tc) (fromBranches branches)))++pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc+-- Used when printing injectivity errors (FamInst.reportInjectivityErrors)+-- and inaccessible branches (TcValidity.inaccessibleCoAxBranch)+-- This happens in error messages: don't print the RHS of a data+--   family axiom, which is meaningless to a user+pprCoAxBranchUser tc br+  | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br+  | otherwise            = pprCoAxBranch    tc br++pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc+-- Print the family-instance equation when reporting+--   a conflict between equations (FamInst.conflictInstErr)+-- For type families the RHS is important; for data families not so.+--   Indeed for data families the RHS is a mysterious internal+--   type constructor, so we suppress it (#14179)+-- See FamInstEnv Note [Family instance overlap conflicts]+pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs+  where+    pp_rhs _ _ = empty++pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc+pprCoAxBranch = ppr_co_ax_branch ppr_rhs+  where+    ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs++ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc)+                 -> TyCon -> CoAxBranch -> SDoc+ppr_co_ax_branch ppr_rhs fam_tc branch+  = foldr1 (flip hangNotEmpty 2)+    [ pprUserForAll (mkTyCoVarBinders Inferred bndrs')+         -- See Note [Printing foralls in type family instances] in GHC.Iface.Type+    , pp_lhs <+> ppr_rhs tidy_env ee_rhs+    , text "-- Defined" <+> pp_loc ]+  where+    loc = coAxBranchSpan branch+    pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc)+           | otherwise         = text "in" <+> ppr loc++    -- Eta-expand LHS and RHS types, because sometimes data family+    -- instances are eta-reduced.+    -- See Note [Eta reduction for data families] in GHC.Core.FamInstEnv.+    (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch++    pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc)+                             (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs)++    (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs++tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var])+-- Tidy wildcards "_1", "_2" to "_", and do not return them+-- in the list of binders to be printed+-- This is so that in error messages we see+--     forall a. F _ [a] _ = ...+-- rather than+--     forall a _1 _2. F _1 [a] _2 = ...+--+-- This is a rather disgusting function+tidyCoAxBndrsForUser init_env tcvs+  = (tidy_env, reverse tidy_bndrs)+  where+    (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs++    tidy_one (env@(occ_env, subst), rev_bndrs') bndr+      | is_wildcard bndr = (env_wild, rev_bndrs')+      | otherwise        = (env',     bndr' : rev_bndrs')+      where+        (env', bndr') = tidyVarBndr env bndr+        env_wild = (occ_env, extendVarEnv subst bndr wild_bndr)+        wild_bndr = setVarName bndr $+                    tidyNameOcc (varName bndr) (mkTyVarOcc "_")+                    -- Tidy the binder to "_"++    is_wildcard :: Var -> Bool+    is_wildcard tv = case occNameString (getOccName tv) of+                       ('_' : rest) -> all isDigit rest+                       _            -> False++{-+%************************************************************************+%*                                                                      *+        Destructing coercions+%*                                                                      *+%************************************************************************++Note [Function coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~+Remember that+  (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> TYPE LiftedRep++Hence+  FunCo r co1 co2 :: (s1->t1) ~r (s2->t2)+is short for+  TyConAppCo (->) co_rep1 co_rep2 co1 co2+where co_rep1, co_rep2 are the coercions on the representations.+-}+++-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into+-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence:+--+-- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c]+decomposeCo :: Arity -> Coercion+            -> [Role]  -- the roles of the output coercions+                       -- this must have at least as many+                       -- entries as the Arity provided+            -> [Coercion]+decomposeCo arity co rs+  = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ]+           -- Remember, Nth is zero-indexed++decomposeFunCo :: HasDebugCallStack+               => Role      -- Role of the input coercion+               -> Coercion  -- Input coercion+               -> (Coercion, Coercion)+-- Expects co :: (s1 -> t1) ~ (s2 -> t2)+-- Returns (co1 :: s1~s2, co2 :: t1~t2)+-- See Note [Function coercions] for the "2" and "3"+decomposeFunCo r co = ASSERT2( all_ok, ppr co )+                      (mkNthCo r 2 co, mkNthCo r 3 co)+  where+    Pair s1t1 s2t2 = coercionKind co+    all_ok = isFunTy s1t1 && isFunTy s2t2++{- Note [Pushing a coercion into a pi-type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have this:+    (f |> co) t1 .. tn+Then we want to push the coercion into the arguments, so as to make+progress. For example of why you might want to do so, see Note+[Respecting definitional equality] in GHC.Core.TyCo.Rep.++This is done by decomposePiCos.  Specifically, if+    decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor)+then+    (f |> co) t1 .. tn   =   (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn++Notes:++* k can be smaller than n! That is decomposePiCos can return *fewer*+  coercions than there are arguments (ie k < n), if the kind provided+  doesn't have enough binders.++* If there is a type error, we might see+       (f |> co) t1+  where co :: (forall a. ty) ~ (ty1 -> ty2)+  Here 'co' is insoluble, but we don't want to crash in decoposePiCos.+  So decomposePiCos carefully tests both sides of the coercion to check+  they are both foralls or both arrows.  Not doing this caused #15343.+-}++decomposePiCos :: HasDebugCallStack+               => CoercionN -> Pair Type  -- Coercion and its kind+               -> [Type]+               -> ([CoercionN], CoercionN)+-- See Note [Pushing a coercion into a pi-type]+decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args+  = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args+  where+    orig_subst = mkEmptyTCvSubst $ mkInScopeSet $+                 tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co++    go :: [CoercionN]      -- accumulator for argument coercions, reversed+       -> (TCvSubst,Kind)  -- Lhs kind of coercion+       -> CoercionN        -- coercion originally applied to the function+       -> (TCvSubst,Kind)  -- Rhs kind of coercion+       -> [Type]           -- Arguments to that function+       -> ([CoercionN], Coercion)+    -- Invariant:  co :: subst1(k2) ~ subst2(k2)++    go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys)+      | Just (a, t1) <- splitForAllTy_maybe k1+      , Just (b, t2) <- splitForAllTy_maybe k2+        -- know     co :: (forall a:s1.t1) ~ (forall b:s2.t2)+        --    function :: forall a:s1.t1   (the function is not passed to decomposePiCos)+        --           a :: s1+        --           b :: s2+        --          ty :: s2+        -- need arg_co :: s2 ~ s1+        --      res_co :: t1[ty |> arg_co / a] ~ t2[ty / b]+      = let arg_co  = mkNthCo Nominal 0 (mkSymCo co)+            res_co  = mkInstCo co (mkGReflLeftCo Nominal ty arg_co)+            subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co)+            subst2' = extendTCvSubst subst2 b ty+        in+        go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys++      | Just (_s1, t1) <- splitFunTy_maybe k1+      , Just (_s2, t2) <- splitFunTy_maybe k2+        -- know     co :: (s1 -> t1) ~ (s2 -> t2)+        --    function :: s1 -> t1+        --          ty :: s2+        -- need arg_co :: s2 ~ s1+        --      res_co :: t1 ~ t2+      = let (sym_arg_co, res_co) = decomposeFunCo Nominal co+            arg_co               = mkSymCo sym_arg_co+        in+        go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys++      | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2)+      = go acc_arg_cos (zapTCvSubst subst1, substTy subst1 k1)+                       co+                       (zapTCvSubst subst2, substTy subst1 k2)+                       (ty:tys)++      -- tys might not be empty, if the left-hand type of the original coercion+      -- didn't have enough binders+    go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co)++-- | Attempts to obtain the type variable underlying a 'Coercion'+getCoVar_maybe :: Coercion -> Maybe CoVar+getCoVar_maybe (CoVarCo cv) = Just cv+getCoVar_maybe _            = Nothing++-- | Attempts to tease a coercion apart into a type constructor and the application+-- of a number of coercion arguments to that constructor+splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion])+splitTyConAppCo_maybe co+  | Just (ty, r) <- isReflCo_maybe co+  = do { (tc, tys) <- splitTyConApp_maybe ty+       ; let args = zipWith mkReflCo (tyConRolesX r tc) tys+       ; return (tc, args) }+splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos)+splitTyConAppCo_maybe (FunCo _ arg res)     = Just (funTyCon, cos)+  where cos = [mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res]+splitTyConAppCo_maybe _                     = Nothing++-- first result has role equal to input; third result is Nominal+splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)+-- ^ Attempt to take a coercion application apart.+splitAppCo_maybe (AppCo co arg) = Just (co, arg)+splitAppCo_maybe (TyConAppCo r tc args)+  | args `lengthExceeds` tyConArity tc+  , Just (args', arg') <- snocView args+  = Just ( mkTyConAppCo r tc args', arg' )++  | not (mustBeSaturated tc)+    -- Never create unsaturated type family apps!+  , Just (args', arg') <- snocView args+  , Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg'+  = Just ( mkTyConAppCo r tc args', arg'' )+       -- Use mkTyConAppCo to preserve the invariant+       --  that identity coercions are always represented by Refl++splitAppCo_maybe co+  | Just (ty, r) <- isReflCo_maybe co+  , Just (ty1, ty2) <- splitAppTy_maybe ty+  = Just (mkReflCo r ty1, mkNomReflCo ty2)+splitAppCo_maybe _ = Nothing++splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion)+splitFunCo_maybe (FunCo _ arg res) = Just (arg, res)+splitFunCo_maybe _ = Nothing++splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion)+splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co)+splitForAllCo_maybe _                     = Nothing++-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder+splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)+splitForAllCo_ty_maybe (ForAllCo tv k_co co)+  | isTyVar tv = Just (tv, k_co, co)+splitForAllCo_ty_maybe _ = Nothing++-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder+splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)+splitForAllCo_co_maybe (ForAllCo cv k_co co)+  | isCoVar cv = Just (cv, k_co, co)+splitForAllCo_co_maybe _ = Nothing++-------------------------------------------------------+-- and some coercion kind stuff++coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type+coVarLType cv | (_, _, ty1, _, _) <- coVarKindsTypesRole cv = ty1+coVarRType cv | (_, _, _, ty2, _) <- coVarKindsTypesRole cv = ty2++coVarTypes :: HasDebugCallStack => CoVar -> Pair Type+coVarTypes cv+  | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv+  = Pair ty1 ty2++coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role)+coVarKindsTypesRole cv+ | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv)+ = (k1, k2, ty1, ty2, eqTyConRole tc)+ | otherwise+ = pprPanic "coVarKindsTypesRole, non coercion variable"+            (ppr cv $$ ppr (varType cv))++coVarKind :: CoVar -> Type+coVarKind cv+  = ASSERT( isCoVar cv )+    varType cv++coVarRole :: CoVar -> Role+coVarRole cv+  = eqTyConRole (case tyConAppTyCon_maybe (varType cv) of+                   Just tc0 -> tc0+                   Nothing  -> pprPanic "coVarRole: not tyconapp" (ppr cv))++eqTyConRole :: TyCon -> Role+-- Given (~#) or (~R#) return the Nominal or Representational respectively+eqTyConRole tc+  | tc `hasKey` eqPrimTyConKey+  = Nominal+  | tc `hasKey` eqReprPrimTyConKey+  = Representational+  | otherwise+  = pprPanic "eqTyConRole: unknown tycon" (ppr tc)++-- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@,+-- produce a coercion @rep_co :: r1 ~ r2@.+mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion+mkRuntimeRepCo co+  = mkNthCo Nominal 0 kind_co+  where+    kind_co = mkKindCo co  -- kind_co :: TYPE r1 ~ TYPE r2+                           -- (up to silliness with Constraint)++isReflCoVar_maybe :: Var -> Maybe Coercion+-- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t)+-- Works on all kinds of Vars, not just CoVars+isReflCoVar_maybe cv+  | isCoVar cv+  , Pair ty1 ty2 <- coVarTypes cv+  , ty1 `eqType` ty2+  = Just (mkReflCo (coVarRole cv) ty1)+  | otherwise+  = Nothing++-- | Tests if this coercion is obviously a generalized reflexive coercion.+-- Guaranteed to work very quickly.+isGReflCo :: Coercion -> Bool+isGReflCo (GRefl{}) = True+isGReflCo (Refl{})  = True -- Refl ty == GRefl N ty MRefl+isGReflCo _         = False++-- | Tests if this MCoercion is obviously generalized reflexive+-- Guaranteed to work very quickly.+isGReflMCo :: MCoercion -> Bool+isGReflMCo MRefl = True+isGReflMCo (MCo co) | isGReflCo co = True+isGReflMCo _ = False++-- | Tests if this coercion is obviously reflexive. Guaranteed to work+-- very quickly. Sometimes a coercion can be reflexive, but not obviously+-- so. c.f. 'isReflexiveCo'+isReflCo :: Coercion -> Bool+isReflCo (Refl{}) = True+isReflCo (GRefl _ _ mco) | isGReflMCo mco = True+isReflCo _ = False++-- | Returns the type coerced if this coercion is a generalized reflexive+-- coercion. Guaranteed to work very quickly.+isGReflCo_maybe :: Coercion -> Maybe (Type, Role)+isGReflCo_maybe (GRefl r ty _) = Just (ty, r)+isGReflCo_maybe (Refl ty)      = Just (ty, Nominal)+isGReflCo_maybe _ = Nothing++-- | Returns the type coerced if this coercion is reflexive. Guaranteed+-- to work very quickly. Sometimes a coercion can be reflexive, but not+-- obviously so. c.f. 'isReflexiveCo_maybe'+isReflCo_maybe :: Coercion -> Maybe (Type, Role)+isReflCo_maybe (Refl ty) = Just (ty, Nominal)+isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)+isReflCo_maybe _ = Nothing++-- | Slowly checks if the coercion is reflexive. Don't call this in a loop,+-- as it walks over the entire coercion.+isReflexiveCo :: Coercion -> Bool+isReflexiveCo = isJust . isReflexiveCo_maybe++-- | Extracts the coerced type from a reflexive coercion. This potentially+-- walks over the entire coercion, so avoid doing this in a loop.+isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role)+isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal)+isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)+isReflexiveCo_maybe co+  | ty1 `eqType` ty2+  = Just (ty1, r)+  | otherwise+  = Nothing+  where (Pair ty1 ty2, r) = coercionKindRole co++coToMCo :: Coercion -> MCoercion+coToMCo c = if isReflCo c+  then MRefl+  else MCo c++{-+%************************************************************************+%*                                                                      *+            Building coercions+%*                                                                      *+%************************************************************************++These "smart constructors" maintain the invariants listed in the definition+of Coercion, and they perform very basic optimizations.++Note [Role twiddling functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++There are a plethora of functions for twiddling roles:++mkSubCo: Requires a nominal input coercion and always produces a+representational output. This is used when you (the programmer) are sure you+know exactly that role you have and what you want.++downgradeRole_maybe: This function takes both the input role and the output role+as parameters. (The *output* role comes first!) It can only *downgrade* a+role -- that is, change it from N to R or P, or from R to P. This one-way+behavior is why there is the "_maybe". If an upgrade is requested, this+function produces Nothing. This is used when you need to change the role of a+coercion, but you're not sure (as you're writing the code) of which roles are+involved.++This function could have been written using coercionRole to ascertain the role+of the input. But, that function is recursive, and the caller of downgradeRole_maybe+often knows the input role. So, this is more efficient.++downgradeRole: This is just like downgradeRole_maybe, but it panics if the+conversion isn't a downgrade.++setNominalRole_maybe: This is the only function that can *upgrade* a coercion.+The result (if it exists) is always Nominal. The input can be at any role. It+works on a "best effort" basis, as it should never be strictly necessary to+upgrade a coercion during compilation. It is currently only used within GHC in+splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second+coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable+that splitAppCo_maybe is operating over a TyConAppCo that uses a+representational coercion. Hence the need for setNominalRole_maybe.+splitAppCo_maybe, in turn, is used only within coercion optimization -- thus,+it is not absolutely critical that setNominalRole_maybe be complete.++Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom+UnivCos are perfectly type-safe, whereas representational and nominal ones are+not. (Nominal ones are no worse than representational ones, so this function *will*+change a UnivCo Representational to a UnivCo Nominal.)++Conal Elliott also came across a need for this function while working with the+GHC API, as he was decomposing Core casts. The Core casts use representational+coercions, as they must, but his use case required nominal coercions (he was+building a GADT). So, that's why this function is exported from this module.++One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as+appropriate? I (Richard E.) have decided not to do this, because upgrading a+role is bizarre and a caller should have to ask for this behavior explicitly.++-}++-- | Make a generalized reflexive coercion+mkGReflCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflCo r ty mco+  | isGReflMCo mco = if r == Nominal then Refl ty+                     else GRefl r ty MRefl+  | otherwise    = GRefl r ty mco++-- | Make a reflexive coercion+mkReflCo :: Role -> Type -> Coercion+mkReflCo Nominal ty = Refl ty+mkReflCo r       ty = GRefl r ty MRefl++-- | Make a representational reflexive coercion+mkRepReflCo :: Type -> Coercion+mkRepReflCo ty = GRefl Representational ty MRefl++-- | Make a nominal reflexive coercion+mkNomReflCo :: Type -> Coercion+mkNomReflCo = Refl++-- | Apply a type constructor to a list of coercions. It is the+-- caller's responsibility to get the roles correct on argument coercions.+mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion+mkTyConAppCo r tc cos+  | tc `hasKey` funTyConKey+  , [_rep1, _rep2, co1, co2] <- cos   -- See Note [Function coercions]+  = -- (a :: TYPE ra) -> (b :: TYPE rb)  ~  (c :: TYPE rc) -> (d :: TYPE rd)+    -- rep1 :: ra  ~  rc        rep2 :: rb  ~  rd+    -- co1  :: a   ~  c         co2  :: b   ~  d+    mkFunCo r co1 co2++               -- Expand type synonyms+  | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos+  = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos++  | Just tys_roles <- traverse isReflCo_maybe cos+  = mkReflCo r (mkTyConApp tc (map fst tys_roles))+  -- See Note [Refl invariant]++  | otherwise = TyConAppCo r tc cos++-- | Build a function 'Coercion' from two other 'Coercion's. That is,+-- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@.+mkFunCo :: Role -> Coercion -> Coercion -> Coercion+mkFunCo r co1 co2+    -- See Note [Refl invariant]+  | Just (ty1, _) <- isReflCo_maybe co1+  , Just (ty2, _) <- isReflCo_maybe co2+  = mkReflCo r (mkVisFunTy ty1 ty2)+  | otherwise = FunCo r co1 co2++-- | Apply a 'Coercion' to another 'Coercion'.+-- The second coercion must be Nominal, unless the first is Phantom.+-- If the first is Phantom, then the second can be either Phantom or Nominal.+mkAppCo :: Coercion     -- ^ :: t1 ~r t2+        -> Coercion     -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2+        -> Coercion     -- ^ :: t1 s1 ~r t2 s2+mkAppCo co arg+  | Just (ty1, r) <- isReflCo_maybe co+  , Just (ty2, _) <- isReflCo_maybe arg+  = mkReflCo r (mkAppTy ty1 ty2)++  | Just (ty1, r) <- isReflCo_maybe co+  , Just (tc, tys) <- splitTyConApp_maybe ty1+    -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102)+  = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys)+  where+    zip_roles (r1:_)  []            = [downgradeRole r1 Nominal arg]+    zip_roles (r1:rs) (ty1:tys)     = mkReflCo r1 ty1 : zip_roles rs tys+    zip_roles _       _             = panic "zip_roles" -- but the roles are infinite...++mkAppCo (TyConAppCo r tc args) arg+  = case r of+      Nominal          -> mkTyConAppCo Nominal tc (args ++ [arg])+      Representational -> mkTyConAppCo Representational tc (args ++ [arg'])+        where new_role = (tyConRolesRepresentational tc) !! (length args)+              arg'     = downgradeRole new_role Nominal arg+      Phantom          -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg])+mkAppCo co arg = AppCo co  arg+-- Note, mkAppCo is careful to maintain invariants regarding+-- where Refl constructors appear; see the comments in the definition+-- of Coercion and the Note [Refl invariant] in GHC.Core.TyCo.Rep.++-- | Applies multiple 'Coercion's to another 'Coercion', from left to right.+-- See also 'mkAppCo'.+mkAppCos :: Coercion+         -> [Coercion]+         -> Coercion+mkAppCos co1 cos = foldl' mkAppCo co1 cos++{- Note [Unused coercion variable in ForAllCo]++See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep for the+motivation for checking coercion variable in types.+To lift the design choice to (ForAllCo cv kind_co body_co), we have two options:++(1) In mkForAllCo, we check whether cv is a coercion variable+    and whether it is not used in body_co. If so we construct a FunCo.+(2) We don't do this check in mkForAllCo.+    In coercionKind, we use mkTyCoForAllTy to perform the check and construct+    a FunTy when necessary.++We chose (2) for two reasons:++* for a coercion, all that matters is its kind, So ForAllCo or FunCo does not+  make a difference.+* even if cv occurs in body_co, it is possible that cv does not occur in the kind+  of body_co. Therefore the check in coercionKind is inevitable.++The last wrinkle is that there are restrictions around the use of the cv in the+coercion, as described in Section 5.8.5.2 of Richard's thesis. The idea is that+we cannot prove that the type system is consistent with unrestricted use of this+cv; the consistency proof uses an untyped rewrite relation that works over types+with all coercions and casts removed. So, we can allow the cv to appear only in+positions that are erased. As an approximation of this (and keeping close to the+published theory), we currently allow the cv only within the type in a Refl node+and under a GRefl node (including in the Coercion stored in a GRefl). It's+possible other places are OK, too, but this is a safe approximation.++Sadly, with heterogeneous equality, this restriction might be able to be violated;+Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst+function might create an invalid coercion. Because a violation of the+restriction might lead to a program that "goes wrong", it is checked all the time,+even in a production compiler and without -dcore-list. We *have* proved that the+problem does not occur with homogeneous equality, so this check can be dropped+once ~# is made to be homogeneous.+-}+++-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion.+-- The kind of the tycovar should be the left-hand kind of the kind coercion.+-- See Note [Unused coercion variable in ForAllCo]+mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion+mkForAllCo v kind_co co+  | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True+  , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True+  , Just (ty, r) <- isReflCo_maybe co+  , isGReflCo kind_co+  = mkReflCo r (mkTyCoInvForAllTy v ty)+  | otherwise+  = ForAllCo v kind_co co++-- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious+-- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'.+-- The kind of the tycovar should be the left-hand kind of the kind coercion.+mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion+mkForAllCo_NoRefl v kind_co co+  | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True+  , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True+  , ASSERT( not (isReflCo co)) True+  , isCoVar v+  , not (v `elemVarSet` tyCoVarsOfCo co)+  = FunCo (coercionRole co) kind_co co+  | otherwise+  = ForAllCo v kind_co co++-- | Make nested ForAllCos+mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion+mkForAllCos bndrs co+  | Just (ty, r ) <- isReflCo_maybe co+  = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in+    foldl' (flip $ uncurry mkForAllCo_NoRefl)+           (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty))+           non_refls_rev'd+  | otherwise+  = foldr (uncurry mkForAllCo_NoRefl) co bndrs++-- | Make a Coercion quantified over a type/coercion variable;+-- the variable has the same type in both sides of the coercion+mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion+mkHomoForAllCos vs co+  | Just (ty, r) <- isReflCo_maybe co+  = mkReflCo r (mkTyCoInvForAllTys vs ty)+  | otherwise+  = mkHomoForAllCos_NoRefl vs co++-- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious+-- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'.+mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion+mkHomoForAllCos_NoRefl vs orig_co+  = ASSERT( not (isReflCo orig_co))+    foldr go orig_co vs+  where+    go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co++mkCoVarCo :: CoVar -> Coercion+-- cv :: s ~# t+-- See Note [mkCoVarCo]+mkCoVarCo cv = CoVarCo cv++mkCoVarCos :: [CoVar] -> [Coercion]+mkCoVarCos = map mkCoVarCo++{- Note [mkCoVarCo]+~~~~~~~~~~~~~~~~~~~+In the past, mkCoVarCo optimised (c :: t~t) to (Refl t).  That is+valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but+it's a relatively expensive test and perhaps better done in+optCoercion.  Not a big deal either way.+-}++-- | Extract a covar, if possible. This check is dirty. Be ashamed+-- of yourself. (It's dirty because it cares about the structure of+-- a coercion, which is morally reprehensible.)+isCoVar_maybe :: Coercion -> Maybe CoVar+isCoVar_maybe (CoVarCo cv) = Just cv+isCoVar_maybe _            = Nothing++mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion]+           -> Coercion+-- mkAxInstCo can legitimately be called over-staturated;+-- i.e. with more type arguments than the coercion requires+mkAxInstCo role ax index tys cos+  | arity == n_tys = downgradeRole role ax_role $+                     mkAxiomInstCo ax_br index (rtys `chkAppend` cos)+  | otherwise      = ASSERT( arity < n_tys )+                     downgradeRole role ax_role $+                     mkAppCos (mkAxiomInstCo ax_br index+                                             (ax_args `chkAppend` cos))+                              leftover_args+  where+    n_tys         = length tys+    ax_br         = toBranchedAxiom ax+    branch        = coAxiomNthBranch ax_br index+    tvs           = coAxBranchTyVars branch+    arity         = length tvs+    arg_roles     = coAxBranchRoles branch+    rtys          = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys+    (ax_args, leftover_args)+                  = splitAt arity rtys+    ax_role       = coAxiomRole ax++-- worker function+mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion+mkAxiomInstCo ax index args+  = ASSERT( args `lengthIs` coAxiomArity ax index )+    AxiomInstCo ax index args++-- to be used only with unbranched axioms+mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched+                     -> [Type] -> [Coercion] -> Coercion+mkUnbranchedAxInstCo role ax tys cos+  = mkAxInstCo role ax 0 tys cos++mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type+-- Instantiate the axiom with specified types,+-- returning the instantiated RHS+-- A companion to mkAxInstCo:+--    mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys))+mkAxInstRHS ax index tys cos+  = ASSERT( tvs `equalLength` tys1 )+    mkAppTys rhs' tys2+  where+    branch       = coAxiomNthBranch ax index+    tvs          = coAxBranchTyVars branch+    cvs          = coAxBranchCoVars branch+    (tys1, tys2) = splitAtList tvs tys+    rhs'         = substTyWith tvs tys1 $+                   substTyWithCoVars cvs cos $+                   coAxBranchRHS branch++mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type+mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0++-- | Return the left-hand type of the axiom, when the axiom is instantiated+-- at the types given.+mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type+mkAxInstLHS ax index tys cos+  = ASSERT( tvs `equalLength` tys1 )+    mkTyConApp fam_tc (lhs_tys `chkAppend` tys2)+  where+    branch       = coAxiomNthBranch ax index+    tvs          = coAxBranchTyVars branch+    cvs          = coAxBranchCoVars branch+    (tys1, tys2) = splitAtList tvs tys+    lhs_tys      = substTysWith tvs tys1 $+                   substTysWithCoVars cvs cos $+                   coAxBranchLHS branch+    fam_tc       = coAxiomTyCon ax++-- | Instantiate the left-hand side of an unbranched axiom+mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type+mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0++-- | Make a coercion from a coercion hole+mkHoleCo :: CoercionHole -> Coercion+mkHoleCo h = HoleCo h++-- | Make a universal coercion between two arbitrary types.+mkUnivCo :: UnivCoProvenance+         -> Role       -- ^ role of the built coercion, "r"+         -> Type       -- ^ t1 :: k1+         -> Type       -- ^ t2 :: k2+         -> Coercion   -- ^ :: t1 ~r t2+mkUnivCo prov role ty1 ty2+  | ty1 `eqType` ty2 = mkReflCo role ty1+  | otherwise        = UnivCo prov role ty1 ty2++-- | Create a symmetric version of the given 'Coercion' that asserts+--   equality between the same types but in the other "direction", so+--   a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@.+mkSymCo :: Coercion -> Coercion++-- Do a few simple optimizations, but don't bother pushing occurrences+-- of symmetry to the leaves; the optimizer will take care of that.+mkSymCo co | isReflCo co          = co+mkSymCo    (SymCo co)             = co+mkSymCo    (SubCo (SymCo co))     = SubCo co+mkSymCo co                        = SymCo co++-- | Create a new 'Coercion' by composing the two given 'Coercion's transitively.+--   (co1 ; co2)+mkTransCo :: Coercion -> Coercion -> Coercion+mkTransCo co1 co2 | isReflCo co1 = co2+                  | isReflCo co2 = co1+mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2))+  = GRefl r t1 (MCo $ mkTransCo co1 co2)+mkTransCo co1 co2                 = TransCo co1 co2++-- | Compose two MCoercions via transitivity+mkTransMCo :: MCoercion -> MCoercion -> MCoercion+mkTransMCo MRefl     co2       = co2+mkTransMCo co1       MRefl     = co1+mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2)++mkNthCo :: HasDebugCallStack+        => Role  -- The role of the coercion you're creating+        -> Int   -- Zero-indexed+        -> Coercion+        -> Coercion+mkNthCo r n co+  = ASSERT2( good_call, bad_call_msg )+    go r n co+  where+    Pair ty1 ty2 = coercionKind co++    go r 0 co+      | Just (ty, _) <- isReflCo_maybe co+      , Just (tv, _) <- splitForAllTy_maybe ty+      = -- works for both tyvar and covar+        ASSERT( r == Nominal )+        mkNomReflCo (varType tv)++    go r n co+      | Just (ty, r0) <- isReflCo_maybe co+      , let tc = tyConAppTyCon ty+      = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty )+        ASSERT( nthRole r0 tc n == r )+        mkReflCo r (tyConAppArgN n ty)+      where ok_tc_app :: Type -> Int -> Bool+            ok_tc_app ty n+              | Just (_, tys) <- splitTyConApp_maybe ty+              = tys `lengthExceeds` n+              | isForAllTy ty  -- nth:0 pulls out a kind coercion from a hetero forall+              = n == 0+              | otherwise+              = False++    go r 0 (ForAllCo _ kind_co _)+      = ASSERT( r == Nominal )+        kind_co+      -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)+      -- then (nth 0 co :: k1 ~N k2)+      -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)+      -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4))++    go r n co@(FunCo r0 arg res)+      -- See Note [Function coercions]+      -- If FunCo _ arg_co res_co ::   (s1:TYPE sk1 -> s2:TYPE sk2)+      --                             ~ (t1:TYPE tk1 -> t2:TYPE tk2)+      -- Then we want to behave as if co was+      --    TyConAppCo argk_co resk_co arg_co res_co+      -- where+      --    argk_co :: sk1 ~ tk1  =  mkNthCo 0 (mkKindCo arg_co)+      --    resk_co :: sk2 ~ tk2  =  mkNthCo 0 (mkKindCo res_co)+      --                             i.e. mkRuntimeRepCo+      = case n of+          0 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg+          1 -> ASSERT( r == Nominal ) mkRuntimeRepCo res+          2 -> ASSERT( r == r0 )      arg+          3 -> ASSERT( r == r0 )      res+          _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co)++    go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n+                                                    , (vcat [ ppr tc+                                                            , ppr arg_cos+                                                            , ppr r0+                                                            , ppr n+                                                            , ppr r ]) )+                                             arg_cos `getNth` n++    go r n co =+      NthCo r n co++    -- Assertion checking+    bad_call_msg = vcat [ text "Coercion =" <+> ppr co+                        , text "LHS ty =" <+> ppr ty1+                        , text "RHS ty =" <+> ppr ty2+                        , text "n =" <+> ppr n, text "r =" <+> ppr r+                        , text "coercion role =" <+> ppr (coercionRole co) ]+    good_call+      -- If the Coercion passed in is between forall-types, then the Int must+      -- be 0 and the role must be Nominal.+      | Just (_tv1, _) <- splitForAllTy_maybe ty1+      , Just (_tv2, _) <- splitForAllTy_maybe ty2+      = n == 0 && r == Nominal++      -- If the Coercion passed in is between T tys and T tys', then the Int+      -- must be less than the length of tys/tys' (which must be the same+      -- lengths).+      --+      -- If the role of the Coercion is nominal, then the role passed in must+      -- be nominal. If the role of the Coercion is representational, then the+      -- role passed in must be tyConRolesRepresentational T !! n. If the role+      -- of the Coercion is Phantom, then the role passed in must be Phantom.+      --+      -- See also Note [NthCo Cached Roles] if you're wondering why it's+      -- blaringly obvious that we should be *computing* this role instead of+      -- passing it in.+      | Just (tc1, tys1) <- splitTyConApp_maybe ty1+      , Just (tc2, tys2) <- splitTyConApp_maybe ty2+      , tc1 == tc2+      = let len1 = length tys1+            len2 = length tys2+            good_role = case coercionRole co of+                          Nominal -> r == Nominal+                          Representational -> r == (tyConRolesRepresentational tc1 !! n)+                          Phantom -> r == Phantom+        in len1 == len2 && n < len1 && good_role++      | otherwise+      = True++++-- | If you're about to call @mkNthCo r n co@, then @r@ should be+-- whatever @nthCoRole n co@ returns.+nthCoRole :: Int -> Coercion -> Role+nthCoRole n co+  | Just (tc, _) <- splitTyConApp_maybe lty+  = nthRole r tc n++  | Just _ <- splitForAllTy_maybe lty+  = Nominal++  | otherwise+  = pprPanic "nthCoRole" (ppr co)++  where+    lty = coercionLKind co+    r   = coercionRole co++mkLRCo :: LeftOrRight -> Coercion -> Coercion+mkLRCo lr co+  | Just (ty, eq) <- isReflCo_maybe co+  = mkReflCo eq (pickLR lr (splitAppTy ty))+  | otherwise+  = LRCo lr co++-- | Instantiates a 'Coercion'.+mkInstCo :: Coercion -> Coercion -> Coercion+mkInstCo (ForAllCo tcv _kind_co body_co) co+  | Just (arg, _) <- isReflCo_maybe co+      -- works for both tyvar and covar+  = substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co+mkInstCo co arg = InstCo co arg++-- | Given @ty :: k1@, @co :: k1 ~ k2@,+-- produces @co' :: ty ~r (ty |> co)@+mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion+mkGReflRightCo r ty co+  | isGReflCo co = mkReflCo r ty+    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@+    -- instead of @isReflCo@+  | otherwise = GRefl r ty (MCo co)++-- | Given @ty :: k1@, @co :: k1 ~ k2@,+-- produces @co' :: (ty |> co) ~r ty@+mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion+mkGReflLeftCo r ty co+  | isGReflCo co = mkReflCo r ty+    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@+    -- instead of @isReflCo@+  | otherwise    = mkSymCo $ GRefl r ty (MCo co)++-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@,+-- produces @co' :: (ty |> co) ~r ty'+-- It is not only a utility function, but it saves allocation when co+-- is a GRefl coercion.+mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion+mkCoherenceLeftCo r ty co co2+  | isGReflCo co = co2+  | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2++-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@,+-- produces @co' :: ty' ~r (ty |> co)+-- It is not only a utility function, but it saves allocation when co+-- is a GRefl coercion.+mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion+mkCoherenceRightCo r ty co co2+  | isGReflCo co = co2+  | otherwise = co2 `mkTransCo` GRefl r ty (MCo co)++-- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@.+mkKindCo :: Coercion -> Coercion+mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty)+mkKindCo (GRefl _ _ (MCo co)) = co+mkKindCo (UnivCo (PhantomProv h) _ _ _)    = h+mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h+mkKindCo co+  | Pair ty1 ty2 <- coercionKind co+       -- generally, calling coercionKind during coercion creation is a bad idea,+       -- as it can lead to exponential behavior. But, we don't have nested mkKindCos,+       -- so it's OK here.+  , let tk1 = typeKind ty1+        tk2 = typeKind ty2+  , tk1 `eqType` tk2+  = Refl tk1+  | otherwise+  = KindCo co++mkSubCo :: Coercion -> Coercion+-- Input coercion is Nominal, result is Representational+-- see also Note [Role twiddling functions]+mkSubCo (Refl ty) = GRefl Representational ty MRefl+mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co+mkSubCo (TyConAppCo Nominal tc cos)+  = TyConAppCo Representational tc (applyRoles tc cos)+mkSubCo (FunCo Nominal arg res)+  = FunCo Representational+          (downgradeRole Representational Nominal arg)+          (downgradeRole Representational Nominal res)+mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) )+             SubCo co++-- | Changes a role, but only a downgrade. See Note [Role twiddling functions]+downgradeRole_maybe :: Role   -- ^ desired role+                    -> Role   -- ^ current role+                    -> Coercion -> Maybe Coercion+-- In (downgradeRole_maybe dr cr co) it's a precondition that+--                                   cr = coercionRole co++downgradeRole_maybe Nominal          Nominal          co = Just co+downgradeRole_maybe Nominal          _                _  = Nothing++downgradeRole_maybe Representational Nominal          co = Just (mkSubCo co)+downgradeRole_maybe Representational Representational co = Just co+downgradeRole_maybe Representational Phantom          _  = Nothing++downgradeRole_maybe Phantom          Phantom          co = Just co+downgradeRole_maybe Phantom          _                co = Just (toPhantomCo co)++-- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade.+-- See Note [Role twiddling functions]+downgradeRole :: Role  -- desired role+              -> Role  -- current role+              -> Coercion -> Coercion+downgradeRole r1 r2 co+  = case downgradeRole_maybe r1 r2 co of+      Just co' -> co'+      Nothing  -> pprPanic "downgradeRole" (ppr co)++mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion+mkAxiomRuleCo = AxiomRuleCo++-- | Make a "coercion between coercions".+mkProofIrrelCo :: Role       -- ^ role of the created coercion, "r"+               -> Coercion   -- ^ :: phi1 ~N phi2+               -> Coercion   -- ^ g1 :: phi1+               -> Coercion   -- ^ g2 :: phi2+               -> Coercion   -- ^ :: g1 ~r g2++-- if the two coercion prove the same fact, I just don't care what+-- the individual coercions are.+mkProofIrrelCo r co g  _ | isGReflCo co  = mkReflCo r (mkCoercionTy g)+  -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@+mkProofIrrelCo r kco        g1 g2 = mkUnivCo (ProofIrrelProv kco) r+                                             (mkCoercionTy g1) (mkCoercionTy g2)++{-+%************************************************************************+%*                                                                      *+   Roles+%*                                                                      *+%************************************************************************+-}++-- | Converts a coercion to be nominal, if possible.+-- See Note [Role twiddling functions]+setNominalRole_maybe :: Role -- of input coercion+                     -> Coercion -> Maybe Coercion+setNominalRole_maybe r co+  | r == Nominal = Just co+  | otherwise = setNominalRole_maybe_helper co+  where+    setNominalRole_maybe_helper (SubCo co)  = Just co+    setNominalRole_maybe_helper co@(Refl _) = Just co+    setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co+    setNominalRole_maybe_helper (TyConAppCo Representational tc cos)+      = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos+           ; return $ TyConAppCo Nominal tc cos' }+    setNominalRole_maybe_helper (FunCo Representational co1 co2)+      = do { co1' <- setNominalRole_maybe Representational co1+           ; co2' <- setNominalRole_maybe Representational co2+           ; return $ FunCo Nominal co1' co2'+           }+    setNominalRole_maybe_helper (SymCo co)+      = SymCo <$> setNominalRole_maybe_helper co+    setNominalRole_maybe_helper (TransCo co1 co2)+      = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2+    setNominalRole_maybe_helper (AppCo co1 co2)+      = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2+    setNominalRole_maybe_helper (ForAllCo tv kind_co co)+      = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co+    setNominalRole_maybe_helper (NthCo _r n co)+      -- NB, this case recurses via setNominalRole_maybe, not+      -- setNominalRole_maybe_helper!+      = NthCo Nominal n <$> setNominalRole_maybe (coercionRole co) co+    setNominalRole_maybe_helper (InstCo co arg)+      = InstCo <$> setNominalRole_maybe_helper co <*> pure arg+    setNominalRole_maybe_helper (UnivCo prov _ co1 co2)+      | case prov of PhantomProv _    -> False  -- should always be phantom+                     ProofIrrelProv _ -> True   -- it's always safe+                     PluginProv _     -> False  -- who knows? This choice is conservative.+      = Just $ UnivCo prov Nominal co1 co2+    setNominalRole_maybe_helper _ = Nothing++-- | Make a phantom coercion between two types. The coercion passed+-- in must be a nominal coercion between the kinds of the+-- types.+mkPhantomCo :: Coercion -> Type -> Type -> Coercion+mkPhantomCo h t1 t2+  = mkUnivCo (PhantomProv h) Phantom t1 t2++-- takes any coercion and turns it into a Phantom coercion+toPhantomCo :: Coercion -> Coercion+toPhantomCo co+  = mkPhantomCo (mkKindCo co) ty1 ty2+  where Pair ty1 ty2 = coercionKind co++-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational+applyRoles :: TyCon -> [Coercion] -> [Coercion]+applyRoles tc cos+  = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos++-- the Role parameter is the Role of the TyConAppCo+-- defined here because this is intimately concerned with the implementation+-- of TyConAppCo+-- Always returns an infinite list (with a infinite tail of Nominal)+tyConRolesX :: Role -> TyCon -> [Role]+tyConRolesX Representational tc = tyConRolesRepresentational tc+tyConRolesX role             _  = repeat role++-- Returns the roles of the parameters of a tycon, with an infinite tail+-- of Nominal+tyConRolesRepresentational :: TyCon -> [Role]+tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal++nthRole :: Role -> TyCon -> Int -> Role+nthRole Nominal _ _ = Nominal+nthRole Phantom _ _ = Phantom+nthRole Representational tc n+  = (tyConRolesRepresentational tc) `getNth` n++ltRole :: Role -> Role -> Bool+-- Is one role "less" than another?+--     Nominal < Representational < Phantom+ltRole Phantom          _       = False+ltRole Representational Phantom = True+ltRole Representational _       = False+ltRole Nominal          Nominal = False+ltRole Nominal          _       = True++-------------------------------++-- | like mkKindCo, but aggressively & recursively optimizes to avoid using+-- a KindCo constructor. The output role is nominal.+promoteCoercion :: Coercion -> CoercionN++-- First cases handles anything that should yield refl.+promoteCoercion co = case co of++    _ | ki1 `eqType` ki2+      -> mkNomReflCo (typeKind ty1)+     -- no later branch should return refl+     --    The ASSERT( False )s throughout+     -- are these cases explicitly, but they should never fire.++    Refl _ -> ASSERT( False )+              mkNomReflCo ki1++    GRefl _ _ MRefl -> ASSERT( False )+                       mkNomReflCo ki1++    GRefl _ _ (MCo co) -> co++    TyConAppCo _ tc args+      | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args+      -> co'+      | otherwise+      -> mkKindCo co++    AppCo co1 arg+      | Just co' <- instCoercion (coercionKind (mkKindCo co1))+                                 (promoteCoercion co1) arg+      -> co'+      | otherwise+      -> mkKindCo co++    ForAllCo tv _ g+      | isTyVar tv+      -> promoteCoercion g++    ForAllCo _ _ _+      -> ASSERT( False )+         mkNomReflCo liftedTypeKind+      -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep++    FunCo _ _ _+      -> ASSERT( False )+         mkNomReflCo liftedTypeKind++    CoVarCo {}     -> mkKindCo co+    HoleCo {}      -> mkKindCo co+    AxiomInstCo {} -> mkKindCo co+    AxiomRuleCo {} -> mkKindCo co++    UnivCo (PhantomProv kco) _ _ _    -> kco+    UnivCo (ProofIrrelProv kco) _ _ _ -> kco+    UnivCo (PluginProv _) _ _ _       -> mkKindCo co++    SymCo g+      -> mkSymCo (promoteCoercion g)++    TransCo co1 co2+      -> mkTransCo (promoteCoercion co1) (promoteCoercion co2)++    NthCo _ n co1+      | Just (_, args) <- splitTyConAppCo_maybe co1+      , args `lengthExceeds` n+      -> promoteCoercion (args !! n)++      | Just _ <- splitForAllCo_maybe co+      , n == 0+      -> ASSERT( False ) mkNomReflCo liftedTypeKind++      | otherwise+      -> mkKindCo co++    LRCo lr co1+      | Just (lco, rco) <- splitAppCo_maybe co1+      -> case lr of+           CLeft  -> promoteCoercion lco+           CRight -> promoteCoercion rco++      | otherwise+      -> mkKindCo co++    InstCo g _+      | isForAllTy_ty ty1+      -> ASSERT( isForAllTy_ty ty2 )+         promoteCoercion g+      | otherwise+      -> ASSERT( False)+         mkNomReflCo liftedTypeKind+           -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep++    KindCo _+      -> ASSERT( False )+         mkNomReflCo liftedTypeKind++    SubCo g+      -> promoteCoercion g++  where+    Pair ty1 ty2 = coercionKind co+    ki1 = typeKind ty1+    ki2 = typeKind ty2++-- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@,+-- where @g' = promoteCoercion (h w)@.+-- fails if this is not possible, if @g@ coerces between a forall and an ->+-- or if second parameter has a representational role and can't be used+-- with an InstCo.+instCoercion :: Pair Type -- g :: lty ~ rty+             -> CoercionN  -- ^  must be nominal+             -> Coercion+             -> Maybe CoercionN+instCoercion (Pair lty rty) g w+  | (isForAllTy_ty lty && isForAllTy_ty rty)+  || (isForAllTy_co lty && isForAllTy_co rty)+  , Just w' <- setNominalRole_maybe (coercionRole w) w+    -- g :: (forall t1. t2) ~ (forall t1. t3)+    -- w :: s1 ~ s2+    -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2]+  = Just $ mkInstCo g w'+  | isFunTy lty && isFunTy rty+    -- g :: (t1 -> t2) ~ (t3 -> t4)+    -- returns t2 ~ t4+  = Just $ mkNthCo Nominal 3 g -- extract result type, which is the 4th argument to (->)+  | otherwise -- one forall, one funty...+  = Nothing++-- | Repeated use of 'instCoercion'+instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN+instCoercions g ws+  = let arg_ty_pairs = map coercionKind ws in+    snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws)+  where+    go :: (Pair Type, Coercion) -> (Pair Type, Coercion)+       -> Maybe (Pair Type, Coercion)+    go (g_tys, g) (w_tys, w)+      = do { g' <- instCoercion g_tys g w+           ; return (piResultTy <$> g_tys <*> w_tys, g') }++-- | Creates a new coercion with both of its types casted by different casts+-- @castCoercionKind g r t1 t2 h1 h2@, where @g :: t1 ~r t2@,+-- has type @(t1 |> h1) ~r (t2 |> h2)@.+-- @h1@ and @h2@ must be nominal.+castCoercionKind :: Coercion -> Role -> Type -> Type+                 -> CoercionN -> CoercionN -> Coercion+castCoercionKind g r t1 t2 h1 h2+  = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g)++-- | Creates a new coercion with both of its types casted by different casts+-- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@,+-- has type @(t1 |> h1) ~r (t2 |> h2)@.+-- @h1@ and @h2@ must be nominal.+-- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for)+-- Use @castCoercionKind@ instead if @t1@, @t2@, and @r@ are known beforehand.+castCoercionKindI :: Coercion -> CoercionN -> CoercionN -> Coercion+castCoercionKindI g h1 h2+  = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g)+  where (Pair t1 t2, r) = coercionKindRole g++-- See note [Newtype coercions] in GHC.Core.TyCon++mkPiCos :: Role -> [Var] -> Coercion -> Coercion+mkPiCos r vs co = foldr (mkPiCo r) co vs++-- | Make a forall 'Coercion', where both types related by the coercion+-- are quantified over the same variable.+mkPiCo  :: Role -> Var -> Coercion -> Coercion+mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co+              | isCoVar v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) )+                  -- We didn't call mkForAllCo here because if v does not appear+                  -- in co, the argement coercion will be nominal. But here we+                  -- want it to be r. It is only called in 'mkPiCos', which is+                  -- only used in GHC.Core.Op.Simplify.Utils, where we are sure for+                  -- now (Aug 2018) v won't occur in co.+                            mkFunCo r (mkReflCo r (varType v)) co+              | otherwise = mkFunCo r (mkReflCo r (varType v)) co++-- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2+-- The first coercion might be lifted or unlifted; thus the ~? above+-- Lifted and unlifted equalities take different numbers of arguments,+-- so we have to make sure to supply the right parameter to decomposeCo.+-- Also, note that the role of the first coercion is the same as the role of+-- the equalities related by the second coercion. The second coercion is+-- itself always representational.+mkCoCast :: Coercion -> CoercionR -> Coercion+mkCoCast c g+  | (g2:g1:_) <- reverse co_list+  = mkSymCo g1 `mkTransCo` c `mkTransCo` g2++  | otherwise+  = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g))+  where+    -- g  :: (s1 ~# t1) ~# (s2 ~# t2)+    -- g1 :: s1 ~# s2+    -- g2 :: t1 ~# t2+    (tc, _) = splitTyConApp (coercionLKind g)+    co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc)++{-+%************************************************************************+%*                                                                      *+            Newtypes+%*                                                                      *+%************************************************************************+-}++-- | If @co :: T ts ~ rep_ty@ then:+--+-- > instNewTyCon_maybe T ts = Just (rep_ty, co)+--+-- Checks for a newtype, and for being saturated+instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)+instNewTyCon_maybe tc tys+  | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc  -- Check for newtype+  , tvs `leLength` tys                                    -- Check saturated enough+  = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys [])+  | otherwise+  = Nothing++{-+************************************************************************+*                                                                      *+         Type normalisation+*                                                                      *+************************************************************************+-}++-- | A function to check if we can reduce a type by one step. Used+-- with 'topNormaliseTypeX'.+type NormaliseStepper ev = RecTcChecker+                         -> TyCon     -- tc+                         -> [Type]    -- tys+                         -> NormaliseStepResult ev++-- | The result of stepping in a normalisation function.+-- See 'topNormaliseTypeX'.+data NormaliseStepResult ev+  = NS_Done   -- ^ Nothing more to do+  | NS_Abort  -- ^ Utter failure. The outer function should fail too.+  | NS_Step RecTcChecker Type ev    -- ^ We stepped, yielding new bits;+                                    -- ^ ev is evidence;+                                    -- Usually a co :: old type ~ new type++mapStepResult :: (ev1 -> ev2)+              -> NormaliseStepResult ev1 -> NormaliseStepResult ev2+mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev)+mapStepResult _ NS_Done                 = NS_Done+mapStepResult _ NS_Abort                = NS_Abort++-- | Try one stepper and then try the next, if the first doesn't make+-- progress.+-- So if it returns NS_Done, it means that both steppers are satisfied+composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev+                -> NormaliseStepper ev+composeSteppers step1 step2 rec_nts tc tys+  = case step1 rec_nts tc tys of+      success@(NS_Step {}) -> success+      NS_Done              -> step2 rec_nts tc tys+      NS_Abort             -> NS_Abort++-- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into+-- a loop. If it would fall into a loop, it produces 'NS_Abort'.+unwrapNewTypeStepper :: NormaliseStepper Coercion+unwrapNewTypeStepper rec_nts tc tys+  | Just (ty', co) <- instNewTyCon_maybe tc tys+  = case checkRecTc rec_nts tc of+      Just rec_nts' -> NS_Step rec_nts' ty' co+      Nothing       -> NS_Abort++  | otherwise+  = NS_Done++-- | A general function for normalising the top-level of a type. It continues+-- to use the provided 'NormaliseStepper' until that function fails, and then+-- this function returns. The roles of the coercions produced by the+-- 'NormaliseStepper' must all be the same, which is the role returned from+-- the call to 'topNormaliseTypeX'.+--+-- Typically ev is Coercion.+--+-- If topNormaliseTypeX step plus ty = Just (ev, ty')+-- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty'+-- and ev = ev1 `plus` ev2 `plus` ... `plus` evn+-- If it returns Nothing then no newtype unwrapping could happen+topNormaliseTypeX :: NormaliseStepper ev -> (ev -> ev -> ev)+                  -> Type -> Maybe (ev, Type)+topNormaliseTypeX stepper plus ty+ | Just (tc, tys) <- splitTyConApp_maybe ty+ , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys+ = go rec_nts ev ty'+ | otherwise+ = Nothing+ where+    go rec_nts ev ty+      | Just (tc, tys) <- splitTyConApp_maybe ty+      = case stepper rec_nts tc tys of+          NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty'+          NS_Done  -> Just (ev, ty)+          NS_Abort -> Nothing++      | otherwise+      = Just (ev, ty)++topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)+-- ^ Sometimes we want to look through a @newtype@ and get its associated coercion.+-- This function strips off @newtype@ layers enough to reveal something that isn't+-- a @newtype@.  Specifically, here's the invariant:+--+-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty')+--+-- then (a)  @co : ty0 ~ ty'@.+--      (b)  ty' is not a newtype.+--+-- The function returns @Nothing@ for non-@newtypes@,+-- or unsaturated applications+--+-- This function does *not* look through type families, because it has no access to+-- the type family environment. If you do have that at hand, consider to use+-- topNormaliseType_maybe, which should be a drop-in replacement for+-- topNormaliseNewType_maybe+-- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty'+topNormaliseNewType_maybe ty+  = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty++{-+%************************************************************************+%*                                                                      *+                   Comparison of coercions+%*                                                                      *+%************************************************************************+-}++-- | Syntactic equality of coercions+eqCoercion :: Coercion -> Coercion -> Bool+eqCoercion = eqType `on` coercionType++-- | Compare two 'Coercion's, with respect to an RnEnv2+eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool+eqCoercionX env = eqTypeX env `on` coercionType++{-+%************************************************************************+%*                                                                      *+                   "Lifting" substitution+           [(TyCoVar,Coercion)] -> Type -> Coercion+%*                                                                      *+%************************************************************************++Note [Lifting coercions over types: liftCoSubst]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The KPUSH rule deals with this situation+   data T a = K (a -> Maybe a)+   g :: T t1 ~ T t2+   x :: t1 -> Maybe t1++   case (K @t1 x) |> g of+     K (y:t2 -> Maybe t2) -> rhs++We want to push the coercion inside the constructor application.+So we do this++   g' :: t1~t2  =  Nth 0 g++   case K @t2 (x |> g' -> Maybe g') of+     K (y:t2 -> Maybe t2) -> rhs++The crucial operation is that we+  * take the type of K's argument: a -> Maybe a+  * and substitute g' for a+thus giving *coercion*.  This is what liftCoSubst does.++In the presence of kind coercions, this is a bit+of a hairy operation. So, we refer you to the paper introducing kind coercions,+available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf++Note [extendLiftingContextEx]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider we have datatype+  K :: \/k. \/a::k. P -> T k  -- P be some type+  g :: T k1 ~ T k2++  case (K @k1 @t1 x) |> g of+    K y -> rhs++We want to push the coercion inside the constructor application.+We first get the coercion mapped by the universal type variable k:+   lc = k |-> Nth 0 g :: k1~k2++Here, the important point is that the kind of a is coerced, and P might be+dependent on the existential type variable a.+Thus we first get the coercion of a's kind+   g2 = liftCoSubst lc k :: k1 ~ k2++Then we store a new mapping into the lifting context+   lc2 = a |-> (t1 ~ t1 |> g2), lc++So later when we can correctly deal with the argument type P+   liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)]++This is exactly what extendLiftingContextEx does.+* For each (tyvar:k, ty) pair, we product the mapping+    tyvar |-> (ty ~ ty |> (liftCoSubst lc k))+* For each (covar:s1~s2, ty) pair, we produce the mapping+    covar |-> (co ~ co')+    co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2'++This follows the lifting context extension definition in the+"FC with Explicit Kind Equality" paper.+-}++-- ----------------------------------------------------+-- See Note [Lifting coercions over types: liftCoSubst]+-- ----------------------------------------------------++data LiftingContext = LC TCvSubst LiftCoEnv+  -- in optCoercion, we need to lift when optimizing InstCo.+  -- See Note [Optimising InstCo] in GHC.Core.Coercion.Opt+  -- We thus propagate the substitution from GHC.Core.Coercion.Opt here.++instance Outputable LiftingContext where+  ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env)++type LiftCoEnv = VarEnv Coercion+     -- Maps *type variables* to *coercions*.+     -- That's the whole point of this function!+     -- Also maps coercion variables to ProofIrrelCos.++-- like liftCoSubstWith, but allows for existentially-bound types as well+liftCoSubstWithEx :: Role          -- desired role for output coercion+                  -> [TyVar]       -- universally quantified tyvars+                  -> [Coercion]    -- coercions to substitute for those+                  -> [TyCoVar]     -- existentially quantified tycovars+                  -> [Type]        -- types and coercions to be bound to ex vars+                  -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args)+liftCoSubstWithEx role univs omegas exs rhos+  = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas)+        psi   = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos)+    in (ty_co_subst psi role, substTys (lcSubstRight psi) (mkTyCoVarTys exs))++liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion+liftCoSubstWith r tvs cos ty+  = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty++-- | @liftCoSubst role lc ty@ produces a coercion (at role @role@)+-- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where+-- @lc_left@ is a substitution mapping type variables to the left-hand+-- types of the mapped coercions in @lc@, and similar for @lc_right@.+liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion+liftCoSubst r lc@(LC subst env) ty+  | isEmptyVarEnv env = mkReflCo r (substTy subst ty)+  | otherwise         = ty_co_subst lc r ty++emptyLiftingContext :: InScopeSet -> LiftingContext+emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv++mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext+mkLiftingContext pairs+  = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs))+       (mkVarEnv pairs)++mkSubstLiftingContext :: TCvSubst -> LiftingContext+mkSubstLiftingContext subst = LC subst emptyVarEnv++-- | Extend a lifting context with a new mapping.+extendLiftingContext :: LiftingContext  -- ^ original LC+                     -> TyCoVar         -- ^ new variable to map...+                     -> Coercion        -- ^ ...to this lifted version+                     -> LiftingContext+    -- mappings to reflexive coercions are just substitutions+extendLiftingContext (LC subst env) tv arg+  | Just (ty, _) <- isReflCo_maybe arg+  = LC (extendTCvSubst subst tv ty) env+  | otherwise+  = LC subst (extendVarEnv env tv arg)++-- | Extend a lifting context with a new mapping, and extend the in-scope set+extendLiftingContextAndInScope :: LiftingContext  -- ^ Original LC+                               -> TyCoVar         -- ^ new variable to map...+                               -> Coercion        -- ^ to this coercion+                               -> LiftingContext+extendLiftingContextAndInScope (LC subst env) tv co+  = extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co++-- | Extend a lifting context with existential-variable bindings.+-- See Note [extendLiftingContextEx]+extendLiftingContextEx :: LiftingContext    -- ^ original lifting context+                       -> [(TyCoVar,Type)]  -- ^ ex. var / value pairs+                       -> LiftingContext+-- Note that this is more involved than extendLiftingContext. That function+-- takes a coercion to extend with, so it's assumed that the caller has taken+-- into account any of the kind-changing stuff worried about here.+extendLiftingContextEx lc [] = lc+extendLiftingContextEx lc@(LC subst env) ((v,ty):rest)+-- This function adds bindings for *Nominal* coercions. Why? Because it+-- works with existentially bound variables, which are considered to have+-- nominal roles.+  | isTyVar v+  = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty)+                 (extendVarEnv env v $+                  mkGReflRightCo Nominal+                                 ty+                                 (ty_co_subst lc Nominal (tyVarKind v)))+    in extendLiftingContextEx lc' rest+  | CoercionTy co <- ty+  = -- co      :: s1 ~r s2+    -- lift_s1 :: s1 ~r s1'+    -- lift_s2 :: s2 ~r s2'+    -- kco     :: (s1 ~r s2) ~N (s1' ~r s2')+    ASSERT( isCoVar v )+    let (_, _, s1, s2, r) = coVarKindsTypesRole v+        lift_s1 = ty_co_subst lc r s1+        lift_s2 = ty_co_subst lc r s2+        kco     = mkTyConAppCo Nominal (equalityTyCon r)+                               [ mkKindCo lift_s1, mkKindCo lift_s2+                               , lift_s1         , lift_s2          ]+        lc'     = LC (subst `extendTCvInScopeSet` tyCoVarsOfCo co)+                     (extendVarEnv env v+                        (mkProofIrrelCo Nominal kco co $+                          (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2))+    in extendLiftingContextEx lc' rest+  | otherwise+  = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty)+++-- | Erase the environments in a lifting context+zapLiftingContext :: LiftingContext -> LiftingContext+zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv++-- | Like 'substForAllCoBndr', but works on a lifting context+substForAllCoBndrUsingLC :: Bool+                            -> (Coercion -> Coercion)+                            -> LiftingContext -> TyCoVar -> Coercion+                            -> (LiftingContext, TyCoVar, Coercion)+substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co+  = (LC subst' lc_env, tv', co')+  where+    (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co++-- | The \"lifting\" operation which substitutes coercions for type+--   variables in a type to produce a coercion.+--+--   For the inverse operation, see 'liftCoMatch'+ty_co_subst :: LiftingContext -> Role -> Type -> Coercion+ty_co_subst lc role ty+  = go role ty+  where+    go :: Role -> Type -> Coercion+    go r ty                | Just ty' <- coreView ty+                           = go r ty'+    go Phantom ty          = lift_phantom ty+    go r (TyVarTy tv)      = expectJust "ty_co_subst bad roles" $+                             liftCoSubstTyVar lc r tv+    go r (AppTy ty1 ty2)   = mkAppCo (go r ty1) (go Nominal ty2)+    go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys)+    go r (FunTy _ ty1 ty2) = mkFunCo r (go r ty1) (go r ty2)+    go r t@(ForAllTy (Bndr v _) ty)+       = let (lc', v', h) = liftCoSubstVarBndr lc v+             body_co = ty_co_subst lc' r ty in+         if isTyVar v' || almostDevoidCoVarOfCo v' body_co+           -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo+           -- imposes an extra restriction on where a covar can appear. See last+           -- wrinkle in Note [Unused coercion variable in ForAllCo].+           -- We specifically check for this and panic because we know that+           -- there's a hole in the type system here, and we'd rather panic than+           -- fall into it.+         then mkForAllCo v' h body_co+         else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t)+    go r ty@(LitTy {})     = ASSERT( r == Nominal )+                             mkNomReflCo ty+    go r (CastTy ty co)    = castCoercionKindI (go r ty) (substLeftCo lc co)+                                                         (substRightCo lc co)+    go r (CoercionTy co)   = mkProofIrrelCo r kco (substLeftCo lc co)+                                                  (substRightCo lc co)+      where kco = go Nominal (coercionType co)++    lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty))+                                  (substTy (lcSubstLeft  lc) ty)+                                  (substTy (lcSubstRight lc) ty)++{-+Note [liftCoSubstTyVar]+~~~~~~~~~~~~~~~~~~~~~~~~~+This function can fail if a coercion in the environment is of too low a role.++liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and+also in matchAxiom in GHC.Core.Coercion.Opt. From liftCoSubst, the so-called lifting+lemma guarantees that the roles work out. If we fail in this+case, we really should panic -- something is deeply wrong. But, in matchAxiom,+failing is fine. matchAxiom is trying to find a set of coercions+that match, but it may fail, and this is healthy behavior.+-}++-- See Note [liftCoSubstTyVar]+liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion+liftCoSubstTyVar (LC subst env) r v+  | Just co_arg <- lookupVarEnv env v+  = downgradeRole_maybe r (coercionRole co_arg) co_arg++  | otherwise+  = Just $ mkReflCo r (substTyVar subst v)++{- Note [liftCoSubstVarBndr]++callback:+  We want 'liftCoSubstVarBndrUsing' to be general enough to be reused in+  FamInstEnv, therefore the input arg 'fun' returns a pair with polymorphic type+  in snd.+  However in 'liftCoSubstVarBndr', we don't need the snd, so we use unit and+  ignore the fourth component of the return value.++liftCoSubstTyVarBndrUsing:+  Given+    forall tv:k. t+  We want to get+    forall (tv:k1) (kind_co :: k1 ~ k2) body_co++  We lift the kind k to get the kind_co+    kind_co = ty_co_subst k :: k1 ~ k2++  Now in the LiftingContext, we add the new mapping+    tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2)++liftCoSubstCoVarBndrUsing:+  Given+    forall cv:(s1 ~ s2). t+  We want to get+    forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co++  We lift s1 and s2 respectively to get+    eta1 :: s1' ~ t1+    eta2 :: s2' ~ t2+  And+    kind_co = TyConAppCo Nominal (~#) eta1 eta2++  Now in the liftingContext, we add the new mapping+    cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2)+-}++-- See Note [liftCoSubstVarBndr]+liftCoSubstVarBndr :: LiftingContext -> TyCoVar+                   -> (LiftingContext, TyCoVar, Coercion)+liftCoSubstVarBndr lc tv+  = let (lc', tv', h, _) = liftCoSubstVarBndrUsing callback lc tv in+    (lc', tv', h)+  where+    callback lc' ty' = (ty_co_subst lc' Nominal ty', ())++-- the callback must produce a nominal coercion+liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))+                           -> LiftingContext -> TyCoVar+                           -> (LiftingContext, TyCoVar, CoercionN, a)+liftCoSubstVarBndrUsing fun lc old_var+  | isTyVar old_var+  = liftCoSubstTyVarBndrUsing fun lc old_var+  | otherwise+  = liftCoSubstCoVarBndrUsing fun lc old_var++-- Works for tyvar binder+liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))+                           -> LiftingContext -> TyVar+                           -> (LiftingContext, TyVar, CoercionN, a)+liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var+  = ASSERT( isTyVar old_var )+    ( LC (subst `extendTCvInScope` new_var) new_cenv+    , new_var, eta, stuff )+  where+    old_kind     = tyVarKind old_var+    (eta, stuff) = fun lc old_kind+    k1           = coercionLKind eta+    new_var      = uniqAway (getTCvInScope subst) (setVarType old_var k1)++    lifted   = mkGReflRightCo Nominal (TyVarTy new_var) eta+               -- :: new_var ~ new_var |> eta+    new_cenv = extendVarEnv cenv old_var lifted++-- Works for covar binder+liftCoSubstCoVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))+                           -> LiftingContext -> CoVar+                           -> (LiftingContext, CoVar, CoercionN, a)+liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var+  = ASSERT( isCoVar old_var )+    ( LC (subst `extendTCvInScope` new_var) new_cenv+    , new_var, kind_co, stuff )+  where+    old_kind     = coVarKind old_var+    (eta, stuff) = fun lc old_kind+    k1           = coercionLKind eta+    new_var      = uniqAway (getTCvInScope subst) (setVarType old_var k1)++    -- old_var :: s1  ~r s2+    -- eta     :: (s1' ~r s2') ~N (t1 ~r t2)+    -- eta1    :: s1' ~r t1+    -- eta2    :: s2' ~r t2+    -- co1     :: s1' ~r s2'+    -- co2     :: t1  ~r t2+    -- kind_co :: (s1' ~r s2') ~N (t1 ~r t2)+    -- lifted  :: co1 ~N co2++    role   = coVarRole old_var+    eta'   = downgradeRole role Nominal eta+    eta1   = mkNthCo role 2 eta'+    eta2   = mkNthCo role 3 eta'++    co1     = mkCoVarCo new_var+    co2     = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2+    kind_co = mkTyConAppCo Nominal (equalityTyCon role)+                           [ mkKindCo co1, mkKindCo co2+                           , co1         , co2          ]+    lifted  = mkProofIrrelCo Nominal kind_co co1 co2++    new_cenv = extendVarEnv cenv old_var lifted++-- | Is a var in the domain of a lifting context?+isMappedByLC :: TyCoVar -> LiftingContext -> Bool+isMappedByLC tv (LC _ env) = tv `elemVarEnv` env++-- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1+-- If [a |-> (g1, g2)] is in the substitution, substitute a for g1+substLeftCo :: LiftingContext -> Coercion -> Coercion+substLeftCo lc co+  = substCo (lcSubstLeft lc) co++-- Ditto, but for t2 and g2+substRightCo :: LiftingContext -> Coercion -> Coercion+substRightCo lc co+  = substCo (lcSubstRight lc) co++-- | Apply "sym" to all coercions in a 'LiftCoEnv'+swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv+swapLiftCoEnv = mapVarEnv mkSymCo++lcSubstLeft :: LiftingContext -> TCvSubst+lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env++lcSubstRight :: LiftingContext -> TCvSubst+lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env++liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst+liftEnvSubstLeft = liftEnvSubst pFst++liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst+liftEnvSubstRight = liftEnvSubst pSnd++liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst+liftEnvSubst selector subst lc_env+  = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst+  where+    pairs            = nonDetUFMToList lc_env+                       -- It's OK to use nonDetUFMToList here because we+                       -- immediately forget the ordering by creating+                       -- a VarEnv+    (tpairs, cpairs) = partitionWith ty_or_co pairs+    tenv             = mkVarEnv_Directly tpairs+    cenv             = mkVarEnv_Directly cpairs++    ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion)+    ty_or_co (u, co)+      | Just equality_co <- isCoercionTy_maybe equality_ty+      = Right (u, equality_co)+      | otherwise+      = Left (u, equality_ty)+      where+        equality_ty = selector (coercionKind co)++-- | Extract the underlying substitution from the LiftingContext+lcTCvSubst :: LiftingContext -> TCvSubst+lcTCvSubst (LC subst _) = subst++-- | Get the 'InScopeSet' from a 'LiftingContext'+lcInScopeSet :: LiftingContext -> InScopeSet+lcInScopeSet (LC subst _) = getTCvInScope subst++{-+%************************************************************************+%*                                                                      *+            Sequencing on coercions+%*                                                                      *+%************************************************************************+-}++seqMCo :: MCoercion -> ()+seqMCo MRefl    = ()+seqMCo (MCo co) = seqCo co++seqCo :: Coercion -> ()+seqCo (Refl ty)                 = seqType ty+seqCo (GRefl r ty mco)          = r `seq` seqType ty `seq` seqMCo mco+seqCo (TyConAppCo r tc cos)     = r `seq` tc `seq` seqCos cos+seqCo (AppCo co1 co2)           = seqCo co1 `seq` seqCo co2+seqCo (ForAllCo tv k co)        = seqType (varType tv) `seq` seqCo k+                                                       `seq` seqCo co+seqCo (FunCo r co1 co2)         = r `seq` seqCo co1 `seq` seqCo co2+seqCo (CoVarCo cv)              = cv `seq` ()+seqCo (HoleCo h)                = coHoleCoVar h `seq` ()+seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos+seqCo (UnivCo p r t1 t2)+  = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2+seqCo (SymCo co)                = seqCo co+seqCo (TransCo co1 co2)         = seqCo co1 `seq` seqCo co2+seqCo (NthCo r n co)            = r `seq` n `seq` seqCo co+seqCo (LRCo lr co)              = lr `seq` seqCo co+seqCo (InstCo co arg)           = seqCo co `seq` seqCo arg+seqCo (KindCo co)               = seqCo co+seqCo (SubCo co)                = seqCo co+seqCo (AxiomRuleCo _ cs)        = seqCos cs++seqProv :: UnivCoProvenance -> ()+seqProv (PhantomProv co)    = seqCo co+seqProv (ProofIrrelProv co) = seqCo co+seqProv (PluginProv _)      = ()++seqCos :: [Coercion] -> ()+seqCos []       = ()+seqCos (co:cos) = seqCo co `seq` seqCos cos++{-+%************************************************************************+%*                                                                      *+             The kind of a type, and of a coercion+%*                                                                      *+%************************************************************************+-}++-- | Apply 'coercionKind' to multiple 'Coercion's+coercionKinds :: [Coercion] -> Pair [Type]+coercionKinds tys = sequenceA $ map coercionKind tys++-- | Get a coercion's kind and role.+coercionKindRole :: Coercion -> (Pair Type, Role)+coercionKindRole co = (coercionKind co, coercionRole co)++coercionType :: Coercion -> Type+coercionType co = case coercionKindRole co of+  (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2++------------------+-- | If it is the case that+--+-- > c :: (t1 ~ t2)+--+-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@.++coercionKind :: Coercion -> Pair Type+coercionKind co = Pair (coercionLKind co) (coercionRKind co)++coercionLKind :: Coercion -> Type+coercionLKind co+  = go co+  where+    go (Refl ty)                = ty+    go (GRefl _ ty _)           = ty+    go (TyConAppCo _ tc cos)    = mkTyConApp tc (map go cos)+    go (AppCo co1 co2)          = mkAppTy (go co1) (go co2)+    go (ForAllCo tv1 _ co1)     = mkTyCoInvForAllTy tv1 (go co1)+    go (FunCo _ co1 co2)        = mkVisFunTy (go co1) (go co2)+    go (CoVarCo cv)             = coVarLType cv+    go (HoleCo h)               = coVarLType (coHoleCoVar h)+    go (UnivCo _ _ ty1 _)       = ty1+    go (SymCo co)               = coercionRKind co+    go (TransCo co1 _)          = go co1+    go (LRCo lr co)             = pickLR lr (splitAppTy (go co))+    go (InstCo aco arg)         = go_app aco [go arg]+    go (KindCo co)              = typeKind (go co)+    go (SubCo co)               = go co+    go (NthCo _ d co)           = go_nth d (go co)+    go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos)+    go (AxiomRuleCo ax cos)     = pFst $ expectJust "coercionKind" $+                                  coaxrProves ax $ map coercionKind cos++    go_ax_inst ax ind tys+      | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                   , cab_lhs = lhs } <- coAxiomNthBranch ax ind+      , let (tys1, cotys1) = splitAtList tvs tys+            cos1           = map stripCoercionTy cotys1+      = ASSERT( tys `equalLength` (tvs ++ cvs) )+                  -- Invariant of AxiomInstCo: cos should+                  -- exactly saturate the axiom branch+        substTyWith tvs tys1       $+        substTyWithCoVars cvs cos1 $+        mkTyConApp (coAxiomTyCon ax) lhs++    go_app :: Coercion -> [Type] -> Type+    -- Collect up all the arguments and apply all at once+    -- See Note [Nested InstCos]+    go_app (InstCo co arg) args = go_app co (go arg:args)+    go_app co              args = piResultTys (go co) args++go_nth :: Int -> Type -> Type+go_nth d ty+  | Just args <- tyConAppArgs_maybe ty+  = ASSERT( args `lengthExceeds` d )+    args `getNth` d++  | d == 0+  , Just (tv,_) <- splitForAllTy_maybe ty+  = tyVarKind tv++  | otherwise+  = pprPanic "coercionLKind:nth" (ppr d <+> ppr ty)++coercionRKind :: Coercion -> Type+coercionRKind co+  = go co+  where+    go (Refl ty)                = ty+    go (GRefl _ ty MRefl)       = ty+    go (GRefl _ ty (MCo co1))   = mkCastTy ty co1+    go (TyConAppCo _ tc cos)    = mkTyConApp tc (map go cos)+    go (AppCo co1 co2)          = mkAppTy (go co1) (go co2)+    go (CoVarCo cv)             = coVarRType cv+    go (HoleCo h)               = coVarRType (coHoleCoVar h)+    go (FunCo _ co1 co2)        = mkVisFunTy (go co1) (go co2)+    go (UnivCo _ _ _ ty2)       = ty2+    go (SymCo co)               = coercionLKind co+    go (TransCo _ co2)          = go co2+    go (LRCo lr co)             = pickLR lr (splitAppTy (go co))+    go (InstCo aco arg)         = go_app aco [go arg]+    go (KindCo co)              = typeKind (go co)+    go (SubCo co)               = go co+    go (NthCo _ d co)           = go_nth d (go co)+    go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos)+    go (AxiomRuleCo ax cos)     = pSnd $ expectJust "coercionKind" $+                                  coaxrProves ax $ map coercionKind cos++    go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar+       | isGReflCo k_co           = mkTyCoInvForAllTy tv1 (go co1)+         -- kind_co always has kind @Type@, thus @isGReflCo@+       | otherwise                = go_forall empty_subst co+       where+         empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co)++    go_ax_inst ax ind tys+      | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                   , cab_rhs = rhs } <- coAxiomNthBranch ax ind+      , let (tys2, cotys2) = splitAtList tvs tys+            cos2           = map stripCoercionTy cotys2+      = ASSERT( tys `equalLength` (tvs ++ cvs) )+                  -- Invariant of AxiomInstCo: cos should+                  -- exactly saturate the axiom branch+        substTyWith tvs tys2 $+        substTyWithCoVars cvs cos2 rhs++    go_app :: Coercion -> [Type] -> Type+    -- Collect up all the arguments and apply all at once+    -- See Note [Nested InstCos]+    go_app (InstCo co arg) args = go_app co (go arg:args)+    go_app co              args = piResultTys (go co) args++    go_forall subst (ForAllCo tv1 k_co co)+      -- See Note [Nested ForAllCos]+      | isTyVar tv1+      = mkInvForAllTy tv2 (go_forall subst' co)+      where+        k2  = coercionRKind k_co+        tv2 = setTyVarKind tv1 (substTy subst k2)+        subst' | isGReflCo k_co = extendTCvInScope subst tv1+                 -- kind_co always has kind @Type@, thus @isGReflCo@+               | otherwise      = extendTvSubst (extendTCvInScope subst tv2) tv1 $+                                  TyVarTy tv2 `mkCastTy` mkSymCo k_co++    go_forall subst (ForAllCo cv1 k_co co)+      | isCoVar cv1+      = mkTyCoInvForAllTy cv2 (go_forall subst' co)+      where+        k2 = coercionRKind k_co+        r         = coVarRole cv1+        eta1      = mkNthCo r 2 (downgradeRole r Nominal k_co)+        eta2      = mkNthCo r 3 (downgradeRole r Nominal k_co)++        -- k_co :: (t1 ~r t2) ~N (s1 ~r s2)+        -- k1    = t1 ~r t2+        -- k2    = s1 ~r s2+        -- cv1  :: t1 ~r t2+        -- cv2  :: s1 ~r s2+        -- eta1 :: t1 ~r s1+        -- eta2 :: t2 ~r s2+        -- n_subst  = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2++        cv2     = setVarType cv1 (substTy subst k2)+        n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2)+        subst'  | isReflCo k_co = extendTCvInScope subst cv1+                | otherwise     = extendCvSubst (extendTCvInScope subst cv2)+                                                cv1 n_subst++    go_forall subst other_co+      -- when other_co is not a ForAllCo+      = substTy subst (go other_co)++{-++Note [Nested ForAllCos]+~~~~~~~~~~~~~~~~~~~~~~~++Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an+co)...) )`.   We do not want to perform `n` single-type-variable+substitutions over the kind of `co`; rather we want to do one substitution+which substitutes for all of `a1`, `a2` ... simultaneously.  If we do one+at a time we get the performance hole reported in #11735.++Solution: gather up the type variables for nested `ForAllCos`, and+substitute for them all at once.  Remarkably, for #11735 this single+change reduces /total/ compile time by a factor of more than ten.++-}++-- | Retrieve the role from a coercion.+coercionRole :: Coercion -> Role+coercionRole = go+  where+    go (Refl _) = Nominal+    go (GRefl r _ _) = r+    go (TyConAppCo r _ _) = r+    go (AppCo co1 _) = go co1+    go (ForAllCo _ _ co) = go co+    go (FunCo r _ _) = r+    go (CoVarCo cv) = coVarRole cv+    go (HoleCo h)   = coVarRole (coHoleCoVar h)+    go (AxiomInstCo ax _ _) = coAxiomRole ax+    go (UnivCo _ r _ _)  = r+    go (SymCo co) = go co+    go (TransCo co1 _co2) = go co1+    go (NthCo r _d _co) = r+    go (LRCo {}) = Nominal+    go (InstCo co _) = go co+    go (KindCo {}) = Nominal+    go (SubCo _) = Representational+    go (AxiomRuleCo ax _) = coaxrRole ax++{-+Note [Nested InstCos]+~~~~~~~~~~~~~~~~~~~~~+In #5631 we found that 70% of the entire compilation time was+being spent in coercionKind!  The reason was that we had+   (g @ ty1 @ ty2 .. @ ty100)    -- The "@s" are InstCos+where+   g :: forall a1 a2 .. a100. phi+If we deal with the InstCos one at a time, we'll do this:+   1.  Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi'+   2.  Substitute phi'[ ty100/a100 ], a single tyvar->type subst+But this is a *quadratic* algorithm, and the blew up #5631.+So it's very important to do the substitution simultaneously;+cf Type.piResultTys (which in fact we call here).++-}++-- | Makes a coercion type from two types: the types whose equality+-- is proven by the relevant 'Coercion'+mkCoercionType :: Role -> Type -> Type -> Type+mkCoercionType Nominal          = mkPrimEqPred+mkCoercionType Representational = mkReprPrimEqPred+mkCoercionType Phantom          = \ty1 ty2 ->+  let ki1 = typeKind ty1+      ki2 = typeKind ty2+  in+  TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2]++mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type+mkHeteroCoercionType Nominal          = mkHeteroPrimEqPred+mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred+mkHeteroCoercionType Phantom          = panic "mkHeteroCoercionType"++-- | Creates a primitive type equality predicate.+-- Invariant: the types are not Coercions+mkPrimEqPred :: Type -> Type -> Type+mkPrimEqPred ty1 ty2+  = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2]+  where+    k1 = typeKind ty1+    k2 = typeKind ty2++-- | Makes a lifted equality predicate at the given role+mkPrimEqPredRole :: Role -> Type -> Type -> PredType+mkPrimEqPredRole Nominal          = mkPrimEqPred+mkPrimEqPredRole Representational = mkReprPrimEqPred+mkPrimEqPredRole Phantom          = panic "mkPrimEqPredRole phantom"++-- | Creates a primitive type equality predicate with explicit kinds+mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type+mkHeteroPrimEqPred k1 k2 ty1 ty2 = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2]++-- | Creates a primitive representational type equality predicate+-- with explicit kinds+mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type+mkHeteroReprPrimEqPred k1 k2 ty1 ty2+  = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]++mkReprPrimEqPred :: Type -> Type -> Type+mkReprPrimEqPred ty1  ty2+  = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]+  where+    k1 = typeKind ty1+    k2 = typeKind ty2++-- | Assuming that two types are the same, ignoring coercions, find+-- a nominal coercion between the types. This is useful when optimizing+-- transitivity over coercion applications, where splitting two+-- AppCos might yield different kinds. See Note [EtaAppCo] in+-- GHC.Core.Coercion.Opt.+buildCoercion :: Type -> Type -> CoercionN+buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2+  where+    go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2+               | Just ty2' <- coreView ty2 = go ty1 ty2'++    go (CastTy ty1 co) ty2+      = let co' = go ty1 ty2+            r = coercionRole co'+        in  mkCoherenceLeftCo r ty1 co co'++    go ty1 (CastTy ty2 co)+      = let co' = go ty1 ty2+            r = coercionRole co'+        in  mkCoherenceRightCo r ty2 co co'++    go ty1@(TyVarTy tv1) _tyvarty+      = ASSERT( case _tyvarty of+                  { TyVarTy tv2 -> tv1 == tv2+                  ; _           -> False      } )+        mkNomReflCo ty1++    go (FunTy { ft_arg = arg1, ft_res = res1 })+       (FunTy { ft_arg = arg2, ft_res = res2 })+      = mkFunCo Nominal (go arg1 arg2) (go res1 res2)++    go (TyConApp tc1 args1) (TyConApp tc2 args2)+      = ASSERT( tc1 == tc2 )+        mkTyConAppCo Nominal tc1 (zipWith go args1 args2)++    go (AppTy ty1a ty1b) ty2+      | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2+      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)++    go ty1 (AppTy ty2a ty2b)+      | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1+      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)++    go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2)+      | isTyVar tv1+      = ASSERT( isTyVar tv2 )+        mkForAllCo tv1 kind_co (go ty1 ty2')+      where kind_co  = go (tyVarKind tv1) (tyVarKind tv2)+            in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co+            ty2'     = substTyWithInScope in_scope [tv2]+                         [mkTyVarTy tv1 `mkCastTy` kind_co]+                         ty2++    go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2)+      = ASSERT( isCoVar cv1 && isCoVar cv2 )+        mkForAllCo cv1 kind_co (go ty1 ty2')+      where s1 = varType cv1+            s2 = varType cv2+            kind_co = go s1 s2++            -- s1 = t1 ~r t2+            -- s2 = t3 ~r t4+            -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4)+            -- eta1 :: t1 ~r t3+            -- eta2 :: t2 ~r t4++            r    = coVarRole cv1+            kind_co' = downgradeRole r Nominal kind_co+            eta1 = mkNthCo r 2 kind_co'+            eta2 = mkNthCo r 3 kind_co'++            subst = mkEmptyTCvSubst $ mkInScopeSet $+                      tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co+            ty2'  = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo`+                                                       mkCoVarCo cv1 `mkTransCo`+                                                       eta2)+                            ty2++    go ty1@(LitTy lit1) _lit2+      = ASSERT( case _lit2 of+                  { LitTy lit2 -> lit1 == lit2+                  ; _          -> False        } )+        mkNomReflCo ty1++    go (CoercionTy co1) (CoercionTy co2)+      = mkProofIrrelCo Nominal kind_co co1 co2+      where+        kind_co = go (coercionType co1) (coercionType co2)++    go ty1 ty2+      = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2+                                           , ppr ty1, ppr ty2 ])++{-+%************************************************************************+%*                                                                      *+       Simplifying types+%*                                                                      *+%************************************************************************++The function below morally belongs in TcFlatten, but it is used also in+FamInstEnv, and so lives here.++Note [simplifyArgsWorker]+~~~~~~~~~~~~~~~~~~~~~~~~~+Invariant (F2) of Note [Flattening] says that flattening is homogeneous.+This causes some trouble when flattening a function applied to a telescope+of arguments, perhaps with dependency. For example, suppose++  type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k]++and we wish to flatten the args of (with kind applications explicit)++  F a b (Just a c) (Right a b d) False++where all variables are skolems and++  a :: Type+  b :: Type+  c :: a+  d :: k++  [G] aco :: a ~ fa+  [G] bco :: b ~ fb+  [G] cco :: c ~ fc+  [G] dco :: d ~ fd++The first step is to flatten all the arguments. This is done before calling+simplifyArgsWorker. We start from++  a+  b+  Just a c+  Right a b d+  False++and get++  (fa,                             co1 :: fa ~ a)+  (fb,                             co2 :: fb ~ b)+  (Just fa (fc |> aco) |> co6,     co3 :: (Just fa (fc |> aco) |> co6) ~ (Just a c))+  (Right fa fb (fd |> bco) |> co7, co4 :: (Right fa fb (fd |> bco) |> co7) ~ (Right a b d))+  (False,                          co5 :: False ~ False)++where+  co6 :: Maybe fa ~ Maybe a+  co7 :: Either fa fb ~ Either a b++We now process the flattened args in left-to-right order. The first two args+need no further processing. But now consider the third argument. Let f3 = the flattened+result, Just fa (fc |> aco) |> co6.+This f3 flattened argument has kind (Maybe a), due to+(F2). And yet, when we build the application (F fa fb ...), we need this+argument to have kind (Maybe fa), not (Maybe a). We must cast this argument.+The coercion to use is+determined by the kind of F: we see in F's kind that the third argument has+kind Maybe j. Critically, we also know that the argument corresponding to j+(in our example, a) flattened with a coercion co1. We can thus know the+coercion needed for the 3rd argument is (Maybe (sym co1)), thus building+(f3 |> Maybe (sym co1))++More generally, we must use the Lifting Lemma, as implemented in+Coercion.liftCoSubst. As we work left-to-right, any variable that is a+dependent parameter (j and k, in our example) gets mapped in a lifting context+to the coercion that is output from flattening the corresponding argument (co1+and co2, in our example). Then, after flattening later arguments, we lift the+kind of these arguments in the lifting context that we've be building up.+This coercion is then used to keep the result of flattening well-kinded.++Working through our example, this is what happens:++  1. Extend the (empty) LC with [j |-> co1]. No new casting must be done,+     because the binder associated with the first argument has a closed type (no+     variables).++  2. Extend the LC with [k |-> co2]. No casting to do.++  3. Lifting the kind (Maybe j) with our LC+     yields co8 :: Maybe fa ~ Maybe a. Use (f3 |> sym co8) as the argument to+     F.++  4. Lifting the kind (Either j k) with our LC+     yields co9 :: Either fa fb ~ Either a b. Use (f4 |> sym co9) as the 4th+     argument to F, where f4 is the flattened form of argument 4, written above.++  5. We lift Bool with our LC, getting <Bool>;+     casting has no effect.++We're now almost done, but the new application (F fa fb (f3 |> sym co8) (f4 > sym co9) False)+has the wrong kind. Its kind is [fb], instead of the original [b].+So we must use our LC one last time to lift the result kind [k],+getting res_co :: [fb] ~ [b], and we cast our result.++Accordingly, the final result is++  F fa fb (Just fa (fc |> aco) |> Maybe (sym aco) |> sym (Maybe (sym aco)))+          (Right fa fb (fd |> bco) |> Either (sym aco) (sym bco) |> sym (Either (sym aco) (sym bco)))+          False+            |> [sym bco]++The res_co (in this case, [sym bco])+is returned as the third return value from simplifyArgsWorker.++Note [Last case in simplifyArgsWorker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In writing simplifyArgsWorker's `go`, we know here that args cannot be empty,+because that case is first. We've run out of+binders. But perhaps inner_ki is a tyvar that has been instantiated with a+Π-type.++Here is an example.++  a :: forall (k :: Type). k -> k+  type family Star+  Proxy :: forall j. j -> Type+  axStar :: Star ~ Type+  type family NoWay :: Bool+  axNoWay :: NoWay ~ False+  bo :: Type+  [G] bc :: bo ~ Bool   (in inert set)++  co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star)+  co = forall (j :: sym axStar). (<j> -> sym axStar)++  We are flattening:+  a (forall (j :: Star). (j |> axStar) -> Star)   -- 1+    (Proxy |> co)                                 -- 2+    (bo |> sym axStar)                            -- 3+    (NoWay |> sym bc)                             -- 4+      :: Star++First, we flatten all the arguments (before simplifyArgsWorker), like so:++    (forall j. j -> Type, co1 :: (forall j. j -> Type) ~+                                 (forall (j :: Star). (j |> axStar) -> Star))  -- 1+    (Proxy |> co,         co2 :: (Proxy |> co) ~ (Proxy |> co))                -- 2+    (Bool |> sym axStar,  co3 :: (Bool |> sym axStar) ~ (bo |> sym axStar))    -- 3+    (False |> sym bc,     co4 :: (False |> sym bc) ~ (NoWay |> sym bc))        -- 4++Then we do the process described in Note [simplifyArgsWorker].++1. Lifting Type (the kind of the first arg) gives us a reflexive coercion, so we+   don't use it. But we do build a lifting context [k -> co1] (where co1 is a+   result of flattening an argument, written above).++2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> sym co1).+   This is not a dependent argument, so we don't extend the lifting context.++Now we need to deal with argument (3).+The way we normally proceed is to lift the kind of the binder, to see whether+it's dependent.+But here, the remainder of the kind of `a` that we're left with+after processing two arguments is just `k`.++The way forward is look up k in the lifting context, getting co1. If we're at+all well-typed, co1 will be a coercion between Π-types, with at least one binder.+So, let's+decompose co1 with decomposePiCos. This decomposition needs arguments to use+to instantiate any kind parameters. Look at the type of co1. If we just+decomposed it, we would end up with coercions whose types include j, which is+out of scope here. Accordingly, decomposePiCos takes a list of types whose+kinds are the *right-hand* types in the decomposed coercion. (See comments on+decomposePiCos.) Because the flattened types have unflattened kinds (because+flattening is homogeneous), passing the list of flattened types to decomposePiCos+just won't do: later arguments' kinds won't be as expected. So we need to get+the *unflattened* types to pass to decomposePiCos. We can do this easily enough+by taking the kind of the argument coercions, passed in originally.++(Alternative 1: We could re-engineer decomposePiCos to deal with this situation.+But that function is already gnarly, and taking the right-hand types is correct+at its other call sites, which are much more common than this one.)++(Alternative 2: We could avoid calling decomposePiCos entirely, integrating its+behavior into simplifyArgsWorker. This would work, I think, but then all of the+complication of decomposePiCos would end up layered on top of all the complication+here. Please, no.)++(Alternative 3: We could pass the unflattened arguments into simplifyArgsWorker+so that we don't have to recreate them. But that would complicate the interface+of this function to handle a very dark, dark corner case. Better to keep our+demons to ourselves here instead of exposing them to callers. This decision is+easily reversed if there is ever any performance trouble due to the call of+coercionKind.)++So we now call++  decomposePiCos co1+                 (Pair (forall j. j -> Type) (forall (j :: Star). (j |> axStar) -> Star))+                 [bo |> sym axStar, NoWay |> sym bc]++to get++  co5 :: Star ~ Type+  co6 :: (j |> axStar) ~ (j |> co5), substituted to+                              (bo |> sym axStar |> axStar) ~ (bo |> sym axStar |> co5)+                           == bo ~ bo+  res_co :: Type ~ Star++We then use these casts on (the flattened) (3) and (4) to get++  (Bool |> sym axStar |> co5 :: Type)   -- (C3)+  (False |> sym bc |> co6    :: bo)     -- (C4)++We can simplify to++  Bool                        -- (C3)+  (False |> sym bc :: bo)     -- (C4)++Of course, we still must do the processing in Note [simplifyArgsWorker] to finish+the job. We thus want to recur. Our new function kind is the left-hand type of+co1 (gotten, recall, by lifting the variable k that was the return kind of the+original function). Why the left-hand type (as opposed to the right-hand type)?+Because we have casted all the arguments according to decomposePiCos, which gets+us from the right-hand type to the left-hand one. We thus recur with that new+function kind, zapping our lifting context, because we have essentially applied+it.++This recursive call returns ([Bool, False], [...], Refl). The Bool and False+are the correct arguments we wish to return. But we must be careful about the+result coercion: our new, flattened application will have kind Type, but we+want to make sure that the result coercion casts this back to Star. (Why?+Because we started with an application of kind Star, and flattening is homogeneous.)++So, we have to twiddle the result coercion appropriately.++Let's check whether this is well-typed. We know++  a :: forall (k :: Type). k -> k++  a (forall j. j -> Type) :: (forall j. j -> Type) -> forall j. j -> Type++  a (forall j. j -> Type)+    Proxy+      :: forall j. j -> Type++  a (forall j. j -> Type)+    Proxy+    Bool+      :: Bool -> Type++  a (forall j. j -> Type)+    Proxy+    Bool+    False+      :: Type++  a (forall j. j -> Type)+    Proxy+    Bool+    False+     |> res_co+     :: Star++as desired.++Whew.++Historical note: I (Richard E) once thought that the final part of the kind+had to be a variable k (as in the example above). But it might not be: it could+be an application of a variable. Here is the example:++  let f :: forall (a :: Type) (b :: a -> Type). b (Any @a)+      k :: Type+      x :: k++  flatten (f @Type @((->) k) x)++After instantiating [a |-> Type, b |-> ((->) k)], we see that `b (Any @a)`+is `k -> Any @a`, and thus the third argument of `x :: k` is well-kinded.++-}+++-- This is shared between the flattener and the normaliser in GHC.Core.FamInstEnv.+-- See Note [simplifyArgsWorker]+{-# INLINE simplifyArgsWorker #-}+simplifyArgsWorker :: [TyCoBinder] -> Kind+                       -- the binders & result kind (not a Π-type) of the function applied to the args+                       -- list of binders can be shorter or longer than the list of args+                   -> TyCoVarSet   -- free vars of the args+                   -> [Role]   -- list of roles, r+                   -> [(Type, Coercion)] -- flattened type arguments, arg+                                         -- each comes with the coercion used to flatten it,+                                         -- with co :: flattened_type ~ original_type+                   -> ([Type], [Coercion], CoercionN)+-- Returns (xis, cos, res_co), where each co :: xi ~ arg,+-- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args+-- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in),+-- then (f orig_tys) is well kinded. Note that (f flattened_tys) might *not* be well-kinded.+-- Massaging the flattened_tys in order to make (f flattened_tys) well-kinded is what this+-- function is all about. That is, (f xis), where xis are the returned arguments, *is*+-- well kinded.+simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs+                   orig_roles orig_simplified_args+  = go [] [] orig_lc orig_ki_binders orig_inner_ki orig_roles orig_simplified_args+  where+    orig_lc = emptyLiftingContext $ mkInScopeSet $ orig_fvs++    go :: [Type]      -- Xis accumulator, in reverse order+       -> [Coercion]  -- Coercions accumulator, in reverse order+                      -- These are in 1-to-1 correspondence+       -> LiftingContext  -- mapping from tyvars to flattening coercions+       -> [TyCoBinder]    -- Unsubsted binders of function's kind+       -> Kind        -- Unsubsted result kind of function (not a Pi-type)+       -> [Role]      -- Roles at which to flatten these ...+       -> [(Type, Coercion)]  -- flattened arguments, with their flattening coercions+       -> ([Type], [Coercion], CoercionN)+    go acc_xis acc_cos lc binders inner_ki _ []+      = (reverse acc_xis, reverse acc_cos, kind_co)+      where+        final_kind = mkPiTys binders inner_ki+        kind_co = liftCoSubst Nominal lc final_kind++    go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args)+      = -- By Note [Flattening] in TcFlatten invariant (F2),+         -- tcTypeKind(xi) = tcTypeKind(ty). But, it's possible that xi will be+         -- used as an argument to a function whose kind is different, if+         -- earlier arguments have been flattened to new types. We thus+         -- need a coercion (kind_co :: old_kind ~ new_kind).+         --+         -- The bangs here have been observed to improve performance+         -- significantly in optimized builds.+         let kind_co = mkSymCo $+               liftCoSubst Nominal lc (tyCoBinderType binder)+             !casted_xi = xi `mkCastTy` kind_co+             casted_co =  mkCoherenceLeftCo role xi kind_co co++         -- now, extend the lifting context with the new binding+             !new_lc | Just tv <- tyCoBinderVar_maybe binder+                     = extendLiftingContextAndInScope lc tv casted_co+                     | otherwise+                     = lc+         in+         go (casted_xi : acc_xis)+            (casted_co : acc_cos)+            new_lc+            binders+            inner_ki+            roles+            args+++      -- See Note [Last case in simplifyArgsWorker]+    go acc_xis acc_cos lc [] inner_ki roles args+      = let co1 = liftCoSubst Nominal lc inner_ki+            co1_kind              = coercionKind co1+            unflattened_tys       = map (coercionRKind . snd) args+            (arg_cos, res_co)     = decomposePiCos co1 co1_kind unflattened_tys+            casted_args           = ASSERT2( equalLength args arg_cos+                                           , ppr args $$ ppr arg_cos )+                                    [ (casted_xi, casted_co)+                                    | ((xi, co), arg_co, role) <- zip3 args arg_cos roles+                                    , let casted_xi = xi `mkCastTy` arg_co+                                          casted_co = mkCoherenceLeftCo role xi arg_co co ]+               -- In general decomposePiCos can return fewer cos than tys,+               -- but not here; because we're well typed, there will be enough+               -- binders. Note that decomposePiCos does substitutions, so even+               -- if the original substitution results in something ending with+               -- ... -> k, that k will be substituted to perhaps reveal more+               -- binders.+            zapped_lc             = zapLiftingContext lc+            Pair flattened_kind _ = co1_kind+            (bndrs, new_inner)    = splitPiTys flattened_kind++            (xis_out, cos_out, res_co_out)+              = go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_args+        in+        (xis_out, cos_out, res_co_out `mkTransCo` res_co)++    go _ _ _ _ _ _ _ = panic+        "simplifyArgsWorker wandered into deeper water than usual"+           -- This debug information is commented out because leaving it in+           -- causes a ~2% increase in allocations in T9872d.+           -- That's independent of the analogous case in flatten_args_fast+           -- in TcFlatten:+           -- each of these causes a 2% increase on its own, so commenting them+           -- both out gives a 4% decrease in T9872d.+           {-++             (vcat [ppr orig_binders,+                    ppr orig_inner_ki,+                    ppr (take 10 orig_roles), -- often infinite!+                    ppr orig_tys])+           -}++{-+%************************************************************************+%*                                                                      *+       Coercion holes+%*                                                                      *+%************************************************************************+-}++bad_co_hole_ty :: Type -> Monoid.Any+bad_co_hole_co :: Coercion -> Monoid.Any+(bad_co_hole_ty, _, bad_co_hole_co, _)+  = foldTyCo folder ()+  where+    folder = TyCoFolder { tcf_view  = const Nothing+                        , tcf_tyvar = const2 (Monoid.Any False)+                        , tcf_covar = const2 (Monoid.Any False)+                        , tcf_hole  = const hole+                        , tcf_tycobinder = const2+                        }++    const2 :: a -> b -> c -> a+    const2 x _ _ = x++    hole :: CoercionHole -> Monoid.Any+    hole (CoercionHole { ch_blocker = YesBlockSubst }) = Monoid.Any True+    hole _                                             = Monoid.Any False++-- | Is there a blocking coercion hole in this type? See+-- TcCanonical Note [Equalities with incompatible kinds]+badCoercionHole :: Type -> Bool+badCoercionHole = Monoid.getAny . bad_co_hole_ty++-- | Is there a blocking coercion hole in this coercion? See+-- TcCanonical Note [Equalities with incompatible kinds]+badCoercionHoleCo :: Coercion -> Bool+badCoercionHoleCo = Monoid.getAny . bad_co_hole_co
+ compiler/GHC/Core/Coercion.hs-boot view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleContexts #-}++module GHC.Core.Coercion where++import GhcPrelude++import {-# SOURCE #-} GHC.Core.TyCo.Rep+import {-# SOURCE #-} GHC.Core.TyCon++import GHC.Types.Basic ( LeftOrRight )+import GHC.Core.Coercion.Axiom+import GHC.Types.Var+import Pair+import Util++mkReflCo :: Role -> Type -> Coercion+mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion+mkAppCo :: Coercion -> Coercion -> Coercion+mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion+mkFunCo :: Role -> Coercion -> Coercion -> Coercion+mkCoVarCo :: CoVar -> Coercion+mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion+mkPhantomCo :: Coercion -> Type -> Type -> Coercion+mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion+mkSymCo :: Coercion -> Coercion+mkTransCo :: Coercion -> Coercion -> Coercion+mkNthCo :: HasDebugCallStack => Role -> Int -> Coercion -> Coercion+mkLRCo :: LeftOrRight -> Coercion -> Coercion+mkInstCo :: Coercion -> Coercion -> Coercion+mkGReflCo :: Role -> Type -> MCoercionN -> Coercion+mkNomReflCo :: Type -> Coercion+mkKindCo :: Coercion -> Coercion+mkSubCo :: Coercion -> Coercion+mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion+mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion++isGReflCo :: Coercion -> Bool+isReflCo :: Coercion -> Bool+isReflexiveCo :: Coercion -> Bool+decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion)+coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind, Kind, Type, Type, Role)+coVarRole :: CoVar -> Role++mkCoercionType :: Role -> Type -> Type -> Type++data LiftingContext+liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion+seqCo :: Coercion -> ()++coercionKind :: Coercion -> Pair Type+coercionLKind :: Coercion -> Type+coercionRKind :: Coercion -> Type+coercionType :: Coercion -> Type
+ compiler/GHC/Core/Coercion/Axiom.hs view
@@ -0,0 +1,577 @@+-- (c) The University of Glasgow 2012++{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures,+             ScopedTypeVariables, StandaloneDeriving, RoleAnnotations #-}++-- | Module for coercion axioms, used to represent type family instances+-- and newtypes++module GHC.Core.Coercion.Axiom (+       BranchFlag, Branched, Unbranched, BranchIndex, Branches(..),+       manyBranches, unbranched,+       fromBranches, numBranches,+       mapAccumBranches,++       CoAxiom(..), CoAxBranch(..),++       toBranchedAxiom, toUnbranchedAxiom,+       coAxiomName, coAxiomArity, coAxiomBranches,+       coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats,+       coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole,+       coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars,+       coAxBranchRoles,+       coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps,+       placeHolderIncomps,++       Role(..), fsFromRole,++       CoAxiomRule(..), TypeEqn,+       BuiltInSynFamily(..)+       ) where++import GhcPrelude++import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )+import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType )+import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon )+import Outputable+import FastString+import GHC.Types.Name+import GHC.Types.Unique+import GHC.Types.Var+import Util+import Binary+import Pair+import GHC.Types.Basic+import Data.Typeable ( Typeable )+import GHC.Types.SrcLoc+import qualified Data.Data as Data+import Data.Array+import Data.List ( mapAccumL )++#include "HsVersions.h"++{-+Note [Coercion axiom branches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In order to allow closed type families, an axiom needs to contain an+ordered list of alternatives, called branches. The kind of the coercion built+from an axiom is determined by which index is used when building the coercion+from the axiom.++For example, consider the axiom derived from the following declaration:++type family F a where+  F [Int] = Bool+  F [a]   = Double+  F (a b) = Char++This will give rise to this axiom:++axF :: {                                         F [Int] ~ Bool+       ; forall (a :: *).                        F [a]   ~ Double+       ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char+       }++The axiom is used with the AxiomInstCo constructor of Coercion. If we wish+to have a coercion showing that F (Maybe Int) ~ Char, it will look like++axF[2] <*> <Maybe> <Int> :: F (Maybe Int) ~ Char+-- or, written using concrete-ish syntax --+AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int]++Note that the index is 0-based.++For type-checking, it is also necessary to check that no previous pattern+can unify with the supplied arguments. After all, it is possible that some+of the type arguments are lambda-bound type variables whose instantiation may+cause an earlier match among the branches. We wish to prohibit this behavior,+so the type checker rules out the choice of a branch where a previous branch+can unify. See also [Apartness] in GHC.Core.FamInstEnv.++For example, the following is malformed, where 'a' is a lambda-bound type+variable:++axF[2] <*> <a> <Bool> :: F (a Bool) ~ Char++Why? Because a might be instantiated with [], meaning that branch 1 should+apply, not branch 2. This is a vital consistency check; without it, we could+derive Int ~ Bool, and that is a Bad Thing.++Note [Branched axioms]+~~~~~~~~~~~~~~~~~~~~~~+Although a CoAxiom has the capacity to store many branches, in certain cases,+we want only one. These cases are in data/newtype family instances, newtype+coercions, and type family instances.+Furthermore, these unbranched axioms are used in a+variety of places throughout GHC, and it would difficult to generalize all of+that code to deal with branched axioms, especially when the code can be sure+of the fact that an axiom is indeed a singleton. At the same time, it seems+dangerous to assume singlehood in various places through GHC.++The solution to this is to label a CoAxiom with a phantom type variable+declaring whether it is known to be a singleton or not. The branches+are stored using a special datatype, declared below, that ensures that the+type variable is accurate.++************************************************************************+*                                                                      *+                    Branches+*                                                                      *+************************************************************************+-}++type BranchIndex = Int  -- The index of the branch in the list of branches+                        -- Counting from zero++-- promoted data type+data BranchFlag = Branched | Unbranched+type Branched = 'Branched+type Unbranched = 'Unbranched+-- By using type synonyms for the promoted constructors, we avoid needing+-- DataKinds and the promotion quote in client modules. This also means that+-- we don't need to export the term-level constructors, which should never be used.++newtype Branches (br :: BranchFlag)+  = MkBranches { unMkBranches :: Array BranchIndex CoAxBranch }+type role Branches nominal++manyBranches :: [CoAxBranch] -> Branches Branched+manyBranches brs = ASSERT( snd bnds >= fst bnds )+                   MkBranches (listArray bnds brs)+  where+    bnds = (0, length brs - 1)++unbranched :: CoAxBranch -> Branches Unbranched+unbranched br = MkBranches (listArray (0, 0) [br])++toBranched :: Branches br -> Branches Branched+toBranched = MkBranches . unMkBranches++toUnbranched :: Branches br -> Branches Unbranched+toUnbranched (MkBranches arr) = ASSERT( bounds arr == (0,0) )+                                MkBranches arr++fromBranches :: Branches br -> [CoAxBranch]+fromBranches = elems . unMkBranches++branchesNth :: Branches br -> BranchIndex -> CoAxBranch+branchesNth (MkBranches arr) n = arr ! n++numBranches :: Branches br -> Int+numBranches (MkBranches arr) = snd (bounds arr) + 1++-- | The @[CoAxBranch]@ passed into the mapping function is a list of+-- all previous branches, reversed+mapAccumBranches :: ([CoAxBranch] -> CoAxBranch -> CoAxBranch)+                  -> Branches br -> Branches br+mapAccumBranches f (MkBranches arr)+  = MkBranches (listArray (bounds arr) (snd $ mapAccumL go [] (elems arr)))+  where+    go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch)+    go prev_branches cur_branch = ( cur_branch : prev_branches+                                  , f prev_branches cur_branch )+++{-+************************************************************************+*                                                                      *+                    Coercion axioms+*                                                                      *+************************************************************************++Note [Storing compatibility]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During axiom application, we need to be aware of which branches are compatible+with which others. The full explanation is in Note [Compatibility] in+FamInstEnv. (The code is placed there to avoid a dependency from CoAxiom on+the unification algorithm.) Although we could theoretically compute+compatibility on the fly, this is silly, so we store it in a CoAxiom.++Specifically, each branch refers to all other branches with which it is+incompatible. This list might well be empty, and it will always be for the+first branch of any axiom.++CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk+stored in cab_incomps. The incompatibilities are properly a property of the+axiom as a whole, and they are computed only when the final axiom is built.++During serialization, the list is converted into a list of the indices+of the branches.++Note [CoAxioms are homogeneous]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All axioms must be *homogeneous*, meaning that the kind of the LHS must+match the kind of the RHS. In practice, this means:++  Given a CoAxiom { co_ax_tc = ax_tc },+  for every branch CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }:+    typeKind (mkTyConApp ax_tc lhs) `eqType` typeKind rhs++This is checked in FamInstEnv.mkCoAxBranch.+-}++-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom.++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data CoAxiom br+  = CoAxiom                   -- Type equality axiom.+    { co_ax_unique   :: Unique        -- Unique identifier+    , co_ax_name     :: Name          -- Name for pretty-printing+    , co_ax_role     :: Role          -- Role of the axiom's equality+    , co_ax_tc       :: TyCon         -- The head of the LHS patterns+                                      -- e.g.  the newtype or family tycon+    , co_ax_branches :: Branches br   -- The branches that form this axiom+    , co_ax_implicit :: Bool          -- True <=> the axiom is "implicit"+                                      -- See Note [Implicit axioms]+         -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1.+    }++data CoAxBranch+  = CoAxBranch+    { cab_loc      :: SrcSpan       -- Location of the defining equation+                                    -- See Note [CoAxiom locations]+    , cab_tvs      :: [TyVar]       -- Bound type variables; not necessarily fresh+    , cab_eta_tvs  :: [TyVar]       -- Eta-reduced tyvars+                                    -- See Note [CoAxBranch type variables]+                                    -- cab_tvs and cab_lhs may be eta-reduded; see+                                    -- Note [Eta reduction for data families]+    , cab_cvs      :: [CoVar]       -- Bound coercion variables+                                    -- Always empty, for now.+                                    -- See Note [Constraints in patterns]+                                    -- in TcTyClsDecls+    , cab_roles    :: [Role]        -- See Note [CoAxBranch roles]+    , cab_lhs      :: [Type]        -- Type patterns to match against+    , cab_rhs      :: Type          -- Right-hand side of the equality+                                    -- See Note [CoAxioms are homogeneous]+    , cab_incomps  :: [CoAxBranch]  -- The previous incompatible branches+                                    -- See Note [Storing compatibility]+    }+  deriving Data.Data++toBranchedAxiom :: CoAxiom br -> CoAxiom Branched+toBranchedAxiom (CoAxiom unique name role tc branches implicit)+  = CoAxiom unique name role tc (toBranched branches) implicit++toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched+toUnbranchedAxiom (CoAxiom unique name role tc branches implicit)+  = CoAxiom unique name role tc (toUnbranched branches) implicit++coAxiomNumPats :: CoAxiom br -> Int+coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0)++coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch+coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index+  = branchesNth bs index++coAxiomArity :: CoAxiom br -> BranchIndex -> Arity+coAxiomArity ax index+  = length tvs + length cvs+  where+    CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index++coAxiomName :: CoAxiom br -> Name+coAxiomName = co_ax_name++coAxiomRole :: CoAxiom br -> Role+coAxiomRole = co_ax_role++coAxiomBranches :: CoAxiom br -> Branches br+coAxiomBranches = co_ax_branches++coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch+coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr })+  | snd (bounds arr) == 0+  = Just $ arr ! 0+  | otherwise+  = Nothing++coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch+coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr })+  = arr ! 0++coAxiomTyCon :: CoAxiom br -> TyCon+coAxiomTyCon = co_ax_tc++coAxBranchTyVars :: CoAxBranch -> [TyVar]+coAxBranchTyVars = cab_tvs++coAxBranchCoVars :: CoAxBranch -> [CoVar]+coAxBranchCoVars = cab_cvs++coAxBranchLHS :: CoAxBranch -> [Type]+coAxBranchLHS = cab_lhs++coAxBranchRHS :: CoAxBranch -> Type+coAxBranchRHS = cab_rhs++coAxBranchRoles :: CoAxBranch -> [Role]+coAxBranchRoles = cab_roles++coAxBranchSpan :: CoAxBranch -> SrcSpan+coAxBranchSpan = cab_loc++isImplicitCoAxiom :: CoAxiom br -> Bool+isImplicitCoAxiom = co_ax_implicit++coAxBranchIncomps :: CoAxBranch -> [CoAxBranch]+coAxBranchIncomps = cab_incomps++-- See Note [Compatibility checking] in GHC.Core.FamInstEnv+placeHolderIncomps :: [CoAxBranch]+placeHolderIncomps = panic "placeHolderIncomps"++{-+Note [CoAxBranch type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the case of a CoAxBranch of an associated type-family instance,+we use the *same* type variables (where possible) as the+enclosing class or instance.  Consider++  instance C Int [z] where+     type F Int [z] = ...   -- Second param must be [z]++In the CoAxBranch in the instance decl (F Int [z]) we use the+same 'z', so that it's easy to check that that type is the same+as that in the instance header.++So, unlike FamInsts, there is no expectation that the cab_tvs+are fresh wrt each other, or any other CoAxBranch.++Note [CoAxBranch roles]+~~~~~~~~~~~~~~~~~~~~~~~+Consider this code:++  newtype Age = MkAge Int+  newtype Wrap a = MkWrap a++  convert :: Wrap Age -> Int+  convert (MkWrap (MkAge i)) = i++We want this to compile to:++  NTCo:Wrap :: forall a. Wrap a ~R a+  NTCo:Age  :: Age ~R Int+  convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0])++But, note that NTCo:Age is at role R. Thus, we need to be able to pass+coercions at role R into axioms. However, we don't *always* want to be able to+do this, as it would be disastrous with type families. The solution is to+annotate the arguments to the axiom with roles, much like we annotate tycon+tyvars. Where do these roles get set? Newtype axioms inherit their roles from+the newtype tycon; family axioms are all at role N.++Note [CoAxiom locations]+~~~~~~~~~~~~~~~~~~~~~~~~+The source location of a CoAxiom is stored in two places in the+datatype tree.+  * The first is in the location info buried in the Name of the+    CoAxiom. This span includes all of the branches of a branched+    CoAxiom.+  * The second is in the cab_loc fields of the CoAxBranches.++In the case of a single branch, we can extract the source location of+the branch from the name of the CoAxiom. In other cases, we need an+explicit SrcSpan to correctly store the location of the equation+giving rise to the FamInstBranch.++Note [Implicit axioms]+~~~~~~~~~~~~~~~~~~~~~~+See also Note [Implicit TyThings] in GHC.Driver.Types+* A CoAxiom arising from data/type family instances is not "implicit".+  That is, it has its own IfaceAxiom declaration in an interface file++* The CoAxiom arising from a newtype declaration *is* "implicit".+  That is, it does not have its own IfaceAxiom declaration in an+  interface file; instead the CoAxiom is generated by type-checking+  the newtype declaration++Note [Eta reduction for data families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   data family T a b :: *+   newtype instance T Int a = MkT (IO a) deriving( Monad )+We'd like this to work.++From the 'newtype instance' you might think we'd get:+   newtype TInt a = MkT (IO a)+   axiom ax1 a :: T Int a ~ TInt a   -- The newtype-instance part+   axiom ax2 a :: TInt a ~ IO a      -- The newtype part++But now what can we do?  We have this problem+   Given:   d  :: Monad IO+   Wanted:  d' :: Monad (T Int) = d |> ????+What coercion can we use for the ???++Solution: eta-reduce both axioms, thus:+   axiom ax1 :: T Int ~ TInt+   axiom ax2 :: TInt ~ IO+Now+   d' = d |> Monad (sym (ax2 ; ax1))++----- Bottom line ------++For a CoAxBranch for a data family instance with representation+TyCon rep_tc:++  - cab_tvs (of its CoAxiom) may be shorter+    than tyConTyVars of rep_tc.++  - cab_lhs may be shorter than tyConArity of the family tycon+       i.e. LHS is unsaturated++  - cab_rhs will be (rep_tc cab_tvs)+       i.e. RHS is un-saturated++  - This eta reduction happens for data instances as well+    as newtype instances. Here we want to eta-reduce the data family axiom.++  - This eta-reduction is done in TcInstDcls.tcDataFamInstDecl.++But for a /type/ family+  - cab_lhs has the exact arity of the family tycon++There are certain situations (e.g., pretty-printing) where it is necessary to+deal with eta-expanded data family instances. For these situations, the+cab_eta_tvs field records the stuff that has been eta-reduced away.+So if we have+    axiom forall a b. F [a->b] = D b a+and cab_eta_tvs is [p,q], then the original user-written definition+looked like+    axiom forall a b p q. F [a->b] p q = D b a p q+(See #9692, #14179, and #15845 for examples of what can go wrong if+we don't eta-expand when showing things to the user.)++(See also Note [Newtype eta] in GHC.Core.TyCon.  This is notionally separate+and deals with the axiom connecting a newtype with its representation+type; but it too is eta-reduced.)+-}++instance Eq (CoAxiom br) where+    a == b = getUnique a == getUnique b+    a /= b = getUnique a /= getUnique b++instance Uniquable (CoAxiom br) where+    getUnique = co_ax_unique++instance Outputable (CoAxiom br) where+    ppr = ppr . getName++instance NamedThing (CoAxiom br) where+    getName = co_ax_name++instance Typeable br => Data.Data (CoAxiom br) where+    -- don't traverse?+    toConstr _   = abstractConstr "CoAxiom"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "CoAxiom"++instance Outputable CoAxBranch where+  ppr (CoAxBranch { cab_loc = loc+                  , cab_lhs = lhs+                  , cab_rhs = rhs }) =+    text "CoAxBranch" <+> parens (ppr loc) <> colon+      <+> brackets (fsep (punctuate comma (map pprType lhs)))+      <+> text "=>" <+> pprType rhs++{-+************************************************************************+*                                                                      *+                    Roles+*                                                                      *+************************************************************************++Roles are defined here to avoid circular dependencies.+-}++-- See Note [Roles] in GHC.Core.Coercion+-- defined here to avoid cyclic dependency with GHC.Core.Coercion+--+-- Order of constructors matters: the Ord instance coincides with the *super*typing+-- relation on roles.+data Role = Nominal | Representational | Phantom+  deriving (Eq, Ord, Data.Data)++-- These names are slurped into the parser code. Changing these strings+-- will change the **surface syntax** that GHC accepts! If you want to+-- change only the pretty-printing, do some replumbing. See+-- mkRoleAnnotDecl in RdrHsSyn+fsFromRole :: Role -> FastString+fsFromRole Nominal          = fsLit "nominal"+fsFromRole Representational = fsLit "representational"+fsFromRole Phantom          = fsLit "phantom"++instance Outputable Role where+  ppr = ftext . fsFromRole++instance Binary Role where+  put_ bh Nominal          = putByte bh 1+  put_ bh Representational = putByte bh 2+  put_ bh Phantom          = putByte bh 3++  get bh = do tag <- getByte bh+              case tag of 1 -> return Nominal+                          2 -> return Representational+                          3 -> return Phantom+                          _ -> panic ("get Role " ++ show tag)++{-+************************************************************************+*                                                                      *+                    CoAxiomRule+              Rules for building Evidence+*                                                                      *+************************************************************************++Conditional axioms.  The general idea is that a `CoAxiomRule` looks like this:++    forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2++My intention is to reuse these for both (~) and (~#).+The short-term plan is to use this datatype to represent the type-nat axioms.+In the longer run, it may be good to unify this and `CoAxiom`,+as `CoAxiom` is the special case when there are no assumptions.+-}++-- | A more explicit representation for `t1 ~ t2`.+type TypeEqn = Pair Type++-- | For now, we work only with nominal equality.+data CoAxiomRule = CoAxiomRule+  { coaxrName      :: FastString+  , coaxrAsmpRoles :: [Role]    -- roles of parameter equations+  , coaxrRole      :: Role      -- role of resulting equation+  , coaxrProves    :: [TypeEqn] -> Maybe TypeEqn+        -- ^ coaxrProves returns @Nothing@ when it doesn't like+        -- the supplied arguments.  When this happens in a coercion+        -- that means that the coercion is ill-formed, and Core Lint+        -- checks for that.+  }++instance Data.Data CoAxiomRule where+  -- don't traverse?+  toConstr _   = abstractConstr "CoAxiomRule"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "CoAxiomRule"++instance Uniquable CoAxiomRule where+  getUnique = getUnique . coaxrName++instance Eq CoAxiomRule where+  x == y = coaxrName x == coaxrName y++instance Ord CoAxiomRule where+  compare x y = compare (coaxrName x) (coaxrName y)++instance Outputable CoAxiomRule where+  ppr = ppr . coaxrName+++-- Type checking of built-in families+data BuiltInSynFamily = BuiltInSynFamily+  { sfMatchFam      :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+  , sfInteractTop   :: [Type] -> Type -> [TypeEqn]+  , sfInteractInert :: [Type] -> Type ->+                       [Type] -> Type -> [TypeEqn]+  }
+ compiler/GHC/Core/Coercion/Opt.hs view
@@ -0,0 +1,1206 @@+-- (c) The University of Glasgow 2006++{-# LANGUAGE CPP #-}++module GHC.Core.Coercion.Opt ( optCoercion, checkAxInstCo ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Driver.Session+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Subst+import GHC.Core.Coercion+import GHC.Core.Type as Type hiding( substTyVarBndr, substTy )+import TcType       ( exactTyCoVarsOfType )+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import Outputable+import GHC.Core.FamInstEnv ( flattenTys )+import Pair+import ListSetOps ( getNth )+import Util+import GHC.Core.Unify+import GHC.Core.InstEnv+import Control.Monad   ( zipWithM )++{-+%************************************************************************+%*                                                                      *+                 Optimising coercions+%*                                                                      *+%************************************************************************++Note [Optimising coercion optimisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Looking up a coercion's role or kind is linear in the size of the+coercion. Thus, doing this repeatedly during the recursive descent+of coercion optimisation is disastrous. We must be careful to avoid+doing this if at all possible.++Because it is generally easy to know a coercion's components' roles+from the role of the outer coercion, we pass down the known role of+the input in the algorithm below. We also keep functions opt_co2+and opt_co3 separate from opt_co4, so that the former two do Phantom+checks that opt_co4 can avoid. This is a big win because Phantom coercions+rarely appear within non-phantom coercions -- only in some TyConAppCos+and some AxiomInstCos. We handle these cases specially by calling+opt_co2.++Note [Optimising InstCo]+~~~~~~~~~~~~~~~~~~~~~~~~+(1) tv is a type variable+When we have (InstCo (ForAllCo tv h g) g2), we want to optimise.++Let's look at the typing rules.++h : k1 ~ k2+tv:k1 |- g : t1 ~ t2+-----------------------------+ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h])++g1 : (all tv:k1.t1') ~ (all tv:k2.t2')+g2 : s1 ~ s2+--------------------+InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2]++We thus want some coercion proving this:++  (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h])++If we substitute the *type* tv for the *coercion*+(g2 ; t2 ~ t2 |> sym h) in g, we'll get this result exactly.+This is bizarre,+though, because we're substituting a type variable with a coercion. However,+this operation already exists: it's called *lifting*, and defined in GHC.Core.Coercion.+We just need to enhance the lifting operation to be able to deal with+an ambient substitution, which is why a LiftingContext stores a TCvSubst.++(2) cv is a coercion variable+Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise.++h : (t1 ~r t2) ~N (t3 ~r t4)+cv : t1 ~r t2 |- g : t1' ~r2 t2'+n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3+n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4+------------------------------------------------+ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2+                  (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2])++g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2')+g2 : h1 ~N h2+h1 : t1 ~r t2+h2 : t3 ~r t4+------------------------------------------------+InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2]++We thus want some coercion proving this:++  t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2]++So we substitute the coercion variable c for the coercion+(h1 ~N (n1; h2; sym n2)) in g.+-}++optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo+-- ^ optCoercion applies a substitution to a coercion,+--   *and* optimises it to reduce its size+optCoercion dflags env co+  | hasNoOptCoercion dflags = substCo env co+  | otherwise               = optCoercion' env co++optCoercion' :: TCvSubst -> Coercion -> NormalCo+optCoercion' env co+  | debugIsOn+  = let out_co = opt_co1 lc False co+        (Pair in_ty1  in_ty2,  in_role)  = coercionKindRole co+        (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co+    in+    ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 &&+             substTyUnchecked env in_ty2 `eqType` out_ty2 &&+             in_role == out_role+           , text "optCoercion changed types!"+             $$ hang (text "in_co:") 2 (ppr co)+             $$ hang (text "in_ty1:") 2 (ppr in_ty1)+             $$ hang (text "in_ty2:") 2 (ppr in_ty2)+             $$ hang (text "out_co:") 2 (ppr out_co)+             $$ hang (text "out_ty1:") 2 (ppr out_ty1)+             $$ hang (text "out_ty2:") 2 (ppr out_ty2)+             $$ hang (text "subst:") 2 (ppr env) )+    out_co++  | otherwise         = opt_co1 lc False co+  where+    lc = mkSubstLiftingContext env++type NormalCo    = Coercion+  -- Invariants:+  --  * The substitution has been fully applied+  --  * For trans coercions (co1 `trans` co2)+  --       co1 is not a trans, and neither co1 nor co2 is identity++type NormalNonIdCo = NormalCo  -- Extra invariant: not the identity++-- | Do we apply a @sym@ to the result?+type SymFlag = Bool++-- | Do we force the result to be representational?+type ReprFlag = Bool++-- | Optimize a coercion, making no assumptions. All coercions in+-- the lifting context are already optimized (and sym'd if nec'y)+opt_co1 :: LiftingContext+        -> SymFlag+        -> Coercion -> NormalCo+opt_co1 env sym co = opt_co2 env sym (coercionRole co) co++-- See Note [Optimising coercion optimisation]+-- | Optimize a coercion, knowing the coercion's role. No other assumptions.+opt_co2 :: LiftingContext+        -> SymFlag+        -> Role   -- ^ The role of the input coercion+        -> Coercion -> NormalCo+opt_co2 env sym Phantom co = opt_phantom env sym co+opt_co2 env sym r       co = opt_co3 env sym Nothing r co++-- See Note [Optimising coercion optimisation]+-- | Optimize a coercion, knowing the coercion's non-Phantom role.+opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo+opt_co3 env sym (Just Phantom)          _ co = opt_phantom env sym co+opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True  r co+  -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore+opt_co3 env sym _                       r co = opt_co4_wrap env sym False r co++-- See Note [Optimising coercion optimisation]+-- | Optimize a non-phantom coercion.+opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo++opt_co4_wrap = opt_co4+{-+opt_co4_wrap env sym rep r co+  = pprTrace "opt_co4_wrap {"+    ( vcat [ text "Sym:" <+> ppr sym+           , text "Rep:" <+> ppr rep+           , text "Role:" <+> ppr r+           , text "Co:" <+> ppr co ]) $+    ASSERT( r == coercionRole co )+    let result = opt_co4 env sym rep r co in+    pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $+    result+-}++opt_co4 env _   rep r (Refl ty)+  = ASSERT2( r == Nominal, text "Expected role:" <+> ppr r    $$+                           text "Found role:" <+> ppr Nominal $$+                           text "Type:" <+> ppr ty )+    liftCoSubst (chooseRole rep r) env ty++opt_co4 env _   rep r (GRefl _r ty MRefl)+  = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$+                      text "Found role:" <+> ppr _r   $$+                      text "Type:" <+> ppr ty )+    liftCoSubst (chooseRole rep r) env ty++opt_co4 env sym  rep r (GRefl _r ty (MCo co))+  = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$+                      text "Found role:" <+> ppr _r   $$+                      text "Type:" <+> ppr ty )+    if isGReflCo co || isGReflCo co'+    then liftCoSubst r' env ty+    else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty)+  where+    r'  = chooseRole rep r+    ty' = substTy (lcSubstLeft env) ty+    co' = opt_co4 env False False Nominal co++opt_co4 env sym rep r (SymCo co)  = opt_co4_wrap env (not sym) rep r co+  -- surprisingly, we don't have to do anything to the env here. This is+  -- because any "lifting" substitutions in the env are tied to ForAllCos,+  -- which treat their left and right sides differently. We don't want to+  -- exchange them.++opt_co4 env sym rep r g@(TyConAppCo _r tc cos)+  = ASSERT( r == _r )+    case (rep, r) of+      (True, Nominal) ->+        mkTyConAppCo Representational tc+                     (zipWith3 (opt_co3 env sym)+                               (map Just (tyConRolesRepresentational tc))+                               (repeat Nominal)+                               cos)+      (False, Nominal) ->+        mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos)+      (_, Representational) ->+                      -- must use opt_co2 here, because some roles may be P+                      -- See Note [Optimising coercion optimisation]+        mkTyConAppCo r tc (zipWith (opt_co2 env sym)+                                   (tyConRolesRepresentational tc)  -- the current roles+                                   cos)+      (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g)++opt_co4 env sym rep r (AppCo co1 co2)+  = mkAppCo (opt_co4_wrap env sym rep r co1)+            (opt_co4_wrap env sym False Nominal co2)++opt_co4 env sym rep r (ForAllCo tv k_co co)+  = case optForAllCoBndr env sym tv k_co of+      (env', tv', k_co') -> mkForAllCo tv' k_co' $+                            opt_co4_wrap env' sym rep r co+     -- Use the "mk" functions to check for nested Refls++opt_co4 env sym rep r (FunCo _r co1 co2)+  = ASSERT( r == _r )+    if rep+    then mkFunCo Representational co1' co2'+    else mkFunCo r co1' co2'+  where+    co1' = opt_co4_wrap env sym rep r co1+    co2' = opt_co4_wrap env sym rep r co2++opt_co4 env sym rep r (CoVarCo cv)+  | Just co <- lookupCoVar (lcTCvSubst env) cv+  = opt_co4_wrap (zapLiftingContext env) sym rep r co++  | ty1 `eqType` ty2   -- See Note [Optimise CoVarCo to Refl]+  = mkReflCo (chooseRole rep r) ty1++  | otherwise+  = ASSERT( isCoVar cv1 )+    wrapRole rep r $ wrapSym sym $+    CoVarCo cv1++  where+    Pair ty1 ty2 = coVarTypes cv1++    cv1 = case lookupInScope (lcInScopeSet env) cv of+             Just cv1 -> cv1+             Nothing  -> WARN( True, text "opt_co: not in scope:"+                                     <+> ppr cv $$ ppr env)+                         cv+          -- cv1 might have a substituted kind!++opt_co4 _ _ _ _ (HoleCo h)+  = pprPanic "opt_univ fell into a hole" (ppr h)++opt_co4 env sym rep r (AxiomInstCo con ind cos)+    -- Do *not* push sym inside top-level axioms+    -- e.g. if g is a top-level axiom+    --   g a : f a ~ a+    -- then (sym (g ty)) /= g (sym ty) !!+  = ASSERT( r == coAxiomRole con )+    wrapRole rep (coAxiomRole con) $+    wrapSym sym $+                       -- some sub-cos might be P: use opt_co2+                       -- See Note [Optimising coercion optimisation]+    AxiomInstCo con ind (zipWith (opt_co2 env False)+                                 (coAxBranchRoles (coAxiomNthBranch con ind))+                                 cos)+      -- Note that the_co does *not* have sym pushed into it++opt_co4 env sym rep r (UnivCo prov _r t1 t2)+  = ASSERT( r == _r )+    opt_univ env sym prov (chooseRole rep r) t1 t2++opt_co4 env sym rep r (TransCo co1 co2)+                      -- sym (g `o` h) = sym h `o` sym g+  | sym       = opt_trans in_scope co2' co1'+  | otherwise = opt_trans in_scope co1' co2'+  where+    co1' = opt_co4_wrap env sym rep r co1+    co2' = opt_co4_wrap env sym rep r co2+    in_scope = lcInScopeSet env++opt_co4 env _sym rep r (NthCo _r n co)+  | Just (ty, _) <- isReflCo_maybe co+  , Just (_tc, args) <- ASSERT( r == _r )+                        splitTyConApp_maybe ty+  = liftCoSubst (chooseRole rep r) env (args `getNth` n)+  | Just (ty, _) <- isReflCo_maybe co+  , n == 0+  , Just (tv, _) <- splitForAllTy_maybe ty+      -- works for both tyvar and covar+  = liftCoSubst (chooseRole rep r) env (varType tv)++opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos))+  = ASSERT( r == r1 )+    opt_co4_wrap env sym rep r (cos `getNth` n)++opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _))+      -- works for both tyvar and covar+  = ASSERT( r == _r )+    ASSERT( n == 0 )+    opt_co4_wrap env sym rep Nominal eta++opt_co4 env sym rep r (NthCo _r n co)+  | TyConAppCo _ _ cos <- co'+  , let nth_co = cos `getNth` n+  = if rep && (r == Nominal)+      -- keep propagating the SubCo+    then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co+    else nth_co++  | ForAllCo _ eta _ <- co'+  = if rep+    then opt_co4_wrap (zapLiftingContext env) False True Nominal eta+    else eta++  | otherwise+  = wrapRole rep r $ NthCo r n co'+  where+    co' = opt_co1 env sym co++opt_co4 env sym rep r (LRCo lr co)+  | Just pr_co <- splitAppCo_maybe co+  = ASSERT( r == Nominal )+    opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co)+  | Just pr_co <- splitAppCo_maybe co'+  = ASSERT( r == Nominal )+    if rep+    then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co)+    else pick_lr lr pr_co+  | otherwise+  = wrapRole rep Nominal $ LRCo lr co'+  where+    co' = opt_co4_wrap env sym False Nominal co++    pick_lr CLeft  (l, _) = l+    pick_lr CRight (_, r) = r++-- See Note [Optimising InstCo]+opt_co4 env sym rep r (InstCo co1 arg)+    -- forall over type...+  | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1+  = opt_co4_wrap (extendLiftingContext env tv+                    (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg))+                   -- mkSymCo kind_co :: k1 ~ k2+                   -- sym_arg :: (t1 :: k1) ~ (t2 :: k2)+                   -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1)+                 sym rep r co_body++    -- forall over coercion...+  | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1+  , CoercionTy h1 <- t1+  , CoercionTy h2 <- t2+  = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2+    in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body++    -- See if it is a forall after optimization+    -- If so, do an inefficient one-variable substitution, then re-optimize++    -- forall over type...+  | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1'+  = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv'+                    (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg'))+            False False r' co_body'++    -- forall over coercion...+  | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1'+  , CoercionTy h1' <- t1'+  , CoercionTy h2' <- t2'+  = let new_co = mk_new_co cv' kind_co' h1' h2'+    in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co)+                    False False r' co_body'++  | otherwise = InstCo co1' arg'+  where+    co1'    = opt_co4_wrap env sym rep r co1+    r'      = chooseRole rep r+    arg'    = opt_co4_wrap env sym False Nominal arg+    sym_arg = wrapSym sym arg'++    -- Performance note: don't be alarmed by the two calls to coercionKind+    -- here, as only one call to coercionKind is actually demanded per guard.+    -- t1/t2 are used when checking if co1 is a forall, and t1'/t2' are used+    -- when checking if co1' (i.e., co1 post-optimization) is a forall.+    --+    -- t1/t2 must come from sym_arg, not arg', since it's possible that arg'+    -- might have an extra Sym at the front (after being optimized) that co1+    -- lacks, so we need to use sym_arg to balance the number of Syms. (#15725)+    Pair t1  t2  = coercionKind sym_arg+    Pair t1' t2' = coercionKind arg'++    mk_new_co cv kind_co h1 h2+      = let -- h1 :: (t1 ~ t2)+            -- h2 :: (t3 ~ t4)+            -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4)+            -- n1 :: t1 ~ t3+            -- n2 :: t2 ~ t4+            -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2)+            r2  = coVarRole cv+            kind_co' = downgradeRole r2 Nominal kind_co+            n1 = mkNthCo r2 2 kind_co'+            n2 = mkNthCo r2 3 kind_co'+         in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1+                           (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2))++opt_co4 env sym _rep r (KindCo co)+  = ASSERT( r == Nominal )+    let kco' = promoteCoercion co in+    case kco' of+      KindCo co' -> promoteCoercion (opt_co1 env sym co')+      _          -> opt_co4_wrap env sym False Nominal kco'+  -- This might be able to be optimized more to do the promotion+  -- and substitution/optimization at the same time++opt_co4 env sym _ r (SubCo co)+  = ASSERT( r == Representational )+    opt_co4_wrap env sym True Nominal co++-- This could perhaps be optimized more.+opt_co4 env sym rep r (AxiomRuleCo co cs)+  = ASSERT( r == coaxrRole co )+    wrapRole rep r $+    wrapSym sym $+    AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs)++{- Note [Optimise CoVarCo to Refl]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have (c :: t~t) we can optimise it to Refl. That increases the+chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t)++We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo]+in GHC.Core.Coercion.+-}++-------------+-- | Optimize a phantom coercion. The input coercion may not necessarily+-- be a phantom, but the output sure will be.+opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo+opt_phantom env sym co+  = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2+  where+    Pair ty1 ty2 = coercionKind co++{- Note [Differing kinds]+   ~~~~~~~~~~~~~~~~~~~~~~+The two types may not have the same kind (although that would be very unusual).+But even if they have the same kind, and the same type constructor, the number+of arguments in a `CoTyConApp` can differ. Consider++  Any :: forall k. k++  Any * Int                      :: *+  Any (*->*) Maybe Int  :: *++Hence the need to compare argument lengths; see #13658+ -}++opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role+         -> Type -> Type -> Coercion+opt_univ env sym (PhantomProv h) _r ty1 ty2+  | sym       = mkPhantomCo h' ty2' ty1'+  | otherwise = mkPhantomCo h' ty1' ty2'+  where+    h' = opt_co4 env sym False Nominal h+    ty1' = substTy (lcSubstLeft  env) ty1+    ty2' = substTy (lcSubstRight env) ty2++opt_univ env sym prov role oty1 oty2+  | Just (tc1, tys1) <- splitTyConApp_maybe oty1+  , Just (tc2, tys2) <- splitTyConApp_maybe oty2+  , tc1 == tc2+  , equalLength tys1 tys2 -- see Note [Differing kinds]+      -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom);+      -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps+  = let roles    = tyConRolesX role tc1+        arg_cos  = zipWith3 (mkUnivCo prov') roles tys1 tys2+        arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos+    in+    mkTyConAppCo role tc1 arg_cos'++  -- can't optimize the AppTy case because we can't build the kind coercions.++  | Just (tv1, ty1) <- splitForAllTy_ty_maybe oty1+  , Just (tv2, ty2) <- splitForAllTy_ty_maybe oty2+      -- NB: prov isn't interesting here either+  = let k1   = tyVarKind tv1+        k2   = tyVarKind tv2+        eta  = mkUnivCo prov' Nominal k1 k2+          -- eta gets opt'ed soon, but not yet.+        ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2++        (env', tv1', eta') = optForAllCoBndr env sym tv1 eta+    in+    mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2')++  | Just (cv1, ty1) <- splitForAllTy_co_maybe oty1+  , Just (cv2, ty2) <- splitForAllTy_co_maybe oty2+      -- NB: prov isn't interesting here either+  = let k1    = varType cv1+        k2    = varType cv2+        r'    = coVarRole cv1+        eta   = mkUnivCo prov' Nominal k1 k2+        eta_d = downgradeRole r' Nominal eta+          -- eta gets opt'ed soon, but not yet.+        n_co  = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo`+                (mkCoVarCo cv1) `mkTransCo`+                (mkNthCo r' 3 eta_d)+        ty2'  = substTyWithCoVars [cv2] [n_co] ty2++        (env', cv1', eta') = optForAllCoBndr env sym cv1 eta+    in+    mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2')++  | otherwise+  = let ty1 = substTyUnchecked (lcSubstLeft  env) oty1+        ty2 = substTyUnchecked (lcSubstRight env) oty2+        (a, b) | sym       = (ty2, ty1)+               | otherwise = (ty1, ty2)+    in+    mkUnivCo prov' role a b++  where+    prov' = case prov of+      PhantomProv kco    -> PhantomProv $ opt_co4_wrap env sym False Nominal kco+      ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco+      PluginProv _       -> prov++-------------+opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]+opt_transList is = zipWith (opt_trans is)++opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo+opt_trans is co1 co2+  | isReflCo co1 = co2+    -- optimize when co1 is a Refl Co+  | otherwise    = opt_trans1 is co1 co2++opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo+-- First arg is not the identity+opt_trans1 is co1 co2+  | isReflCo co2 = co1+    -- optimize when co2 is a Refl Co+  | otherwise    = opt_trans2 is co1 co2++opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo+-- Neither arg is the identity+opt_trans2 is (TransCo co1a co1b) co2+    -- Don't know whether the sub-coercions are the identity+  = opt_trans is co1a (opt_trans is co1b co2)++opt_trans2 is co1 co2+  | Just co <- opt_trans_rule is co1 co2+  = co++opt_trans2 is co1 (TransCo co2a co2b)+  | Just co1_2a <- opt_trans_rule is co1 co2a+  = if isReflCo co1_2a+    then co2b+    else opt_trans1 is co1_2a co2b++opt_trans2 _ co1 co2+  = mkTransCo co1 co2++------+-- Optimize coercions with a top-level use of transitivity.+opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo++opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2))+  = ASSERT( r1 == r2 )+    fireTransRule "GRefl" in_co1 in_co2 $+    mkGReflRightCo r1 t1 (opt_trans is co1 co2)++-- Push transitivity through matching destructors+opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2)+  | d1 == d2+  , coercionRole co1 == coercionRole co2+  , co1 `compatible_co` co2+  = ASSERT( r1 == r2 )+    fireTransRule "PushNth" in_co1 in_co2 $+    mkNthCo r1 d1 (opt_trans is co1 co2)++opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)+  | d1 == d2+  , co1 `compatible_co` co2+  = fireTransRule "PushLR" in_co1 in_co2 $+    mkLRCo d1 (opt_trans is co1 co2)++-- Push transitivity inside instantiation+opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)+  | ty1 `eqCoercion` ty2+  , co1 `compatible_co` co2+  = fireTransRule "TrPushInst" in_co1 in_co2 $+    mkInstCo (opt_trans is co1 co2) ty1++opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1)+                  in_co2@(UnivCo p2 r2 _tyl2 tyr2)+  | Just prov' <- opt_trans_prov p1 p2+  = ASSERT( r1 == r2 )+    fireTransRule "UnivCo" in_co1 in_co2 $+    mkUnivCo prov' r1 tyl1 tyr2+  where+    -- if the provenances are different, opt'ing will be very confusing+    opt_trans_prov (PhantomProv kco1)    (PhantomProv kco2)+      = Just $ PhantomProv $ opt_trans is kco1 kco2+    opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2)+      = Just $ ProofIrrelProv $ opt_trans is kco1 kco2+    opt_trans_prov (PluginProv str1)     (PluginProv str2)     | str1 == str2 = Just p1+    opt_trans_prov _ _ = Nothing++-- Push transitivity down through matching top-level constructors.+opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2)+  | tc1 == tc2+  = ASSERT( r1 == r2 )+    fireTransRule "PushTyConApp" in_co1 in_co2 $+    mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2)++opt_trans_rule is in_co1@(FunCo r1 co1a co1b) in_co2@(FunCo r2 co2a co2b)+  = ASSERT( r1 == r2 )   -- Just like the TyConAppCo/TyConAppCo case+    fireTransRule "PushFun" in_co1 in_co2 $+    mkFunCo r1 (opt_trans is co1a co2a) (opt_trans is co1b co2b)++opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)+  -- Must call opt_trans_rule_app; see Note [EtaAppCo]+  = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b]++-- Eta rules+opt_trans_rule is co1@(TyConAppCo r tc cos1) co2+  | Just cos2 <- etaTyConAppCo_maybe tc co2+  = ASSERT( cos1 `equalLength` cos2 )+    fireTransRule "EtaCompL" co1 co2 $+    mkTyConAppCo r tc (opt_transList is cos1 cos2)++opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)+  | Just cos1 <- etaTyConAppCo_maybe tc co1+  = ASSERT( cos1 `equalLength` cos2 )+    fireTransRule "EtaCompR" co1 co2 $+    mkTyConAppCo r tc (opt_transList is cos1 cos2)++opt_trans_rule is co1@(AppCo co1a co1b) co2+  | Just (co2a,co2b) <- etaAppCo_maybe co2+  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]++opt_trans_rule is co1 co2@(AppCo co2a co2b)+  | Just (co1a,co1b) <- etaAppCo_maybe co1+  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]++-- Push transitivity inside forall+-- forall over types.+opt_trans_rule is co1 co2+  | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1+  , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2+  = push_trans tv1 eta1 r1 tv2 eta2 r2++  | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2+  , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1+  = push_trans tv1 eta1 r1 tv2 eta2 r2++  where+  push_trans tv1 eta1 r1 tv2 eta2 r2+    -- Given:+    --   co1 = /\ tv1 : eta1. r1+    --   co2 = /\ tv2 : eta2. r2+    -- Wanted:+    --   /\tv1 : (eta1;eta2).  (r1; r2[tv2 |-> tv1 |> eta1])+    = fireTransRule "EtaAllTy_ty" co1 co2 $+      mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2')+    where+      is' = is `extendInScopeSet` tv1+      r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2++-- Push transitivity inside forall+-- forall over coercions.+opt_trans_rule is co1 co2+  | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1+  , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2+  = push_trans cv1 eta1 r1 cv2 eta2 r2++  | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2+  , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1+  = push_trans cv1 eta1 r1 cv2 eta2 r2++  where+  push_trans cv1 eta1 r1 cv2 eta2 r2+    -- Given:+    --   co1 = /\ cv1 : eta1. r1+    --   co2 = /\ cv2 : eta2. r2+    -- Wanted:+    --   n1 = nth 2 eta1+    --   n2 = nth 3 eta1+    --   nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2])+    = fireTransRule "EtaAllTy_co" co1 co2 $+      mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2')+    where+      is'  = is `extendInScopeSet` cv1+      role = coVarRole cv1+      eta1' = downgradeRole role Nominal eta1+      n1   = mkNthCo role 2 eta1'+      n2   = mkNthCo role 3 eta1'+      r2'  = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo`+                                        (mkCoVarCo cv1) `mkTransCo` n2])+                    r2++-- Push transitivity inside axioms+opt_trans_rule is co1 co2++  -- See Note [Why call checkAxInstCo during optimisation]+  -- TrPushSymAxR+  | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe+  , True <- sym+  , Just cos2 <- matchAxiom sym con ind co2+  , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1)+  , Nothing <- checkAxInstCo newAxInst+  = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst++  -- TrPushAxR+  | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe+  , False <- sym+  , Just cos2 <- matchAxiom sym con ind co2+  , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)+  , Nothing <- checkAxInstCo newAxInst+  = fireTransRule "TrPushAxR" co1 co2 newAxInst++  -- TrPushSymAxL+  | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe+  , True <- sym+  , Just cos1 <- matchAxiom (not sym) con ind co1+  , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1))+  , Nothing <- checkAxInstCo newAxInst+  = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst++  -- TrPushAxL+  | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe+  , False <- sym+  , Just cos1 <- matchAxiom (not sym) con ind co1+  , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)+  , Nothing <- checkAxInstCo newAxInst+  = fireTransRule "TrPushAxL" co1 co2 newAxInst++  -- TrPushAxSym/TrPushSymAx+  | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe+  , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe+  , con1 == con2+  , ind1 == ind2+  , sym1 == not sym2+  , let branch = coAxiomNthBranch con1 ind1+        qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch+        lhs  = coAxNthLHS con1 ind1+        rhs  = coAxBranchRHS branch+        pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs)+  , all (`elemVarSet` pivot_tvs) qtvs+  = fireTransRule "TrPushAxSym" co1 co2 $+    if sym2+       -- TrPushAxSym+    then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs+       -- TrPushSymAx+    else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs+  where+    co1_is_axiom_maybe = isAxiom_maybe co1+    co2_is_axiom_maybe = isAxiom_maybe co2+    role = coercionRole co1 -- should be the same as coercionRole co2!++opt_trans_rule _ co1 co2        -- Identity rule+  | let ty1 = coercionLKind co1+        r   = coercionRole co1+        ty2 = coercionRKind co2+  , ty1 `eqType` ty2+  = fireTransRule "RedTypeDirRefl" co1 co2 $+    mkReflCo r ty2++opt_trans_rule _ _ _ = Nothing++-- See Note [EtaAppCo]+opt_trans_rule_app :: InScopeSet+                   -> Coercion   -- original left-hand coercion (printing only)+                   -> Coercion   -- original right-hand coercion (printing only)+                   -> Coercion   -- left-hand coercion "function"+                   -> [Coercion] -- left-hand coercion "args"+                   -> Coercion   -- right-hand coercion "function"+                   -> [Coercion] -- right-hand coercion "args"+                   -> Maybe Coercion+opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs+  | AppCo co1aa co1ab <- co1a+  , Just (co2aa, co2ab) <- etaAppCo_maybe co2a+  = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)++  | AppCo co2aa co2ab <- co2a+  , Just (co1aa, co1ab) <- etaAppCo_maybe co1a+  = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)++  | otherwise+  = ASSERT( co1bs `equalLength` co2bs )+    fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $+    let rt1a = coercionRKind co1a++        lt2a = coercionLKind co2a+        rt2a = coercionRole  co2a++        rt1bs = map coercionRKind co1bs+        lt2bs = map coercionLKind co2bs+        rt2bs = map coercionRole co2bs++        kcoa = mkKindCo $ buildCoercion lt2a rt1a+        kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs++        co2a'   = mkCoherenceLeftCo rt2a lt2a kcoa co2a+        co2bs'  = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs+        co2bs'' = zipWith mkTransCo co2bs' co2bs+    in+    mkAppCos (opt_trans is co1a co2a')+             (zipWith (opt_trans is) co1bs co2bs'')++fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion+fireTransRule _rule _co1 _co2 res+  = Just res++{-+Note [Conflict checking with AxiomInstCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following type family and axiom:++type family Equal (a :: k) (b :: k) :: Bool+type instance where+  Equal a a = True+  Equal a b = False+--+Equal :: forall k::*. k -> k -> Bool+axEqual :: { forall k::*. forall a::k. Equal k a a ~ True+           ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False }++We wish to disallow (axEqual[1] <*> <Int> <Int). (Recall that the index is+0-based, so this is the second branch of the axiom.) The problem is that, on+the surface, it seems that (axEqual[1] <*> <Int> <Int>) :: (Equal * Int Int ~+False) and that all is OK. But, all is not OK: we want to use the first branch+of the axiom in this case, not the second. The problem is that the parameters+of the first branch can unify with the supplied coercions, thus meaning that+the first branch should be taken. See also Note [Apartness] in+types/FamInstEnv.hs.++Note [Why call checkAxInstCo during optimisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is possible that otherwise-good-looking optimisations meet with disaster+in the presence of axioms with multiple equations. Consider++type family Equal (a :: *) (b :: *) :: Bool where+  Equal a a = True+  Equal a b = False+type family Id (a :: *) :: * where+  Id a = a++axEq :: { [a::*].       Equal a a ~ True+        ; [a::*, b::*]. Equal a b ~ False }+axId :: [a::*]. Id a ~ a++co1 = Equal (axId[0] Int) (axId[0] Bool)+  :: Equal (Id Int) (Id Bool) ~  Equal Int Bool+co2 = axEq[1] <Int> <Bool>+  :: Equal Int Bool ~ False++We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that+co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what+happens when we push the coercions inside? We get++co3 = axEq[1] (axId[0] Int) (axId[0] Bool)+  :: Equal (Id Int) (Id Bool) ~ False++which is bogus! This is because the type system isn't smart enough to know+that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type+families. At the time of writing, I (Richard Eisenberg) couldn't think of+a way of detecting this any more efficient than just building the optimised+coercion and checking.++Note [EtaAppCo]+~~~~~~~~~~~~~~~+Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd+like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that+the resultant coercions might not be well kinded. Here is an example (things+labeled with x don't matter in this example):++  k1 :: Type+  k2 :: Type++  a :: k1 -> Type+  b :: k1++  h :: k1 ~ k2++  co1a :: x1 ~ (a |> (h -> <Type>)+  co1b :: x2 ~ (b |> h)++  co2a :: a ~ x3+  co2b :: b ~ x4++First, convince yourself of the following:++  co1a co1b :: x1 x2 ~ (a |> (h -> <Type>)) (b |> h)+  co2a co2b :: a b   ~ x3 x4++  (a |> (h -> <Type>)) (b |> h) `eqType` a b++That last fact is due to Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep,+where we ignore coercions in types as long as two types' kinds are the same.+In our case, we meet this last condition, because++  (a |> (h -> <Type>)) (b |> h) :: Type+    and+  a b :: Type++So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the+suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the+kinds don't match up.++The solution here is to twiddle the kinds in the output coercions. First, we+need to find coercions++  ak :: kind(a |> (h -> <Type>)) ~ kind(a)+  bk :: kind(b |> h)             ~ kind(b)++This can be done with mkKindCo and buildCoercion. The latter assumes two+types are identical modulo casts and builds a coercion between them.++Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the+output coercions. These are well-kinded.++Also, note that all of this is done after accumulated any nested AppCo+parameters. This step is to avoid quadratic behavior in calling coercionKind.++The problem described here was first found in dependent/should_compile/dynamic-paper.++-}++-- | Check to make sure that an AxInstCo is internally consistent.+-- Returns the conflicting branch, if it exists+-- See Note [Conflict checking with AxiomInstCo]+checkAxInstCo :: Coercion -> Maybe CoAxBranch+-- defined here to avoid dependencies in GHC.Core.Coercion+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+checkAxInstCo (AxiomInstCo ax ind cos)+  = let branch       = coAxiomNthBranch ax ind+        tvs          = coAxBranchTyVars branch+        cvs          = coAxBranchCoVars branch+        incomps      = coAxBranchIncomps branch+        (tys, cotys) = splitAtList tvs (map coercionLKind cos)+        co_args      = map stripCoercionTy cotys+        subst        = zipTvSubst tvs tys `composeTCvSubst`+                       zipCvSubst cvs co_args+        target   = Type.substTys subst (coAxBranchLHS branch)+        in_scope = mkInScopeSet $+                   unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps)+        flattened_target = flattenTys in_scope target in+    check_no_conflict flattened_target incomps+  where+    check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch+    check_no_conflict _    [] = Nothing+    check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest)+         -- See Note [Apartness] in GHC.Core.FamInstEnv+      | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp+      = check_no_conflict flat rest+      | otherwise+      = Just b+checkAxInstCo _ = Nothing+++-----------+wrapSym :: SymFlag -> Coercion -> Coercion+wrapSym sym co | sym       = mkSymCo co+               | otherwise = co++-- | Conditionally set a role to be representational+wrapRole :: ReprFlag+         -> Role         -- ^ current role+         -> Coercion -> Coercion+wrapRole False _       = id+wrapRole True  current = downgradeRole Representational current++-- | If we require a representational role, return that. Otherwise,+-- return the "default" role provided.+chooseRole :: ReprFlag+           -> Role    -- ^ "default" role+           -> Role+chooseRole True _ = Representational+chooseRole _    r = r++-----------+isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion])+isAxiom_maybe (SymCo co)+  | Just (sym, con, ind, cos) <- isAxiom_maybe co+  = Just (not sym, con, ind, cos)+isAxiom_maybe (AxiomInstCo con ind cos)+  = Just (False, con, ind, cos)+isAxiom_maybe _ = Nothing++matchAxiom :: Bool -- True = match LHS, False = match RHS+           -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion]+matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co+  | CoAxBranch { cab_tvs = qtvs+               , cab_cvs = []   -- can't infer these, so fail if there are any+               , cab_roles = roles+               , cab_lhs = lhs+               , cab_rhs = rhs } <- coAxiomNthBranch ax ind+  , Just subst <- liftCoMatch (mkVarSet qtvs)+                              (if sym then (mkTyConApp tc lhs) else rhs)+                              co+  , all (`isMappedByLC` subst) qtvs+  = zipWithM (liftCoSubstTyVar subst) roles qtvs++  | otherwise+  = Nothing++-------------+compatible_co :: Coercion -> Coercion -> Bool+-- Check whether (co1 . co2) will be well-kinded+compatible_co co1 co2+  = x1 `eqType` x2+  where+    x1 = coercionRKind co1+    x2 = coercionLKind co2++-------------+{-+etaForAllCo+~~~~~~~~~~~~~~~~~+(1) etaForAllCo_ty_maybe+Suppose we have++  g : all a1:k1.t1  ~  all a2:k2.t2++but g is *not* a ForAllCo. We want to eta-expand it. So, we do this:++  g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g))++Call the kind coercion h1 and the body coercion h2. We can see that++  h2 : t1 ~ t2[a2 |-> (a1 |> h1)]++According to the typing rule for ForAllCo, we get that++  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1])++or++  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> a1])++as desired.++(2) etaForAllCo_co_maybe+Suppose we have++  g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2++Similarly, we do this++  g' = all c1:h1. h2+     : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)]+                                              [c1 |-> eta1;c1;sym eta2]++Here,++  h1   = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4)+  eta1 = mkNthCo r 2 h1      :: (s1 ~ s3)+  eta2 = mkNthCo r 3 h1      :: (s2 ~ s4)+  h2   = mkInstCo g (cv1 ~ (sym eta1;c1;eta2))+-}+etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)+-- Try to make the coercion be of form (forall tv:kind_co. co)+etaForAllCo_ty_maybe co+  | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co+  = Just (tv, kind_co, r)++  | Pair ty1 ty2  <- coercionKind co+  , Just (tv1, _) <- splitForAllTy_ty_maybe ty1+  , isForAllTy_ty ty2+  , let kind_co = mkNthCo Nominal 0 co+  = Just ( tv1, kind_co+         , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co))++  | otherwise+  = Nothing++etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)+-- Try to make the coercion be of form (forall cv:kind_co. co)+etaForAllCo_co_maybe co+  | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co+  = Just (cv, kind_co, r)++  | Pair ty1 ty2  <- coercionKind co+  , Just (cv1, _) <- splitForAllTy_co_maybe ty1+  , isForAllTy_co ty2+  = let kind_co  = mkNthCo Nominal 0 co+        r        = coVarRole cv1+        l_co     = mkCoVarCo cv1+        kind_co' = downgradeRole r Nominal kind_co+        r_co     = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo`+                   l_co `mkTransCo`+                   (mkNthCo r 3 kind_co')+    in Just ( cv1, kind_co+            , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co))++  | otherwise+  = Nothing++etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion)+-- If possible, split a coercion+--   g :: t1a t1b ~ t2a t2b+-- into a pair of coercions (left g, right g)+etaAppCo_maybe co+  | Just (co1,co2) <- splitAppCo_maybe co+  = Just (co1,co2)+  | (Pair ty1 ty2, Nominal) <- coercionKindRole co+  , Just (_,t1) <- splitAppTy_maybe ty1+  , Just (_,t2) <- splitAppTy_maybe ty2+  , let isco1 = isCoercionTy t1+  , let isco2 = isCoercionTy t2+  , isco1 == isco2+  = Just (LRCo CLeft co, LRCo CRight co)+  | otherwise+  = Nothing++etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]+-- If possible, split a coercion+--       g :: T s1 .. sn ~ T t1 .. tn+-- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ]+etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)+  = ASSERT( tc == tc2 ) Just cos2++etaTyConAppCo_maybe tc co+  | not (mustBeSaturated tc)+  , (Pair ty1 ty2, r) <- coercionKindRole co+  , Just (tc1, tys1)  <- splitTyConApp_maybe ty1+  , Just (tc2, tys2)  <- splitTyConApp_maybe ty2+  , tc1 == tc2+  , isInjectiveTyCon tc r  -- See Note [NthCo and newtypes] in GHC.Core.TyCo.Rep+  , let n = length tys1+  , tys2 `lengthIs` n      -- This can fail in an erroneous program+                           -- E.g. T a ~# T a b+                           -- #14607+  = ASSERT( tc == tc1 )+    Just (decomposeCo n co (tyConRolesX r tc1))+    -- NB: n might be <> tyConArity tc+    -- e.g.   data family T a :: * -> *+    --        g :: T a b ~ T c d++  | otherwise+  = Nothing++{-+Note [Eta for AppCo]+~~~~~~~~~~~~~~~~~~~~+Suppose we have+   g :: s1 t1 ~ s2 t2++Then we can't necessarily make+   left  g :: s1 ~ s2+   right g :: t1 ~ t2+because it's possible that+   s1 :: * -> *         t1 :: *+   s2 :: (*->*) -> *    t2 :: * -> *+and in that case (left g) does not have the same+kind on either side.++It's enough to check that+  kind t1 = kind t2+because if g is well-kinded then+  kind (s1 t2) = kind (s2 t2)+and these two imply+  kind s1 = kind s2++-}++optForAllCoBndr :: LiftingContext -> Bool+                -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion)+optForAllCoBndr env sym+  = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env
+ compiler/GHC/Core/ConLike.hs view
@@ -0,0 +1,196 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998++\section[ConLike]{@ConLike@: Constructor-like things}+-}++{-# LANGUAGE CPP #-}++module GHC.Core.ConLike (+          ConLike(..)+        , conLikeArity+        , conLikeFieldLabels+        , conLikeInstOrigArgTys+        , conLikeExTyCoVars+        , conLikeName+        , conLikeStupidTheta+        , conLikeWrapId_maybe+        , conLikeImplBangs+        , conLikeFullSig+        , conLikeResTy+        , conLikeFieldType+        , conLikesWithFields+        , conLikeIsInfix+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Core.DataCon+import GHC.Core.PatSyn+import Outputable+import GHC.Types.Unique+import Util+import GHC.Types.Name+import GHC.Types.Basic+import GHC.Core.TyCo.Rep (Type, ThetaType)+import GHC.Types.Var+import GHC.Core.Type(mkTyConApp)++import qualified Data.Data as Data++{-+************************************************************************+*                                                                      *+\subsection{Constructor-like things}+*                                                                      *+************************************************************************+-}++-- | A constructor-like thing+data ConLike = RealDataCon DataCon+             | PatSynCon PatSyn++{-+************************************************************************+*                                                                      *+\subsection{Instances}+*                                                                      *+************************************************************************+-}++instance Eq ConLike where+    (==) = eqConLike++eqConLike :: ConLike -> ConLike -> Bool+eqConLike x y = getUnique x == getUnique y++-- There used to be an Ord ConLike instance here that used Unique for ordering.+-- It was intentionally removed to prevent determinism problems.+-- See Note [Unique Determinism] in GHC.Types.Unique.++instance Uniquable ConLike where+    getUnique (RealDataCon dc) = getUnique dc+    getUnique (PatSynCon ps)   = getUnique ps++instance NamedThing ConLike where+    getName (RealDataCon dc) = getName dc+    getName (PatSynCon ps)   = getName ps++instance Outputable ConLike where+    ppr (RealDataCon dc) = ppr dc+    ppr (PatSynCon ps) = ppr ps++instance OutputableBndr ConLike where+    pprInfixOcc (RealDataCon dc) = pprInfixOcc dc+    pprInfixOcc (PatSynCon ps) = pprInfixOcc ps+    pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc+    pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps++instance Data.Data ConLike where+    -- don't traverse?+    toConstr _   = abstractConstr "ConLike"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "ConLike"++-- | Number of arguments+conLikeArity :: ConLike -> Arity+conLikeArity (RealDataCon data_con) = dataConSourceArity data_con+conLikeArity (PatSynCon pat_syn)    = patSynArity pat_syn++-- | Names of fields used for selectors+conLikeFieldLabels :: ConLike -> [FieldLabel]+conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con+conLikeFieldLabels (PatSynCon pat_syn)    = patSynFieldLabels pat_syn++-- | Returns just the instantiated /value/ argument types of a 'ConLike',+-- (excluding dictionary args)+conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type]+conLikeInstOrigArgTys (RealDataCon data_con) tys =+    dataConInstOrigArgTys data_con tys+conLikeInstOrigArgTys (PatSynCon pat_syn) tys =+    patSynInstArgTys pat_syn tys++-- | Existentially quantified type/coercion variables+conLikeExTyCoVars :: ConLike -> [TyCoVar]+conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1+conLikeExTyCoVars (PatSynCon psyn1)   = patSynExTyVars psyn1++conLikeName :: ConLike -> Name+conLikeName (RealDataCon data_con) = dataConName data_con+conLikeName (PatSynCon pat_syn)    = patSynName pat_syn++-- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in:+--+-- > data Eq a => T a = ...+-- It is empty for `PatSynCon` as they do not allow such contexts.+conLikeStupidTheta :: ConLike -> ThetaType+conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con+conLikeStupidTheta (PatSynCon {})         = []++-- | Returns the `Id` of the wrapper. This is also known as the builder in+-- some contexts. The value is Nothing only in the case of unidirectional+-- pattern synonyms.+conLikeWrapId_maybe :: ConLike -> Maybe Id+conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con+conLikeWrapId_maybe (PatSynCon pat_syn)    = fst <$> patSynBuilder pat_syn++-- | Returns the strictness information for each constructor+conLikeImplBangs :: ConLike -> [HsImplBang]+conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con+conLikeImplBangs (PatSynCon pat_syn)    =+    replicate (patSynArity pat_syn) HsLazy++-- | Returns the type of the whole pattern+conLikeResTy :: ConLike -> [Type] -> Type+conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys+conLikeResTy (PatSynCon ps)    tys = patSynInstResTy ps tys++-- | The \"full signature\" of the 'ConLike' returns, in order:+--+-- 1) The universally quantified type variables+--+-- 2) The existentially quantified type/coercion variables+--+-- 3) The equality specification+--+-- 4) The provided theta (the constraints provided by a match)+--+-- 5) The required theta (the constraints required for a match)+--+-- 6) The original argument types (i.e. before+--    any change of the representation of the type)+--+-- 7) The original result type+conLikeFullSig :: ConLike+               -> ([TyVar], [TyCoVar], [EqSpec]+                   -- Why tyvars for universal but tycovars for existential?+                   -- See Note [Existential coercion variables] in GHC.Core.DataCon+                  , ThetaType, ThetaType, [Type], Type)+conLikeFullSig (RealDataCon con) =+  let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con+  -- Required theta is empty as normal data cons require no additional+  -- constraints for a match+  in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty)+conLikeFullSig (PatSynCon pat_syn) =+ let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn+ -- eqSpec is empty+ in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty)++-- | Extract the type for any given labelled field of the 'ConLike'+conLikeFieldType :: ConLike -> FieldLabelString -> Type+conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label+conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label+++-- | The ConLikes that have *all* the given fields+conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]+conLikesWithFields con_likes lbls = filter has_flds con_likes+  where has_flds dc = all (has_fld dc) lbls+        has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)++conLikeIsInfix :: ConLike -> Bool+conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc+conLikeIsInfix (PatSynCon ps)   = patSynIsInfix  ps
+ compiler/GHC/Core/ConLike.hs-boot view
@@ -0,0 +1,9 @@+module GHC.Core.ConLike where+import {-# SOURCE #-} GHC.Core.DataCon (DataCon)+import {-# SOURCE #-} GHC.Core.PatSyn (PatSyn)+import GHC.Types.Name ( Name )++data ConLike = RealDataCon DataCon+             | PatSynCon PatSyn++conLikeName :: ConLike -> Name
+ compiler/GHC/Core/DataCon.hs view
@@ -0,0 +1,1468 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998++\section[DataCon]{@DataCon@: Data Constructors}+-}++{-# LANGUAGE CPP, DeriveDataTypeable #-}++module GHC.Core.DataCon (+        -- * Main data types+        DataCon, DataConRep(..),+        SrcStrictness(..), SrcUnpackedness(..),+        HsSrcBang(..), HsImplBang(..),+        StrictnessMark(..),+        ConTag,++        -- ** Equality specs+        EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType,+        eqSpecPair, eqSpecPreds,+        substEqSpec, filterEqSpec,++        -- ** Field labels+        FieldLbl(..), FieldLabel, FieldLabelString,++        -- ** Type construction+        mkDataCon, fIRST_TAG,++        -- ** Type deconstruction+        dataConRepType, dataConInstSig, dataConFullSig,+        dataConName, dataConIdentity, dataConTag, dataConTagZ,+        dataConTyCon, dataConOrigTyCon,+        dataConUserType,+        dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars,+        dataConUserTyVars, dataConUserTyVarBinders,+        dataConEqSpec, dataConTheta,+        dataConStupidTheta,+        dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,+        dataConInstOrigArgTys, dataConRepArgTys,+        dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,+        dataConSrcBangs,+        dataConSourceArity, dataConRepArity,+        dataConIsInfix,+        dataConWorkId, dataConWrapId, dataConWrapId_maybe,+        dataConImplicitTyThings,+        dataConRepStrictness, dataConImplBangs, dataConBoxer,++        splitDataProductType_maybe,++        -- ** Predicates on DataCons+        isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,+        isUnboxedSumCon,+        isVanillaDataCon, classDataCon, dataConCannotMatch,+        dataConUserTyVarsArePermuted,+        isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,+        specialPromotedDc,++        -- ** Promotion related functions+        promoteDataCon+    ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer )+import GHC.Core.Type as Type+import GHC.Core.Coercion+import GHC.Core.Unify+import GHC.Core.TyCon+import GHC.Types.FieldLabel+import GHC.Core.Class+import GHC.Types.Name+import PrelNames+import GHC.Core.Predicate+import GHC.Types.Var+import Outputable+import Util+import GHC.Types.Basic+import FastString+import GHC.Types.Module+import Binary+import GHC.Types.Unique.Set+import GHC.Types.Unique( mkAlphaTyVarUnique )++import Data.ByteString (ByteString)+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Lazy    as LBS+import qualified Data.Data as Data+import Data.Char+import Data.List( find )++{-+Data constructor representation+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following Haskell data type declaration++        data T = T !Int ![Int]++Using the strictness annotations, GHC will represent this as++        data T = T Int# [Int]++That is, the Int has been unboxed.  Furthermore, the Haskell source construction++        T e1 e2++is translated to++        case e1 of { I# x ->+        case e2 of { r ->+        T x r }}++That is, the first argument is unboxed, and the second is evaluated.  Finally,+pattern matching is translated too:++        case e of { T a b -> ... }++becomes++        case e of { T a' b -> let a = I# a' in ... }++To keep ourselves sane, we name the different versions of the data constructor+differently, as follows.+++Note [Data Constructor Naming]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Each data constructor C has two, and possibly up to four, Names associated with it:++                   OccName   Name space   Name of   Notes+ ---------------------------------------------------------------------------+ The "data con itself"   C     DataName   DataCon   In dom( GlobalRdrEnv )+ The "worker data con"   C     VarName    Id        The worker+ The "wrapper data con"  $WC   VarName    Id        The wrapper+ The "newtype coercion"  :CoT  TcClsName  TyCon++EVERY data constructor (incl for newtypes) has the former two (the+data con itself, and its worker.  But only some data constructors have a+wrapper (see Note [The need for a wrapper]).++Each of these three has a distinct Unique.  The "data con itself" name+appears in the output of the renamer, and names the Haskell-source+data constructor.  The type checker translates it into either the wrapper Id+(if it exists) or worker Id (otherwise).++The data con has one or two Ids associated with it:++The "worker Id", is the actual data constructor.+* Every data constructor (newtype or data type) has a worker++* The worker is very like a primop, in that it has no binding.++* For a *data* type, the worker *is* the data constructor;+  it has no unfolding++* For a *newtype*, the worker has a compulsory unfolding which+  does a cast, e.g.+        newtype T = MkT Int+        The worker for MkT has unfolding+                \\(x:Int). x `cast` sym CoT+  Here CoT is the type constructor, witnessing the FC axiom+        axiom CoT : T = Int++The "wrapper Id", \$WC, goes as follows++* Its type is exactly what it looks like in the source program.++* It is an ordinary function, and it gets a top-level binding+  like any other function.++* The wrapper Id isn't generated for a data type if there is+  nothing for the wrapper to do.  That is, if its defn would be+        \$wC = C++Note [Data constructor workers and wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Algebraic data types+  - Always have a worker, with no unfolding+  - May or may not have a wrapper; see Note [The need for a wrapper]++* Newtypes+  - Always have a worker, which has a compulsory unfolding (just a cast)+  - May or may not have a wrapper; see Note [The need for a wrapper]++* INVARIANT: the dictionary constructor for a class+             never has a wrapper.++* Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments++* The wrapper (if it exists) takes dcOrigArgTys as its arguments+  The worker takes dataConRepArgTys as its arguments+  If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys++* The 'NoDataConRep' case of DataConRep is important. Not only is it+  efficient, but it also ensures that the wrapper is replaced by the+  worker (because it *is* the worker) even when there are no+  args. E.g. in+               f (:) x+  the (:) *is* the worker.  This is really important in rule matching,+  (We could match on the wrappers, but that makes it less likely that+  rules will match when we bring bits of unfoldings together.)++Note [The need for a wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Why might the wrapper have anything to do?  The full story is+in wrapper_reqd in GHC.Types.Id.Make.mkDataConRep.++* Unboxing strict fields (with -funbox-strict-fields)+        data T = MkT !(Int,Int)+        \$wMkT :: (Int,Int) -> T+        \$wMkT (x,y) = MkT x y+  Notice that the worker has two fields where the wapper has+  just one.  That is, the worker has type+                MkT :: Int -> Int -> T++* Equality constraints for GADTs+        data T a where { MkT :: a -> T [a] }++  The worker gets a type with explicit equality+  constraints, thus:+        MkT :: forall a b. (a=[b]) => b -> T a++  The wrapper has the programmer-specified type:+        \$wMkT :: a -> T [a]+        \$wMkT a x = MkT [a] a [a] x+  The third argument is a coercion+        [a] :: [a]~[a]++* Data family instances may do a cast on the result++* Type variables may be permuted; see MkId+  Note [Data con wrappers and GADT syntax]+++Note [The stupid context]+~~~~~~~~~~~~~~~~~~~~~~~~~+Data types can have a context:++        data (Eq a, Ord b) => T a b = T1 a b | T2 a++and that makes the constructors have a context too+(notice that T2's context is "thinned"):++        T1 :: (Eq a, Ord b) => a -> b -> T a b+        T2 :: (Eq a) => a -> T a b++Furthermore, this context pops up when pattern matching+(though GHC hasn't implemented this, but it is in H98, and+I've fixed GHC so that it now does):++        f (T2 x) = x+gets inferred type+        f :: Eq a => T a b -> a++I say the context is "stupid" because the dictionaries passed+are immediately discarded -- they do nothing and have no benefit.+It's a flaw in the language.++        Up to now [March 2002] I have put this stupid context into the+        type of the "wrapper" constructors functions, T1 and T2, but+        that turned out to be jolly inconvenient for generics, and+        record update, and other functions that build values of type T+        (because they don't have suitable dictionaries available).++        So now I've taken the stupid context out.  I simply deal with+        it separately in the type checker on occurrences of a+        constructor, either in an expression or in a pattern.++        [May 2003: actually I think this decision could easily be+        reversed now, and probably should be.  Generics could be+        disabled for types with a stupid context; record updates now+        (H98) needs the context too; etc.  It's an unforced change, so+        I'm leaving it for now --- but it does seem odd that the+        wrapper doesn't include the stupid context.]++[July 04] With the advent of generalised data types, it's less obvious+what the "stupid context" is.  Consider+        C :: forall a. Ord a => a -> a -> T (Foo a)+Does the C constructor in Core contain the Ord dictionary?  Yes, it must:++        f :: T b -> Ordering+        f = /\b. \x:T b.+            case x of+                C a (d:Ord a) (p:a) (q:a) -> compare d p q++Note that (Foo a) might not be an instance of Ord.++************************************************************************+*                                                                      *+\subsection{Data constructors}+*                                                                      *+************************************************************************+-}++-- | A data constructor+--+-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',+--             'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma'++-- For details on above see note [Api annotations] in ApiAnnotation+data DataCon+  = MkData {+        dcName    :: Name,      -- This is the name of the *source data con*+                                -- (see "Note [Data Constructor Naming]" above)+        dcUnique :: Unique,     -- Cached from Name+        dcTag    :: ConTag,     -- ^ Tag, used for ordering 'DataCon's++        -- Running example:+        --+        --      *** As declared by the user+        --  data T a b c where+        --    MkT :: forall c y x b. (x~y,Ord x) => x -> y -> T (x,y) b c++        --      *** As represented internally+        --  data T a b c where+        --    MkT :: forall a b c. forall x y. (a~(x,y),x~y,Ord x)+        --        => x -> y -> T a b c+        --+        -- The next six fields express the type of the constructor, in pieces+        -- e.g.+        --+        --      dcUnivTyVars       = [a,b,c]+        --      dcExTyCoVars       = [x,y]+        --      dcUserTyVarBinders = [c,y,x,b]+        --      dcEqSpec           = [a~(x,y)]+        --      dcOtherTheta       = [x~y, Ord x]+        --      dcOrigArgTys       = [x,y]+        --      dcRepTyCon         = T++        -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE+        -- TYVARS FOR THE PARENT TyCon. (This is a change (Oct05): previously,+        -- vanilla datacons guaranteed to have the same type variables as their+        -- parent TyCon, but that seems ugly.) They can be different in the case+        -- where a GADT constructor uses different names for the universal+        -- tyvars than does the tycon. For example:+        --+        --   data H a where+        --     MkH :: b -> H b+        --+        -- Here, the tyConTyVars of H will be [a], but the dcUnivTyVars of MkH+        -- will be [b].++        dcVanilla :: Bool,      -- True <=> This is a vanilla Haskell 98 data constructor+                                --          Its type is of form+                                --              forall a1..an . t1 -> ... tm -> T a1..an+                                --          No existentials, no coercions, nothing.+                                -- That is: dcExTyCoVars = dcEqSpec = dcOtherTheta = []+                -- NB 1: newtypes always have a vanilla data con+                -- NB 2: a vanilla constructor can still be declared in GADT-style+                --       syntax, provided its type looks like the above.+                --       The declaration format is held in the TyCon (algTcGadtSyntax)++        -- Universally-quantified type vars [a,b,c]+        -- INVARIANT: length matches arity of the dcRepTyCon+        -- INVARIANT: result type of data con worker is exactly (T a b c)+        -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with+        --            the tyConTyVars of the parent TyCon+        dcUnivTyVars     :: [TyVar],++        -- Existentially-quantified type and coercion vars [x,y]+        -- For an example involving coercion variables,+        -- Why tycovars? See Note [Existential coercion variables]+        dcExTyCoVars     :: [TyCoVar],++        -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames+        -- Reason: less confusing, and easier to generate Iface syntax++        -- The type/coercion vars in the order the user wrote them [c,y,x,b]+        -- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the set+        --            of tyvars (*not* covars) of dcExTyCoVars unioned with the+        --            set of dcUnivTyVars whose tyvars do not appear in dcEqSpec+        -- See Note [DataCon user type variable binders]+        dcUserTyVarBinders :: [TyVarBinder],++        dcEqSpec :: [EqSpec],   -- Equalities derived from the result type,+                                -- _as written by the programmer_.+                                -- Only non-dependent GADT equalities (dependent+                                -- GADT equalities are in the covars of+                                -- dcExTyCoVars).++                -- This field allows us to move conveniently between the two ways+                -- of representing a GADT constructor's type:+                --      MkT :: forall a b. (a ~ [b]) => b -> T a+                --      MkT :: forall b. b -> T [b]+                -- Each equality is of the form (a ~ ty), where 'a' is one of+                -- the universally quantified type variables++                -- The next two fields give the type context of the data constructor+                --      (aside from the GADT constraints,+                --       which are given by the dcExpSpec)+                -- In GADT form, this is *exactly* what the programmer writes, even if+                -- the context constrains only universally quantified variables+                --      MkT :: forall a b. (a ~ b, Ord b) => a -> T a b+        dcOtherTheta :: ThetaType,  -- The other constraints in the data con's type+                                    -- other than those in the dcEqSpec++        dcStupidTheta :: ThetaType,     -- The context of the data type declaration+                                        --      data Eq a => T a = ...+                                        -- or, rather, a "thinned" version thereof+                -- "Thinned", because the Report says+                -- to eliminate any constraints that don't mention+                -- tyvars free in the arg types for this constructor+                --+                -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars+                -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon+                --+                -- "Stupid", because the dictionaries aren't used for anything.+                -- Indeed, [as of March 02] they are no longer in the type of+                -- the wrapper Id, because that makes it harder to use the wrap-id+                -- to rebuild values after record selection or in generics.++        dcOrigArgTys :: [Type],         -- Original argument types+                                        -- (before unboxing and flattening of strict fields)+        dcOrigResTy :: Type,            -- Original result type, as seen by the user+                -- NB: for a data instance, the original user result type may+                -- differ from the DataCon's representation TyCon.  Example+                --      data instance T [a] where MkT :: a -> T [a]+                -- The OrigResTy is T [a], but the dcRepTyCon might be :T123++        -- Now the strictness annotations and field labels of the constructor+        dcSrcBangs :: [HsSrcBang],+                -- See Note [Bangs on data constructor arguments]+                --+                -- The [HsSrcBang] as written by the programmer.+                --+                -- Matches 1-1 with dcOrigArgTys+                -- Hence length = dataConSourceArity dataCon++        dcFields  :: [FieldLabel],+                -- Field labels for this constructor, in the+                -- same order as the dcOrigArgTys;+                -- length = 0 (if not a record) or dataConSourceArity.++        -- The curried worker function that corresponds to the constructor:+        -- It doesn't have an unfolding; the code generator saturates these Ids+        -- and allocates a real constructor when it finds one.+        dcWorkId :: Id,++        -- Constructor representation+        dcRep      :: DataConRep,++        -- Cached; see Note [DataCon arities]+        -- INVARIANT: dcRepArity    == length dataConRepArgTys + count isCoVar (dcExTyCoVars)+        -- INVARIANT: dcSourceArity == length dcOrigArgTys+        dcRepArity    :: Arity,+        dcSourceArity :: Arity,++        -- Result type of constructor is T t1..tn+        dcRepTyCon  :: TyCon,           -- Result tycon, T++        dcRepType   :: Type,    -- Type of the constructor+                                --      forall a x y. (a~(x,y), x~y, Ord x) =>+                                --        x -> y -> T a+                                -- (this is *not* of the constructor wrapper Id:+                                --  see Note [Data con representation] below)+        -- Notice that the existential type parameters come *second*.+        -- Reason: in a case expression we may find:+        --      case (e :: T t) of+        --        MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ...+        -- It's convenient to apply the rep-type of MkT to 't', to get+        --      forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t+        -- and use that to check the pattern.  Mind you, this is really only+        -- used in GHC.Core.Lint.+++        dcInfix :: Bool,        -- True <=> declared infix+                                -- Used for Template Haskell and 'deriving' only+                                -- The actual fixity is stored elsewhere++        dcPromoted :: TyCon    -- The promoted TyCon+                               -- See Note [Promoted data constructors] in GHC.Core.TyCon+  }+++{- Note [TyVarBinders in DataCons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For the TyVarBinders in a DataCon and PatSyn:++ * Each argument flag is Inferred or Specified.+   None are Required. (A DataCon is a term-level function; see+   Note [No Required TyCoBinder in terms] in GHC.Core.TyCo.Rep.)++Why do we need the TyVarBinders, rather than just the TyVars?  So that+we can construct the right type for the DataCon with its foralls+attributed the correct visibility.  That in turn governs whether you+can use visible type application at a call of the data constructor.++See also [DataCon user type variable binders] for an extended discussion on the+order in which TyVarBinders appear in a DataCon.++Note [Existential coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++For now (Aug 2018) we can't write coercion quantifications in source Haskell, but+we can in Core. Consider having:++  data T :: forall k. k -> k -> Constraint where+    MkT :: forall k (a::k) (b::k). forall k' (c::k') (co::k'~k). (b~(c|>co))+        => T k a b++  dcUnivTyVars       = [k,a,b]+  dcExTyCoVars       = [k',c,co]+  dcUserTyVarBinders = [k,a,k',c]+  dcEqSpec           = [b~(c|>co)]+  dcOtherTheta       = []+  dcOrigArgTys       = []+  dcRepTyCon         = T++  Function call 'dataConKindEqSpec' returns [k'~k]++Note [DataCon arities]+~~~~~~~~~~~~~~~~~~~~~~+dcSourceArity does not take constraints into account,+but dcRepArity does.  For example:+   MkT :: Ord a => a -> T a+    dcSourceArity = 1+    dcRepArity    = 2++Note [DataCon user type variable binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In System FC, data constructor type signatures always quantify over all of+their universal type variables, followed by their existential type variables.+Normally, this isn't a problem, as most datatypes naturally quantify their type+variables in this order anyway. For example:++  data T a b = forall c. MkT b c++Here, we have `MkT :: forall {k} (a :: k) (b :: *) (c :: *). b -> c -> T a b`,+where k, a, and b are universal and c is existential. (The inferred variable k+isn't available for TypeApplications, hence why it's in braces.) This is a+perfectly reasonable order to use, as the syntax of H98-style datatypes+(+ ExistentialQuantification) suggests it.++Things become more complicated when GADT syntax enters the picture. Consider+this example:++  data X a where+    MkX :: forall b a. b -> Proxy a -> X a++If we adopt the earlier approach of quantifying all the universal variables+followed by all the existential ones, GHC would come up with this type+signature for MkX:++  MkX :: forall {k} (a :: k) (b :: *). b -> Proxy a -> X a++But this is not what we want at all! After all, if a user were to use+TypeApplications on MkX, they would expect to instantiate `b` before `a`,+as that's the order in which they were written in the `forall`. (See #11721.)+Instead, we'd like GHC to come up with this type signature:++  MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a++In fact, even if we left off the explicit forall:++  data X a where+    MkX :: b -> Proxy a -> X a++Then a user should still expect `b` to be quantified before `a`, since+according to the rules of TypeApplications, in the absence of `forall` GHC+performs a stable topological sort on the type variables in the user-written+type signature, which would place `b` before `a`.++But as noted above, enacting this behavior is not entirely trivial, as System+FC demands the variables go in universal-then-existential order under the hood.+Our solution is thus to equip DataCon with two different sets of type+variables:++* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential+  type/coercion variables, respectively. Their order is irrelevant for the+  purposes of TypeApplications, and as a consequence, they do not come equipped+  with visibilities (that is, they are TyVars/TyCoVars instead of+  TyCoVarBinders).+* dcUserTyVarBinders, for the type variables binders in the order in which they+  originally arose in the user-written type signature. Their order *does* matter+  for TypeApplications, so they are full TyVarBinders, complete with+  visibilities.++This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders+consists precisely of:++* The set of tyvars in dcUnivTyVars whose type variables do not appear in+  dcEqSpec, unioned with:+* The set of tyvars (*not* covars) in dcExTyCoVars+  No covars here because because they're not user-written++The word "set" is used above because the order in which the tyvars appear in+dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or+dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of+(tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the+ordering, they in fact share the same type variables (with the same Uniques). We+sometimes refer to this as "the dcUserTyVarBinders invariant".++dcUserTyVarBinders, as the name suggests, is the one that users will see most of+the time. It's used when computing the type signature of a data constructor (see+dataConUserType), and as a result, it's what matters from a TypeApplications+perspective.+-}++-- | Data Constructor Representation+-- See Note [Data constructor workers and wrappers]+data DataConRep+  = -- NoDataConRep means that the data con has no wrapper+    NoDataConRep++    -- DCR means that the data con has a wrapper+  | DCR { dcr_wrap_id :: Id   -- Takes src args, unboxes/flattens,+                              -- and constructs the representation++        , dcr_boxer   :: DataConBoxer++        , dcr_arg_tys :: [Type]  -- Final, representation argument types,+                                 -- after unboxing and flattening,+                                 -- and *including* all evidence args++        , dcr_stricts :: [StrictnessMark]  -- 1-1 with dcr_arg_tys+                -- See also Note [Data-con worker strictness] in GHC.Types.Id.Make++        , dcr_bangs :: [HsImplBang]  -- The actual decisions made (including failures)+                                     -- about the original arguments; 1-1 with orig_arg_tys+                                     -- See Note [Bangs on data constructor arguments]++    }++-------------------------++-- | Haskell Source Bang+--+-- Bangs on data constructor arguments as the user wrote them in the+-- source code.+--+-- @(HsSrcBang _ SrcUnpack SrcLazy)@ and+-- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we+-- emit a warning (in checkValidDataCon) and treat it like+-- @(HsSrcBang _ NoSrcUnpack SrcLazy)@+data HsSrcBang =+  HsSrcBang SourceText -- Note [Pragma source text] in GHC.Types.Basic+            SrcUnpackedness+            SrcStrictness+  deriving Data.Data++-- | Haskell Implementation Bang+--+-- Bangs of data constructor arguments as generated by the compiler+-- after consulting HsSrcBang, flags, etc.+data HsImplBang+  = HsLazy    -- ^ Lazy field, or one with an unlifted type+  | HsStrict  -- ^ Strict but not unpacked field+  | HsUnpack (Maybe Coercion)+    -- ^ Strict and unpacked field+    -- co :: arg-ty ~ product-ty HsBang+  deriving Data.Data++-- | Source Strictness+--+-- What strictness annotation the user wrote+data SrcStrictness = SrcLazy -- ^ Lazy, ie '~'+                   | SrcStrict -- ^ Strict, ie '!'+                   | NoSrcStrict -- ^ no strictness annotation+     deriving (Eq, Data.Data)++-- | Source Unpackedness+--+-- What unpackedness the user requested+data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified+                     | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified+                     | NoSrcUnpack -- ^ no unpack pragma+     deriving (Eq, Data.Data)++++-------------------------+-- StrictnessMark is internal only, used to indicate strictness+-- of the DataCon *worker* fields+data StrictnessMark = MarkedStrict | NotMarkedStrict++-- | An 'EqSpec' is a tyvar/type pair representing an equality made in+-- rejigging a GADT constructor+data EqSpec = EqSpec TyVar+                     Type++-- | Make a non-dependent 'EqSpec'+mkEqSpec :: TyVar -> Type -> EqSpec+mkEqSpec tv ty = EqSpec tv ty++eqSpecTyVar :: EqSpec -> TyVar+eqSpecTyVar (EqSpec tv _) = tv++eqSpecType :: EqSpec -> Type+eqSpecType (EqSpec _ ty) = ty++eqSpecPair :: EqSpec -> (TyVar, Type)+eqSpecPair (EqSpec tv ty) = (tv, ty)++eqSpecPreds :: [EqSpec] -> ThetaType+eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty+                   | EqSpec tv ty <- spec ]++-- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec+-- is mapped in the substitution, it is mapped to a type variable, not+-- a full type.+substEqSpec :: TCvSubst -> EqSpec -> EqSpec+substEqSpec subst (EqSpec tv ty)+  = EqSpec tv' (substTy subst ty)+  where+    tv' = getTyVar "substEqSpec" (substTyVar subst tv)++-- | Filter out any 'TyVar's mentioned in an 'EqSpec'.+filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar]+filterEqSpec eq_spec+  = filter not_in_eq_spec+  where+    not_in_eq_spec var = all (not . (== var) . eqSpecTyVar) eq_spec++instance Outputable EqSpec where+  ppr (EqSpec tv ty) = ppr (tv, ty)++{- Note [Bangs on data constructor arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data T = MkT !Int {-# UNPACK #-} !Int Bool++When compiling the module, GHC will decide how to represent+MkT, depending on the optimisation level, and settings of+flags like -funbox-small-strict-fields.++Terminology:+  * HsSrcBang:  What the user wrote+                Constructors: HsSrcBang++  * HsImplBang: What GHC decided+                Constructors: HsLazy, HsStrict, HsUnpack++* If T was defined in this module, MkT's dcSrcBangs field+  records the [HsSrcBang] of what the user wrote; in the example+    [ HsSrcBang _ NoSrcUnpack SrcStrict+    , HsSrcBang _ SrcUnpack SrcStrict+    , HsSrcBang _ NoSrcUnpack NoSrcStrictness]++* However, if T was defined in an imported module, the importing module+  must follow the decisions made in the original module, regardless of+  the flag settings in the importing module.+  Also see Note [Bangs on imported data constructors] in GHC.Types.Id.Make++* The dcr_bangs field of the dcRep field records the [HsImplBang]+  If T was defined in this module, Without -O the dcr_bangs might be+    [HsStrict, HsStrict, HsLazy]+  With -O it might be+    [HsStrict, HsUnpack _, HsLazy]+  With -funbox-small-strict-fields it might be+    [HsUnpack, HsUnpack _, HsLazy]+  With -XStrictData it might be+    [HsStrict, HsUnpack _, HsStrict]++Note [Data con representation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The dcRepType field contains the type of the representation of a constructor+This may differ from the type of the constructor *Id* (built+by MkId.mkDataConId) for two reasons:+        a) the constructor Id may be overloaded, but the dictionary isn't stored+           e.g.    data Eq a => T a = MkT a a++        b) the constructor may store an unboxed version of a strict field.++Here's an example illustrating both:+        data Ord a => T a = MkT Int! a+Here+        T :: Ord a => Int -> a -> T a+but the rep type is+        Trep :: Int# -> a -> T a+Actually, the unboxed part isn't implemented yet!++++************************************************************************+*                                                                      *+\subsection{Instances}+*                                                                      *+************************************************************************+-}++instance Eq DataCon where+    a == b = getUnique a == getUnique b+    a /= b = getUnique a /= getUnique b++instance Uniquable DataCon where+    getUnique = dcUnique++instance NamedThing DataCon where+    getName = dcName++instance Outputable DataCon where+    ppr con = ppr (dataConName con)++instance OutputableBndr DataCon where+    pprInfixOcc con = pprInfixName (dataConName con)+    pprPrefixOcc con = pprPrefixName (dataConName con)++instance Data.Data DataCon where+    -- don't traverse?+    toConstr _   = abstractConstr "DataCon"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "DataCon"++instance Outputable HsSrcBang where+    ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark++instance Outputable HsImplBang where+    ppr HsLazy                  = text "Lazy"+    ppr (HsUnpack Nothing)      = text "Unpacked"+    ppr (HsUnpack (Just co))    = text "Unpacked" <> parens (ppr co)+    ppr HsStrict                = text "StrictNotUnpacked"++instance Outputable SrcStrictness where+    ppr SrcLazy     = char '~'+    ppr SrcStrict   = char '!'+    ppr NoSrcStrict = empty++instance Outputable SrcUnpackedness where+    ppr SrcUnpack   = text "{-# UNPACK #-}"+    ppr SrcNoUnpack = text "{-# NOUNPACK #-}"+    ppr NoSrcUnpack = empty++instance Outputable StrictnessMark where+    ppr MarkedStrict    = text "!"+    ppr NotMarkedStrict = empty++instance Binary SrcStrictness where+    put_ bh SrcLazy     = putByte bh 0+    put_ bh SrcStrict   = putByte bh 1+    put_ bh NoSrcStrict = putByte bh 2++    get bh =+      do h <- getByte bh+         case h of+           0 -> return SrcLazy+           1 -> return SrcStrict+           _ -> return NoSrcStrict++instance Binary SrcUnpackedness where+    put_ bh SrcNoUnpack = putByte bh 0+    put_ bh SrcUnpack   = putByte bh 1+    put_ bh NoSrcUnpack = putByte bh 2++    get bh =+      do h <- getByte bh+         case h of+           0 -> return SrcNoUnpack+           1 -> return SrcUnpack+           _ -> return NoSrcUnpack++-- | Compare strictness annotations+eqHsBang :: HsImplBang -> HsImplBang -> Bool+eqHsBang HsLazy               HsLazy              = True+eqHsBang HsStrict             HsStrict            = True+eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)  = True+eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2))+  = eqType (coercionType c1) (coercionType c2)+eqHsBang _ _                                       = False++isBanged :: HsImplBang -> Bool+isBanged (HsUnpack {}) = True+isBanged (HsStrict {}) = True+isBanged HsLazy        = False++isSrcStrict :: SrcStrictness -> Bool+isSrcStrict SrcStrict = True+isSrcStrict _ = False++isSrcUnpacked :: SrcUnpackedness -> Bool+isSrcUnpacked SrcUnpack = True+isSrcUnpacked _ = False++isMarkedStrict :: StrictnessMark -> Bool+isMarkedStrict NotMarkedStrict = False+isMarkedStrict _               = True   -- All others are strict++{- *********************************************************************+*                                                                      *+\subsection{Construction}+*                                                                      *+********************************************************************* -}++-- | Build a new data constructor+mkDataCon :: Name+          -> Bool           -- ^ Is the constructor declared infix?+          -> TyConRepName   -- ^  TyConRepName for the promoted TyCon+          -> [HsSrcBang]    -- ^ Strictness/unpack annotations, from user+          -> [FieldLabel]   -- ^ Field labels for the constructor,+                            -- if it is a record, otherwise empty+          -> [TyVar]        -- ^ Universals.+          -> [TyCoVar]      -- ^ Existentials.+          -> [TyVarBinder]  -- ^ User-written 'TyVarBinder's.+                            --   These must be Inferred/Specified.+                            --   See @Note [TyVarBinders in DataCons]@+          -> [EqSpec]       -- ^ GADT equalities+          -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper+          -> [KnotTied Type]    -- ^ Original argument types+          -> KnotTied Type      -- ^ Original result type+          -> RuntimeRepInfo     -- ^ See comments on 'TyCon.RuntimeRepInfo'+          -> KnotTied TyCon     -- ^ Representation type constructor+          -> ConTag             -- ^ Constructor tag+          -> ThetaType          -- ^ The "stupid theta", context of the data+                                -- declaration e.g. @data Eq a => T a ...@+          -> Id                 -- ^ Worker Id+          -> DataConRep         -- ^ Representation+          -> DataCon+  -- Can get the tag from the TyCon++mkDataCon name declared_infix prom_info+          arg_stricts   -- Must match orig_arg_tys 1-1+          fields+          univ_tvs ex_tvs user_tvbs+          eq_spec theta+          orig_arg_tys orig_res_ty rep_info rep_tycon tag+          stupid_theta work_id rep+-- Warning: mkDataCon is not a good place to check certain invariants.+-- If the programmer writes the wrong result type in the decl, thus:+--      data T a where { MkT :: S }+-- then it's possible that the univ_tvs may hit an assertion failure+-- if you pull on univ_tvs.  This case is checked by checkValidDataCon,+-- so the error is detected properly... it's just that assertions here+-- are a little dodgy.++  = con+  where+    is_vanilla = null ex_tvs && null eq_spec && null theta++    con = MkData {dcName = name, dcUnique = nameUnique name,+                  dcVanilla = is_vanilla, dcInfix = declared_infix,+                  dcUnivTyVars = univ_tvs,+                  dcExTyCoVars = ex_tvs,+                  dcUserTyVarBinders = user_tvbs,+                  dcEqSpec = eq_spec,+                  dcOtherTheta = theta,+                  dcStupidTheta = stupid_theta,+                  dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,+                  dcRepTyCon = rep_tycon,+                  dcSrcBangs = arg_stricts,+                  dcFields = fields, dcTag = tag, dcRepType = rep_ty,+                  dcWorkId = work_id,+                  dcRep = rep,+                  dcSourceArity = length orig_arg_tys,+                  dcRepArity = length rep_arg_tys + count isCoVar ex_tvs,+                  dcPromoted = promoted }++        -- The 'arg_stricts' passed to mkDataCon are simply those for the+        -- source-language arguments.  We add extra ones for the+        -- dictionary arguments right here.++    rep_arg_tys = dataConRepArgTys con++    rep_ty =+      case rep of+        -- If the DataCon has no wrapper, then the worker's type *is* the+        -- user-facing type, so we can simply use dataConUserType.+        NoDataConRep -> dataConUserType con+        -- If the DataCon has a wrapper, then the worker's type is never seen+        -- by the user. The visibilities we pick do not matter here.+        DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $+                 mkVisFunTys rep_arg_tys $+                 mkTyConApp rep_tycon (mkTyVarTys univ_tvs)++      -- See Note [Promoted data constructors] in GHC.Core.TyCon+    prom_tv_bndrs = [ mkNamedTyConBinder vis tv+                    | Bndr tv vis <- user_tvbs ]++    fresh_names = freshNames (map getName user_tvbs)+      -- fresh_names: make sure that the "anonymous" tyvars don't+      -- clash in name or unique with the universal/existential ones.+      -- Tiresome!  And unnecessary because these tyvars are never looked at+    prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t)+     {- Invisible -}   | (n,t) <- fresh_names `zip` theta ]+    prom_arg_bndrs   = [ mkAnonTyConBinder VisArg (mkTyVar n t)+     {- Visible -}     | (n,t) <- dropList theta fresh_names `zip` orig_arg_tys ]+    prom_bndrs       = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs+    prom_res_kind    = orig_res_ty+    promoted         = mkPromotedDataCon con name prom_info prom_bndrs+                                         prom_res_kind roles rep_info++    roles = map (\tv -> if isTyVar tv then Nominal else Phantom)+                (univ_tvs ++ ex_tvs)+            ++ map (const Representational) (theta ++ orig_arg_tys)++freshNames :: [Name] -> [Name]+-- Make an infinite list of Names whose Uniques and OccNames+-- differ from those in the 'avoid' list+freshNames avoids+  = [ mkSystemName uniq occ+    | n <- [0..]+    , let uniq = mkAlphaTyVarUnique n+          occ = mkTyVarOccFS (mkFastString ('x' : show n))++    , not (uniq `elementOfUniqSet` avoid_uniqs)+    , not (occ `elemOccSet` avoid_occs) ]++  where+    avoid_uniqs :: UniqSet Unique+    avoid_uniqs = mkUniqSet (map getUnique avoids)++    avoid_occs :: OccSet+    avoid_occs = mkOccSet (map getOccName avoids)++-- | The 'Name' of the 'DataCon', giving it a unique, rooted identification+dataConName :: DataCon -> Name+dataConName = dcName++-- | The tag used for ordering 'DataCon's+dataConTag :: DataCon -> ConTag+dataConTag  = dcTag++dataConTagZ :: DataCon -> ConTagZ+dataConTagZ con = dataConTag con - fIRST_TAG++-- | The type constructor that we are building via this data constructor+dataConTyCon :: DataCon -> TyCon+dataConTyCon = dcRepTyCon++-- | The original type constructor used in the definition of this data+-- constructor.  In case of a data family instance, that will be the family+-- type constructor.+dataConOrigTyCon :: DataCon -> TyCon+dataConOrigTyCon dc+  | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc+  | otherwise                                          = dcRepTyCon dc++-- | The representation type of the data constructor, i.e. the sort+-- type that will represent values of this type at runtime+dataConRepType :: DataCon -> Type+dataConRepType = dcRepType++-- | Should the 'DataCon' be presented infix?+dataConIsInfix :: DataCon -> Bool+dataConIsInfix = dcInfix++-- | The universally-quantified type variables of the constructor+dataConUnivTyVars :: DataCon -> [TyVar]+dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = tvbs++-- | The existentially-quantified type/coercion variables of the constructor+-- including dependent (kind-) GADT equalities+dataConExTyCoVars :: DataCon -> [TyCoVar]+dataConExTyCoVars (MkData { dcExTyCoVars = tvbs }) = tvbs++-- | Both the universal and existential type/coercion variables of the constructor+dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar]+dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs })+  = univ_tvs ++ ex_tvs++-- See Note [DataCon user type variable binders]+-- | The type variables of the constructor, in the order the user wrote them+dataConUserTyVars :: DataCon -> [TyVar]+dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs++-- See Note [DataCon user type variable binders]+-- | 'TyCoVarBinder's for the type variables of the constructor, in the order the+-- user wrote them+dataConUserTyVarBinders :: DataCon -> [TyVarBinder]+dataConUserTyVarBinders = dcUserTyVarBinders++-- | Equalities derived from the result type of the data constructor, as written+-- by the programmer in any GADT declaration. This includes *all* GADT-like+-- equalities, including those written in by hand by the programmer.+dataConEqSpec :: DataCon -> [EqSpec]+dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })+  = dataConKindEqSpec con+    ++ eq_spec +++    [ spec   -- heterogeneous equality+    | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta+    , tc `hasKey` heqTyConKey+    , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of+                    (Just tv1, _) -> [mkEqSpec tv1 ty2]+                    (_, Just tv2) -> [mkEqSpec tv2 ty1]+                    _             -> []+    ] +++    [ spec   -- homogeneous equality+    | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta+    , tc `hasKey` eqTyConKey+    , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of+                    (Just tv1, _) -> [mkEqSpec tv1 ty2]+                    (_, Just tv2) -> [mkEqSpec tv2 ty1]+                    _             -> []+    ]++-- | Dependent (kind-level) equalities in a constructor.+-- There are extracted from the existential variables.+-- See Note [Existential coercion variables]+dataConKindEqSpec :: DataCon -> [EqSpec]+dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs})+  -- It is used in 'dataConEqSpec' (maybe also 'dataConFullSig' in the future),+  -- which are frequently used functions.+  -- For now (Aug 2018) this function always return empty set as we don't really+  -- have coercion variables.+  -- In the future when we do, we might want to cache this information in DataCon+  -- so it won't be computed every time when aforementioned functions are called.+  = [ EqSpec tv ty+    | cv <- ex_tcvs+    , isCoVar cv+    , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv+          tv = getTyVar "dataConKindEqSpec" ty1+    ]++-- | The *full* constraints on the constructor type, including dependent GADT+-- equalities.+dataConTheta :: DataCon -> ThetaType+dataConTheta con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })+  = eqSpecPreds (dataConKindEqSpec con ++ eq_spec) ++ theta++-- | Get the Id of the 'DataCon' worker: a function that is the "actual"+-- constructor and has no top level binding in the program. The type may+-- be different from the obvious one written in the source program. Panics+-- if there is no such 'Id' for this 'DataCon'+dataConWorkId :: DataCon -> Id+dataConWorkId dc = dcWorkId dc++-- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual"+-- constructor so it has the type visible in the source program: c.f.+-- 'dataConWorkId'.+-- Returns Nothing if there is no wrapper, which occurs for an algebraic data+-- constructor and also for a newtype (whose constructor is inlined+-- compulsorily)+dataConWrapId_maybe :: DataCon -> Maybe Id+dataConWrapId_maybe dc = case dcRep dc of+                           NoDataConRep -> Nothing+                           DCR { dcr_wrap_id = wrap_id } -> Just wrap_id++-- | Returns an Id which looks like the Haskell-source constructor by using+-- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to+-- the worker (see 'dataConWorkId')+dataConWrapId :: DataCon -> Id+dataConWrapId dc = case dcRep dc of+                     NoDataConRep-> dcWorkId dc    -- worker=wrapper+                     DCR { dcr_wrap_id = wrap_id } -> wrap_id++-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently,+-- the union of the 'dataConWorkId' and the 'dataConWrapId'+dataConImplicitTyThings :: DataCon -> [TyThing]+dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep })+  = [AnId work] ++ wrap_ids+  where+    wrap_ids = case rep of+                 NoDataConRep               -> []+                 DCR { dcr_wrap_id = wrap } -> [AnId wrap]++-- | The labels for the fields of this particular 'DataCon'+dataConFieldLabels :: DataCon -> [FieldLabel]+dataConFieldLabels = dcFields++-- | Extract the type for any given labelled field of the 'DataCon'+dataConFieldType :: DataCon -> FieldLabelString -> Type+dataConFieldType con label = case dataConFieldType_maybe con label of+      Just (_, ty) -> ty+      Nothing      -> pprPanic "dataConFieldType" (ppr con <+> ppr label)++-- | Extract the label and type for any given labelled field of the+-- 'DataCon', or return 'Nothing' if the field does not belong to it+dataConFieldType_maybe :: DataCon -> FieldLabelString+                       -> Maybe (FieldLabel, Type)+dataConFieldType_maybe con label+  = find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con)++-- | Strictness/unpack annotations, from user; or, for imported+-- DataCons, from the interface file+-- The list is in one-to-one correspondence with the arity of the 'DataCon'++dataConSrcBangs :: DataCon -> [HsSrcBang]+dataConSrcBangs = dcSrcBangs++-- | Source-level arity of the data constructor+dataConSourceArity :: DataCon -> Arity+dataConSourceArity (MkData { dcSourceArity = arity }) = arity++-- | Gives the number of actual fields in the /representation/ of the+-- data constructor. This may be more than appear in the source code;+-- the extra ones are the existentially quantified dictionaries+dataConRepArity :: DataCon -> Arity+dataConRepArity (MkData { dcRepArity = arity }) = arity++-- | Return whether there are any argument types for this 'DataCon's original source type+-- See Note [DataCon arities]+isNullarySrcDataCon :: DataCon -> Bool+isNullarySrcDataCon dc = dataConSourceArity dc == 0++-- | Return whether there are any argument types for this 'DataCon's runtime representation type+-- See Note [DataCon arities]+isNullaryRepDataCon :: DataCon -> Bool+isNullaryRepDataCon dc = dataConRepArity dc == 0++dataConRepStrictness :: DataCon -> [StrictnessMark]+-- ^ Give the demands on the arguments of a+-- Core constructor application (Con dc args)+dataConRepStrictness dc = case dcRep dc of+                            NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc]+                            DCR { dcr_stricts = strs } -> strs++dataConImplBangs :: DataCon -> [HsImplBang]+-- The implementation decisions about the strictness/unpack of each+-- source program argument to the data constructor+dataConImplBangs dc+  = case dcRep dc of+      NoDataConRep              -> replicate (dcSourceArity dc) HsLazy+      DCR { dcr_bangs = bangs } -> bangs++dataConBoxer :: DataCon -> Maybe DataConBoxer+dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer+dataConBoxer _ = Nothing++dataConInstSig+  :: DataCon+  -> [Type]    -- Instantiate the *universal* tyvars with these types+  -> ([TyCoVar], ThetaType, [Type])  -- Return instantiated existentials+                                     -- theta and arg tys+-- ^ Instantiate the universal tyvars of a data con,+--   returning+--     ( instantiated existentials+--     , instantiated constraints including dependent GADT equalities+--         which are *also* listed in the instantiated existentials+--     , instantiated args)+dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs+                           , dcOrigArgTys = arg_tys })+               univ_tys+  = ( ex_tvs'+    , substTheta subst (dataConTheta con)+    , substTys   subst arg_tys)+  where+    univ_subst = zipTvSubst univ_tvs univ_tys+    (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs+++-- | The \"full signature\" of the 'DataCon' returns, in order:+--+-- 1) The result of 'dataConUnivTyVars'+--+-- 2) The result of 'dataConExTyCoVars'+--+-- 3) The non-dependent GADT equalities.+--    Dependent GADT equalities are implied by coercion variables in+--    return value (2).+--+-- 4) The other constraints of the data constructor type, excluding GADT+-- equalities+--+-- 5) The original argument types to the 'DataCon' (i.e. before+--    any change of the representation of the type)+--+-- 6) The original result type of the 'DataCon'+dataConFullSig :: DataCon+               -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type)+dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs,+                        dcEqSpec = eq_spec, dcOtherTheta = theta,+                        dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})+  = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)++dataConOrigResTy :: DataCon -> Type+dataConOrigResTy dc = dcOrigResTy dc++-- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in:+--+-- > data Eq a => T a = ...+dataConStupidTheta :: DataCon -> ThetaType+dataConStupidTheta dc = dcStupidTheta dc++dataConUserType :: DataCon -> Type+-- ^ The user-declared type of the data constructor+-- in the nice-to-read form:+--+-- > T :: forall a b. a -> b -> T [a]+--+-- rather than:+--+-- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c+--+-- The type variables are quantified in the order that the user wrote them.+-- See @Note [DataCon user type variable binders]@.+--+-- NB: If the constructor is part of a data instance, the result type+-- mentions the family tycon, not the internal one.+dataConUserType (MkData { dcUserTyVarBinders = user_tvbs,+                          dcOtherTheta = theta, dcOrigArgTys = arg_tys,+                          dcOrigResTy = res_ty })+  = mkForAllTys user_tvbs $+    mkInvisFunTys theta $+    mkVisFunTys arg_tys $+    res_ty++-- | Finds the instantiated types of the arguments required to construct a+-- 'DataCon' representation+-- NB: these INCLUDE any dictionary args+--     but EXCLUDE the data-declaration context, which is discarded+-- It's all post-flattening etc; this is a representation type+dataConInstArgTys :: DataCon    -- ^ A datacon with no existentials or equality constraints+                                -- However, it can have a dcTheta (notably it can be a+                                -- class dictionary, with superclasses)+                  -> [Type]     -- ^ Instantiated at these types+                  -> [Type]+dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs,+                              dcExTyCoVars = ex_tvs}) inst_tys+ = ASSERT2( univ_tvs `equalLength` inst_tys+          , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)+   ASSERT2( null ex_tvs, ppr dc )+   map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc)++-- | Returns just the instantiated /value/ argument types of a 'DataCon',+-- (excluding dictionary args)+dataConInstOrigArgTys+        :: DataCon      -- Works for any DataCon+        -> [Type]       -- Includes existential tyvar args, but NOT+                        -- equality constraints or dicts+        -> [Type]+-- For vanilla datacons, it's all quite straightforward+-- But for the call in GHC.HsToCore.Match.Constructor, we really do want just+-- the value args+dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,+                                  dcUnivTyVars = univ_tvs,+                                  dcExTyCoVars = ex_tvs}) inst_tys+  = ASSERT2( tyvars `equalLength` inst_tys+           , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )+    map (substTy subst) arg_tys+  where+    tyvars = univ_tvs ++ ex_tvs+    subst  = zipTCvSubst tyvars inst_tys++-- | Returns the argument types of the wrapper, excluding all dictionary arguments+-- and without substituting for any type variables+dataConOrigArgTys :: DataCon -> [Type]+dataConOrigArgTys dc = dcOrigArgTys dc++-- | Returns the arg types of the worker, including *all* non-dependent+-- evidence, after any flattening has been done and without substituting for+-- any type variables+dataConRepArgTys :: DataCon -> [Type]+dataConRepArgTys (MkData { dcRep = rep+                         , dcEqSpec = eq_spec+                         , dcOtherTheta = theta+                         , dcOrigArgTys = orig_arg_tys })+  = case rep of+      NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys+      DCR { dcr_arg_tys = arg_tys } -> arg_tys++-- | The string @package:module.name@ identifying a constructor, which is attached+-- to its info table and used by the GHCi debugger and the heap profiler+dataConIdentity :: DataCon -> ByteString+-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings.+dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat+   [ BSB.byteString $ bytesFS (unitIdFS (moduleUnitId mod))+   , BSB.int8 $ fromIntegral (ord ':')+   , BSB.byteString $ bytesFS (moduleNameFS (moduleName mod))+   , BSB.int8 $ fromIntegral (ord '.')+   , BSB.byteString $ bytesFS (occNameFS (nameOccName name))+   ]+  where name = dataConName dc+        mod  = ASSERT( isExternalName name ) nameModule name++isTupleDataCon :: DataCon -> Bool+isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc++isUnboxedTupleCon :: DataCon -> Bool+isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc++isUnboxedSumCon :: DataCon -> Bool+isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc++-- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors+isVanillaDataCon :: DataCon -> Bool+isVanillaDataCon dc = dcVanilla dc++-- | Should this DataCon be allowed in a type even without -XDataKinds?+-- Currently, only Lifted & Unlifted+specialPromotedDc :: DataCon -> Bool+specialPromotedDc = isKindTyCon . dataConTyCon++classDataCon :: Class -> DataCon+classDataCon clas = case tyConDataCons (classTyCon clas) of+                      (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr+                      [] -> panic "classDataCon"++dataConCannotMatch :: [Type] -> DataCon -> Bool+-- Returns True iff the data con *definitely cannot* match a+--                  scrutinee of type (T tys)+--                  where T is the dcRepTyCon for the data con+dataConCannotMatch tys con+  -- See (U6) in Note [Implementing unsafeCoerce]+  -- in base:Unsafe.Coerce+  | dataConName con == unsafeReflDataConName+                      = False+  | null inst_theta   = False   -- Common+  | all isTyVarTy tys = False   -- Also common+  | otherwise         = typesCantMatch (concatMap predEqs inst_theta)+  where+    (_, inst_theta, _) = dataConInstSig con tys++    -- TODO: could gather equalities from superclasses too+    predEqs pred = case classifyPredType pred of+                     EqPred NomEq ty1 ty2         -> [(ty1, ty2)]+                     ClassPred eq args+                       | eq `hasKey` eqTyConKey+                       , [_, ty1, ty2] <- args    -> [(ty1, ty2)]+                       | eq `hasKey` heqTyConKey+                       , [_, _, ty1, ty2] <- args -> [(ty1, ty2)]+                     _                            -> []++-- | Were the type variables of the data con written in a different order+-- than the regular order (universal tyvars followed by existential tyvars)?+--+-- This is not a cheap test, so we minimize its use in GHC as much as possible.+-- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in+-- "MkId", and so 'dataConUserTyVarsArePermuted' is only called at most once+-- during a data constructor's lifetime.++-- See Note [DataCon user type variable binders], as well as+-- Note [Data con wrappers and GADT syntax] for an explanation of what+-- mkDataConRep is doing with this function.+dataConUserTyVarsArePermuted :: DataCon -> Bool+dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs+                                     , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec+                                     , dcUserTyVarBinders = user_tvbs }) =+  (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs++{-+%************************************************************************+%*                                                                      *+        Promoting of data types to the kind level+*                                                                      *+************************************************************************++-}++promoteDataCon :: DataCon -> TyCon+promoteDataCon (MkData { dcPromoted = tc }) = tc++{-+************************************************************************+*                                                                      *+\subsection{Splitting products}+*                                                                      *+************************************************************************+-}++-- | Extract the type constructor, type argument, data constructor and it's+-- /representation/ argument types from a type if it is a product type.+--+-- Precisely, we return @Just@ for any type that is all of:+--+--  * Concrete (i.e. constructors visible)+--+--  * Single-constructor+--+--  * Not existentially quantified+--+-- Whether the type is a @data@ type or a @newtype@+splitDataProductType_maybe+        :: Type                         -- ^ A product type, perhaps+        -> Maybe (TyCon,                -- The type constructor+                  [Type],               -- Type args of the tycon+                  DataCon,              -- The data constructor+                  [Type])               -- Its /representation/ arg types++        -- Rejecting existentials is conservative.  Maybe some things+        -- could be made to work with them, but I'm not going to sweat+        -- it through till someone finds it's important.++splitDataProductType_maybe ty+  | Just (tycon, ty_args) <- splitTyConApp_maybe ty+  , Just con <- isDataProductTyCon_maybe tycon+  = Just (tycon, ty_args, con, dataConInstArgTys con ty_args)+  | otherwise+  = Nothing+
+ compiler/GHC/Core/DataCon.hs-boot view
@@ -0,0 +1,34 @@+module GHC.Core.DataCon where++import GhcPrelude+import GHC.Types.Var( TyVar, TyCoVar, TyVarBinder )+import GHC.Types.Name( Name, NamedThing )+import {-# SOURCE #-} GHC.Core.TyCon( TyCon )+import GHC.Types.FieldLabel ( FieldLabel )+import GHC.Types.Unique ( Uniquable )+import Outputable ( Outputable, OutputableBndr )+import GHC.Types.Basic (Arity)+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, ThetaType )++data DataCon+data DataConRep+data EqSpec++dataConName      :: DataCon -> Name+dataConTyCon     :: DataCon -> TyCon+dataConExTyCoVars :: DataCon -> [TyCoVar]+dataConUserTyVars :: DataCon -> [TyVar]+dataConUserTyVarBinders :: DataCon -> [TyVarBinder]+dataConSourceArity  :: DataCon -> Arity+dataConFieldLabels :: DataCon -> [FieldLabel]+dataConInstOrigArgTys  :: DataCon -> [Type] -> [Type]+dataConStupidTheta :: DataCon -> ThetaType+dataConFullSig :: DataCon+               -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type)+isUnboxedSumCon :: DataCon -> Bool++instance Eq DataCon+instance Uniquable DataCon+instance NamedThing DataCon+instance Outputable DataCon+instance OutputableBndr DataCon
compiler/GHC/Core/FVs.hs view
@@ -62,24 +62,24 @@ import GhcPrelude  import GHC.Core-import Id-import IdInfo-import NameSet-import UniqSet-import Unique (Uniquable (..))-import Name-import VarSet-import Var-import Type-import TyCoRep-import TyCoFVs-import TyCon-import CoAxiom-import FamInstEnv+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Name.Set+import GHC.Types.Unique.Set+import GHC.Types.Unique (Uniquable (..))+import GHC.Types.Name+import GHC.Types.Var.Set+import GHC.Types.Var+import GHC.Core.Type+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.FVs+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom+import GHC.Core.FamInstEnv import TysPrim( funTyConName ) import Maybes( orElse ) import Util-import BasicTypes( Activation )+import GHC.Types.Basic( Activation ) import Outputable import FV
+ compiler/GHC/Core/FamInstEnv.hs view
@@ -0,0 +1,1836 @@+-- (c) The University of Glasgow 2006+--+-- FamInstEnv: Type checked family instance declarations++{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections,+    DeriveFunctor #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.Core.FamInstEnv (+        FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS,+        famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon,+        pprFamInst, pprFamInsts,+        mkImportedFamInst,++        FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs,+        extendFamInstEnv, extendFamInstEnvList,+        famInstEnvElts, famInstEnvSize, familyInstances,++        -- * CoAxioms+        mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom,+        mkNewTypeCoAxiom,++        FamInstMatch(..),+        lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon,++        isDominatedBy, apartnessCheck,++        -- Injectivity+        InjectivityCheckResult(..),+        lookupFamInstEnvInjectivityConflicts, injectiveBranches,++        -- Normalisation+        topNormaliseType, topNormaliseType_maybe,+        normaliseType, normaliseTcApp, normaliseTcArgs,+        reduceTyFamApp_maybe,++        -- Flattening+        flattenTys+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Core.Unify+import GHC.Core.Type as Type+import GHC.Core.TyCo.Rep+import GHC.Core.TyCon+import GHC.Core.Coercion+import GHC.Core.Coercion.Axiom+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Name+import GHC.Types.Unique.DFM+import Outputable+import Maybes+import GHC.Core.Map+import GHC.Types.Unique+import Util+import GHC.Types.Var+import GHC.Types.SrcLoc+import FastString+import Control.Monad+import Data.List( mapAccumL )+import Data.Array( Array, assocs )++{-+************************************************************************+*                                                                      *+          Type checked family instance heads+*                                                                      *+************************************************************************++Note [FamInsts and CoAxioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* CoAxioms and FamInsts are just like+  DFunIds  and ClsInsts++* A CoAxiom is a System-FC thing: it can relate any two types++* A FamInst is a Haskell source-language thing, corresponding+  to a type/data family instance declaration.+    - The FamInst contains a CoAxiom, which is the evidence+      for the instance++    - The LHS of the CoAxiom is always of form F ty1 .. tyn+      where F is a type family+-}++data FamInst  -- See Note [FamInsts and CoAxioms]+  = FamInst { fi_axiom  :: CoAxiom Unbranched -- The new coercion axiom+                                              -- introduced by this family+                                              -- instance+                 -- INVARIANT: apart from freshening (see below)+                 --    fi_tvs = cab_tvs of the (single) axiom branch+                 --    fi_cvs = cab_cvs ...ditto...+                 --    fi_tys = cab_lhs ...ditto...+                 --    fi_rhs = cab_rhs ...ditto...++            , fi_flavor :: FamFlavor++            -- Everything below here is a redundant,+            -- cached version of the two things above+            -- except that the TyVars are freshened+            , fi_fam   :: Name          -- Family name++                -- Used for "rough matching"; same idea as for class instances+                -- See Note [Rough-match field] in GHC.Core.InstEnv+            , fi_tcs   :: [Maybe Name]  -- Top of type args+                -- INVARIANT: fi_tcs = roughMatchTcs fi_tys++            -- Used for "proper matching"; ditto+            , fi_tvs :: [TyVar]      -- Template tyvars for full match+            , fi_cvs :: [CoVar]      -- Template covars for full match+                 -- Like ClsInsts, these variables are always fresh+                 -- See Note [Template tyvars are fresh] in GHC.Core.InstEnv++            , fi_tys    :: [Type]       --   The LHS type patterns+            -- May be eta-reduced; see Note [Eta reduction for data families]++            , fi_rhs :: Type         --   the RHS, with its freshened vars+            }++data FamFlavor+  = SynFamilyInst         -- A synonym family+  | DataFamilyInst TyCon  -- A data family, with its representation TyCon++{-+Note [Arity of data families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Data family instances might legitimately be over- or under-saturated.++Under-saturation has two potential causes:+ U1) Eta reduction. See Note [Eta reduction for data families].+ U2) When the user has specified a return kind instead of written out patterns.+     Example:++       data family Sing (a :: k)+       data instance Sing :: Bool -> Type++     The data family tycon Sing has an arity of 2, the k and the a. But+     the data instance has only one pattern, Bool (standing in for k).+     This instance is equivalent to `data instance Sing (a :: Bool)`, but+     without the last pattern, we have an under-saturated data family instance.+     On its own, this example is not compelling enough to add support for+     under-saturation, but U1 makes this feature more compelling.++Over-saturation is also possible:+  O1) If the data family's return kind is a type variable (see also #12369),+      an instance might legitimately have more arguments than the family.+      Example:++        data family Fix :: (Type -> k) -> k+        data instance Fix f = MkFix1 (f (Fix f))+        data instance Fix f x = MkFix2 (f (Fix f x) x)++      In the first instance here, the k in the data family kind is chosen to+      be Type. In the second, it's (Type -> Type).++      However, we require that any over-saturation is eta-reducible. That is,+      we require that any extra patterns be bare unrepeated type variables;+      see Note [Eta reduction for data families]. Accordingly, the FamInst+      is never over-saturated.++Why can we allow such flexibility for data families but not for type families?+Because data families can be decomposed -- that is, they are generative and+injective. A Type family is neither and so always must be applied to all its+arguments.+-}++-- Obtain the axiom of a family instance+famInstAxiom :: FamInst -> CoAxiom Unbranched+famInstAxiom = fi_axiom++-- Split the left-hand side of the FamInst+famInstSplitLHS :: FamInst -> (TyCon, [Type])+famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs })+  = (coAxiomTyCon axiom, lhs)++-- Get the RHS of the FamInst+famInstRHS :: FamInst -> Type+famInstRHS = fi_rhs++-- Get the family TyCon of the FamInst+famInstTyCon :: FamInst -> TyCon+famInstTyCon = coAxiomTyCon . famInstAxiom++-- Return the representation TyCons introduced by data family instances, if any+famInstsRepTyCons :: [FamInst] -> [TyCon]+famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis]++-- Extracts the TyCon for this *data* (or newtype) instance+famInstRepTyCon_maybe :: FamInst -> Maybe TyCon+famInstRepTyCon_maybe fi+  = case fi_flavor fi of+       DataFamilyInst tycon -> Just tycon+       SynFamilyInst        -> Nothing++dataFamInstRepTyCon :: FamInst -> TyCon+dataFamInstRepTyCon fi+  = case fi_flavor fi of+       DataFamilyInst tycon -> tycon+       SynFamilyInst        -> pprPanic "dataFamInstRepTyCon" (ppr fi)++{-+************************************************************************+*                                                                      *+        Pretty printing+*                                                                      *+************************************************************************+-}++instance NamedThing FamInst where+   getName = coAxiomName . fi_axiom++instance Outputable FamInst where+   ppr = pprFamInst++pprFamInst :: FamInst -> SDoc+-- Prints the FamInst as a family instance declaration+-- NB: This function, FamInstEnv.pprFamInst, is used only for internal,+--     debug printing. See GHC.Core.Ppr.TyThing.pprFamInst for printing for the user+pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax+                    , fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs })+  = hang (ppr_tc_sort <+> text "instance"+             <+> pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax))+       2 (whenPprDebug debug_stuff)+  where+    ppr_tc_sort = case flavor of+                     SynFamilyInst             -> text "type"+                     DataFamilyInst tycon+                       | isDataTyCon     tycon -> text "data"+                       | isNewTyCon      tycon -> text "newtype"+                       | isAbstractTyCon tycon -> text "data"+                       | otherwise             -> text "WEIRD" <+> ppr tycon++    debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax+                       , text "Tvs:" <+> ppr tvs+                       , text "LHS:" <+> ppr tys+                       , text "RHS:" <+> ppr rhs ]++pprFamInsts :: [FamInst] -> SDoc+pprFamInsts finsts = vcat (map pprFamInst finsts)++{-+Note [Lazy axiom match]+~~~~~~~~~~~~~~~~~~~~~~~+It is Vitally Important that mkImportedFamInst is *lazy* in its axiom+parameter. The axiom is loaded lazily, via a forkM, in GHC.IfaceToCore. Sometime+later, mkImportedFamInst is called using that axiom. However, the axiom+may itself depend on entities which are not yet loaded as of the time+of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the+axiom, a dependency loop spontaneously appears and GHC hangs. The solution+is simply for mkImportedFamInst never, ever to look inside of the axiom+until everything else is good and ready to do so. We can assume that this+readiness has been achieved when some other code pulls on the axiom in the+FamInst. Thus, we pattern match on the axiom lazily (in the where clause,+not in the parameter list) and we assert the consistency of names there+also.+-}++-- Make a family instance representation from the information found in an+-- interface file.  In particular, we get the rough match info from the iface+-- (instead of computing it here).+mkImportedFamInst :: Name               -- Name of the family+                  -> [Maybe Name]       -- Rough match info+                  -> CoAxiom Unbranched -- Axiom introduced+                  -> FamInst            -- Resulting family instance+mkImportedFamInst fam mb_tcs axiom+  = FamInst {+      fi_fam    = fam,+      fi_tcs    = mb_tcs,+      fi_tvs    = tvs,+      fi_cvs    = cvs,+      fi_tys    = tys,+      fi_rhs    = rhs,+      fi_axiom  = axiom,+      fi_flavor = flavor }+  where+     -- See Note [Lazy axiom match]+     ~(CoAxBranch { cab_lhs = tys+                  , cab_tvs = tvs+                  , cab_cvs = cvs+                  , cab_rhs = rhs }) = coAxiomSingleBranch axiom++         -- Derive the flavor for an imported FamInst rather disgustingly+         -- Maybe we should store it in the IfaceFamInst?+     flavor = case splitTyConApp_maybe rhs of+                Just (tc, _)+                  | Just ax' <- tyConFamilyCoercion_maybe tc+                  , ax' == axiom+                  -> DataFamilyInst tc+                _ -> SynFamilyInst++{-+************************************************************************+*                                                                      *+                FamInstEnv+*                                                                      *+************************************************************************++Note [FamInstEnv]+~~~~~~~~~~~~~~~~~+A FamInstEnv maps a family name to the list of known instances for that family.++The same FamInstEnv includes both 'data family' and 'type family' instances.+Type families are reduced during type inference, but not data families;+the user explains when to use a data family instance by using constructors+and pattern matching.++Nevertheless it is still useful to have data families in the FamInstEnv:++ - For finding overlaps and conflicts++ - For finding the representation type...see FamInstEnv.topNormaliseType+   and its call site in GHC.Core.Op.Simplify++ - In standalone deriving instance Eq (T [Int]) we need to find the+   representation type for T [Int]++Note [Varying number of patterns for data family axioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For data families, the number of patterns may vary between instances.+For example+   data family T a b+   data instance T Int a = T1 a | T2+   data instance T Bool [a] = T3 a++Then we get a data type for each instance, and an axiom:+   data TInt a = T1 a | T2+   data TBoolList a = T3 a++   axiom ax7   :: T Int ~ TInt   -- Eta-reduced+   axiom ax8 a :: T Bool [a] ~ TBoolList a++These two axioms for T, one with one pattern, one with two;+see Note [Eta reduction for data families]++Note [FamInstEnv determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We turn FamInstEnvs into a list in some places that don't directly affect+the ABI. That happens in family consistency checks and when producing output+for `:info`. Unfortunately that nondeterminism is nonlocal and it's hard+to tell what it affects without following a chain of functions. It's also+easy to accidentally make that nondeterminism affect the ABI. Furthermore+the envs should be relatively small, so it should be free to use deterministic+maps here. Testing with nofib and validate detected no difference between+UniqFM and UniqDFM.+See Note [Deterministic UniqFM].+-}++type FamInstEnv = UniqDFM FamilyInstEnv  -- Maps a family to its instances+     -- See Note [FamInstEnv]+     -- See Note [FamInstEnv determinism]++type FamInstEnvs = (FamInstEnv, FamInstEnv)+     -- External package inst-env, Home-package inst-env++newtype FamilyInstEnv+  = FamIE [FamInst]     -- The instances for a particular family, in any order++instance Outputable FamilyInstEnv where+  ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs)++-- INVARIANTS:+--  * The fs_tvs are distinct in each FamInst+--      of a range value of the map (so we can safely unify them)++emptyFamInstEnvs :: (FamInstEnv, FamInstEnv)+emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv)++emptyFamInstEnv :: FamInstEnv+emptyFamInstEnv = emptyUDFM++famInstEnvElts :: FamInstEnv -> [FamInst]+famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts]+  -- See Note [FamInstEnv determinism]++famInstEnvSize :: FamInstEnv -> Int+famInstEnvSize = nonDetFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0+  -- It's OK to use nonDetFoldUDFM here since we're just computing the+  -- size.++familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]+familyInstances (pkg_fie, home_fie) fam+  = get home_fie ++ get pkg_fie+  where+    get env = case lookupUDFM env fam of+                Just (FamIE insts) -> insts+                Nothing                      -> []++extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv+extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis++extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv+extendFamInstEnv inst_env+                 ins_item@(FamInst {fi_fam = cls_nm})+  = addToUDFM_C add inst_env cls_nm (FamIE [ins_item])+  where+    add (FamIE items) _ = FamIE (ins_item:items)++{-+************************************************************************+*                                                                      *+                Compatibility+*                                                                      *+************************************************************************++Note [Apartness]+~~~~~~~~~~~~~~~~+In dealing with closed type families, we must be able to check that one type+will never reduce to another. This check is called /apartness/. The check+is always between a target (which may be an arbitrary type) and a pattern.+Here is how we do it:++apart(target, pattern) = not (unify(flatten(target), pattern))++where flatten (implemented in flattenTys, below) converts all type-family+applications into fresh variables. (See Note [Flattening].)++Note [Compatibility]+~~~~~~~~~~~~~~~~~~~~+Two patterns are /compatible/ if either of the following conditions hold:+1) The patterns are apart.+2) The patterns unify with a substitution S, and their right hand sides+equal under that substitution.++For open type families, only compatible instances are allowed. For closed+type families, the story is slightly more complicated. Consider the following:++type family F a where+  F Int = Bool+  F a   = Int++g :: Show a => a -> F a+g x = length (show x)++Should that type-check? No. We need to allow for the possibility that 'a'+might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int+only when we can be sure that 'a' is not Int.++To achieve this, after finding a possible match within the equations, we have to+go back to all previous equations and check that, under the+substitution induced by the match, other branches are surely apart. (See+Note [Apartness].) This is similar to what happens with class+instance selection, when we need to guarantee that there is only a match and+no unifiers. The exact algorithm is different here because the+potentially-overlapping group is closed.++As another example, consider this:++type family G x where+  G Int = Bool+  G a   = Double++type family H y+-- no instances++Now, we want to simplify (G (H Char)). We can't, because (H Char) might later+simplify to be Int. So, (G (H Char)) is stuck, for now.++While everything above is quite sound, it isn't as expressive as we'd like.+Consider this:++type family J a where+  J Int = Int+  J a   = a++Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if+b is instantiated with Int, but the RHSs coincide there, so it's all OK.++So, the rule is this: when looking up a branch in a closed type family, we+find a branch that matches the target, but then we make sure that the target+is apart from every previous *incompatible* branch. We don't check the+branches that are compatible with the matching branch, because they are either+irrelevant (clause 1 of compatible) or benign (clause 2 of compatible).++Note [Compatibility of eta-reduced axioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In newtype instances of data families we eta-reduce the axioms,+See Note [Eta reduction for data families] in GHC.Core.FamInstEnv. This means that+we sometimes need to test compatibility of two axioms that were eta-reduced to+different degrees, e.g.:+++data family D a b c+newtype instance D a Int c = DInt (Maybe a)+  -- D a Int ~ Maybe+  -- lhs = [a, Int]+newtype instance D Bool Int Char = DIntChar Float+  -- D Bool Int Char ~ Float+  -- lhs = [Bool, Int, Char]++These are obviously incompatible. We could detect this by saturating+(eta-expanding) the shorter LHS with fresh tyvars until the lists are of+equal length, but instead we can just remove the tail of the longer list, as+those types will simply unify with the freshly introduced tyvars.++By doing this, in case the LHS are unifiable, the yielded substitution won't+mention the tyvars that appear in the tail we dropped off, and we might try+to test equality RHSes of different kinds, but that's fine since this case+occurs only for data families, where the RHS is a unique tycon and the equality+fails anyway.+-}++-- See Note [Compatibility]+compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool+compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })+                   (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })+  = let (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2+             -- See Note [Compatibility of eta-reduced axioms]+    in case tcUnifyTysFG (const BindMe) commonlhs1 commonlhs2 of+      SurelyApart -> True+      Unifiable subst+        | Type.substTyAddInScope subst rhs1 `eqType`+          Type.substTyAddInScope subst rhs2+        -> True+      _ -> False++-- | Result of testing two type family equations for injectiviy.+data InjectivityCheckResult+   = InjectivityAccepted+    -- ^ Either RHSs are distinct or unification of RHSs leads to unification of+    -- LHSs+   | InjectivityUnified CoAxBranch CoAxBranch+    -- ^ RHSs unify but LHSs don't unify under that substitution.  Relevant for+    -- closed type families where equation after unification might be+    -- overlpapped (in which case it is OK if they don't unify).  Constructor+    -- stores axioms after unification.++-- | Check whether two type family axioms don't violate injectivity annotation.+injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch+                  -> InjectivityCheckResult+injectiveBranches injectivity+                  ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })+                  ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })+  -- See Note [Verifying injectivity annotation], case 1.+  = let getInjArgs  = filterByList injectivity+    in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification+       Nothing -> InjectivityAccepted+         -- RHS are different, so equations are injective.+         -- This is case 1A from Note [Verifying injectivity annotation]+       Just subst -> -- RHS unify under a substitution+        let lhs1Subst = Type.substTys subst (getInjArgs lhs1)+            lhs2Subst = Type.substTys subst (getInjArgs lhs2)+        -- If LHSs are equal under the substitution used for RHSs then this pair+        -- of equations does not violate injectivity annotation. If LHSs are not+        -- equal under that substitution then this pair of equations violates+        -- injectivity annotation, but for closed type families it still might+        -- be the case that one LHS after substitution is unreachable.+        in if eqTypes lhs1Subst lhs2Subst  -- check case 1B1 from Note.+           then InjectivityAccepted+           else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1+                                         , cab_rhs = Type.substTy  subst rhs1 })+                                   ( ax2 { cab_lhs = Type.substTys subst lhs2+                                         , cab_rhs = Type.substTy  subst rhs2 })+                -- payload of InjectivityUnified used only for check 1B2, only+                -- for closed type families++-- takes a CoAxiom with unknown branch incompatibilities and computes+-- the compatibilities+-- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom+computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch]+computeAxiomIncomps branches+  = snd (mapAccumL go [] branches)+  where+    go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch)+    go prev_brs cur_br+       = (cur_br : prev_brs, new_br)+       where+         new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br }++    mk_incomps :: [CoAxBranch] -> CoAxBranch -> [CoAxBranch]+    mk_incomps prev_brs cur_br+       = filter (not . compatibleBranches cur_br) prev_brs++{-+************************************************************************+*                                                                      *+           Constructing axioms+    These functions are here because tidyType / tcUnifyTysFG+    are not available in GHC.Core.Coercion.Axiom++    Also computeAxiomIncomps is too sophisticated for CoAxiom+*                                                                      *+************************************************************************++Note [Tidy axioms when we build them]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Like types and classes, we build axioms fully quantified over all+their variables, and tidy them when we build them. For example,+we print out axioms and don't want to print stuff like+    F k k a b = ...+Instead we must tidy those kind variables.  See #7524.++We could instead tidy when we print, but that makes it harder to get+things like injectivity errors to come out right. Danger of+     Type family equation violates injectivity annotation.+     Kind variable ‘k’ cannot be inferred from the right-hand side.+     In the type family equation:+        PolyKindVars @[k1] @[k2] ('[] @k1) = '[] @k2++Note [Always number wildcard types in CoAxBranch]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following example (from the DataFamilyInstanceLHS test case):++  data family Sing (a :: k)+  data instance Sing (_ :: MyKind) where+      SingA :: Sing A+      SingB :: Sing B++If we're not careful during tidying, then when this program is compiled with+-ddump-types, we'll get the following information:++  COERCION AXIOMS+    axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 ::+      Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _++It's misleading to have a wildcard type appearing on the RHS like+that. To avoid this issue, when building a CoAxiom (which is what eventually+gets printed above), we tidy all the variables in an env that already contains+'_'. Thus, any variable named '_' will be renamed, giving us the nicer output+here:++  COERCION AXIOMS+    axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 ::+      Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1++Which is at least legal syntax.++See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom; note that we+are tidying (changing OccNames only), not freshening, in accordance with+that Note.+-}++-- all axiom roles are Nominal, as this is only used with type families+mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars+             -> [TyVar] -- Extra eta tyvars+             -> [CoVar] -- possibly stale covars+             -> TyCon   -- family/newtype TyCon (for error-checking only)+             -> [Type]  -- LHS patterns+             -> Type    -- RHS+             -> [Role]+             -> SrcSpan+             -> CoAxBranch+mkCoAxBranch tvs eta_tvs cvs ax_tc lhs rhs roles loc+  = -- See Note [CoAxioms are homogeneous] in Core.Coercion.Axiom+    ASSERT( typeKind (mkTyConApp ax_tc lhs) `eqType` typeKind rhs )+    CoAxBranch { cab_tvs     = tvs'+               , cab_eta_tvs = eta_tvs'+               , cab_cvs     = cvs'+               , cab_lhs     = tidyTypes env lhs+               , cab_roles   = roles+               , cab_rhs     = tidyType env rhs+               , cab_loc     = loc+               , cab_incomps = placeHolderIncomps }+  where+    (env1, tvs')     = tidyVarBndrs init_tidy_env tvs+    (env2, eta_tvs') = tidyVarBndrs env1          eta_tvs+    (env,  cvs')     = tidyVarBndrs env2          cvs+    -- See Note [Tidy axioms when we build them]+    -- See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom++    init_occ_env = initTidyOccEnv [mkTyVarOcc "_"]+    init_tidy_env = mkEmptyTidyEnv init_occ_env+    -- See Note [Always number wildcard types in CoAxBranch]++-- all of the following code is here to avoid mutual dependencies with+-- Coercion+mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched+mkBranchedCoAxiom ax_name fam_tc branches+  = CoAxiom { co_ax_unique   = nameUnique ax_name+            , co_ax_name     = ax_name+            , co_ax_tc       = fam_tc+            , co_ax_role     = Nominal+            , co_ax_implicit = False+            , co_ax_branches = manyBranches (computeAxiomIncomps branches) }++mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched+mkUnbranchedCoAxiom ax_name fam_tc branch+  = CoAxiom { co_ax_unique   = nameUnique ax_name+            , co_ax_name     = ax_name+            , co_ax_tc       = fam_tc+            , co_ax_role     = Nominal+            , co_ax_implicit = False+            , co_ax_branches = unbranched (branch { cab_incomps = [] }) }++mkSingleCoAxiom :: Role -> Name+                -> [TyVar] -> [TyVar] -> [CoVar]+                -> TyCon -> [Type] -> Type+                -> CoAxiom Unbranched+-- Make a single-branch CoAxiom, including making the branch itself+-- Used for both type family (Nominal) and data family (Representational)+-- axioms, hence passing in the Role+mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty+  = CoAxiom { co_ax_unique   = nameUnique ax_name+            , co_ax_name     = ax_name+            , co_ax_tc       = fam_tc+            , co_ax_role     = role+            , co_ax_implicit = False+            , co_ax_branches = unbranched (branch { cab_incomps = [] }) }+  where+    branch = mkCoAxBranch tvs eta_tvs cvs fam_tc lhs_tys rhs_ty+                          (map (const Nominal) tvs)+                          (getSrcSpan ax_name)++-- | Create a coercion constructor (axiom) suitable for the given+--   newtype 'TyCon'. The 'Name' should be that of a new coercion+--   'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and+--   the type the appropriate right hand side of the @newtype@, with+--   the free variables a subset of those 'TyVar's.+mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched+mkNewTypeCoAxiom name tycon tvs roles rhs_ty+  = CoAxiom { co_ax_unique   = nameUnique name+            , co_ax_name     = name+            , co_ax_implicit = True  -- See Note [Implicit axioms] in GHC.Core.TyCon+            , co_ax_role     = Representational+            , co_ax_tc       = tycon+            , co_ax_branches = unbranched (branch { cab_incomps = [] }) }+  where+    branch = mkCoAxBranch tvs [] [] tycon (mkTyVarTys tvs) rhs_ty+                          roles (getSrcSpan name)++{-+************************************************************************+*                                                                      *+                Looking up a family instance+*                                                                      *+************************************************************************++@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.+Multiple matches are only possible in case of type families (not data+families), and then, it doesn't matter which match we choose (as the+instances are guaranteed confluent).++We return the matching family instances and the type instance at which it+matches.  For example, if we lookup 'T [Int]' and have a family instance++  data instance T [a] = ..++desugared to++  data :R42T a = ..+  coe :Co:R42T a :: T [a] ~ :R42T a++we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'.+-}++-- when matching a type family application, we get a FamInst,+-- and the list of types the axiom should be applied to+data FamInstMatch = FamInstMatch { fim_instance :: FamInst+                                 , fim_tys      :: [Type]+                                 , fim_cos      :: [Coercion]+                                 }+  -- See Note [Over-saturated matches]++instance Outputable FamInstMatch where+  ppr (FamInstMatch { fim_instance = inst+                    , fim_tys      = tys+                    , fim_cos      = cos })+    = text "match with" <+> parens (ppr inst) <+> ppr tys <+> ppr cos++lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst]+lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc+  = get pkg_ie ++ get home_ie+  where+    get ie = case lookupUDFM ie fam_tc of+               Nothing          -> []+               Just (FamIE fis) -> fis++lookupFamInstEnv+    :: FamInstEnvs+    -> TyCon -> [Type]          -- What we are looking for+    -> [FamInstMatch]           -- Successful matches+-- Precondition: the tycon is saturated (or over-saturated)++lookupFamInstEnv+   = lookup_fam_inst_env match+   where+     match _ _ tpl_tys tys = tcMatchTys tpl_tys tys++lookupFamInstEnvConflicts+    :: FamInstEnvs+    -> FamInst          -- Putative new instance+    -> [FamInstMatch]   -- Conflicting matches (don't look at the fim_tys field)+-- E.g. when we are about to add+--    f : type instance F [a] = a->a+-- we do (lookupFamInstConflicts f [b])+-- to find conflicting matches+--+-- Precondition: the tycon is saturated (or over-saturated)++lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom })+  = lookup_fam_inst_env my_unify envs fam tys+  where+    (fam, tys) = famInstSplitLHS fam_inst+        -- In example above,   fam tys' = F [b]++    my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _+       = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs,+                  (ppr fam <+> ppr tys) $$+                  (ppr tpl_tvs <+> ppr tpl_tys) )+                -- Unification will break badly if the variables overlap+                -- They shouldn't because we allocate separate uniques for them+         if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch+           then Nothing+           else Just noSubst+      -- Note [Family instance overlap conflicts]++    noSubst = panic "lookupFamInstEnvConflicts noSubst"+    new_branch = coAxiomSingleBranch new_axiom++--------------------------------------------------------------------------------+--                 Type family injectivity checking bits                      --+--------------------------------------------------------------------------------++{- Note [Verifying injectivity annotation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Injectivity means that the RHS of a type family uniquely determines the LHS (see+Note [Type inference for type families with injectivity]).  The user informs us about+injectivity using an injectivity annotation and it is GHC's task to verify that+this annotation is correct w.r.t. type family equations. Whenever we see a new+equation of a type family we need to make sure that adding this equation to the+already known equations of a type family does not violate the injectivity annotation+supplied by the user (see Note [Injectivity annotation]).  Of course if the type+family has no injectivity annotation then no check is required.  But if a type+family has injectivity annotation we need to make sure that the following+conditions hold:++1. For each pair of *different* equations of a type family, one of the following+   conditions holds:++   A:  RHSs are different. (Check done in GHC.Core.FamInstEnv.injectiveBranches)++   B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution+       then it must be possible to unify the LHSs under the same substitution.+       Example:++          type family FunnyId a = r | r -> a+          type instance FunnyId Int = Int+          type instance FunnyId a = a++       RHSs of these two equations unify under [ a |-> Int ] substitution.+       Under this substitution LHSs are equal therefore these equations don't+       violate injectivity annotation. (Check done in GHC.Core.FamInstEnv.injectiveBranches)++   B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some+       substitution then either the LHSs unify under the same substitution or+       the LHS of the latter equation is overlapped by earlier equations.+       Example 1:++          type family SwapIntChar a = r | r -> a where+              SwapIntChar Int  = Char+              SwapIntChar Char = Int+              SwapIntChar a    = a++       Say we are checking the last two equations. RHSs unify under [ a |->+       Int ] substitution but LHSs don't. So we apply the substitution to LHS+       of last equation and check whether it is overlapped by any of previous+       equations. Since it is overlapped by the first equation we conclude+       that pair of last two equations does not violate injectivity+       annotation. (Check done in TcValidity.checkValidCoAxiom#gather_conflicts)++   A special case of B is when RHSs unify with an empty substitution ie. they+   are identical.++   If any of the above two conditions holds we conclude that the pair of+   equations does not violate injectivity annotation. But if we find a pair+   of equations where neither of the above holds we report that this pair+   violates injectivity annotation because for a given RHS we don't have a+   unique LHS. (Note that (B) actually implies (A).)++   Note that we only take into account these LHS patterns that were declared+   as injective.++2. If an RHS of a type family equation is a bare type variable then+   all LHS variables (including implicit kind variables) also have to be bare.+   In other words, this has to be a sole equation of that type family and it has+   to cover all possible patterns.  So for example this definition will be+   rejected:++      type family W1 a = r | r -> a+      type instance W1 [a] = a++   If it were accepted we could call `W1 [W1 Int]`, which would reduce to+   `W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`,+   which is bogus. Checked FamInst.bareTvInRHSViolated.++3. If the RHS of a type family equation is a type family application then the type+   family is rejected as not injective. This is checked by FamInst.isTFHeaded.++4. If a LHS type variable that is declared as injective is not mentioned in an+   injective position in the RHS then the type family is rejected as not+   injective.  "Injective position" means either an argument to a type+   constructor or argument to a type family on injective position.+   There are subtleties here. See Note [Coverage condition for injective type families]+   in FamInst.++Check (1) must be done for all family instances (transitively) imported. Other+checks (2-4) should be done just for locally written equations, as they are checks+involving just a single equation, not about interactions. Doing the other checks for+imported equations led to #17405, as the behavior of check (4) depends on+-XUndecidableInstances (see Note [Coverage condition for injective type families] in+FamInst), which may vary between modules.++See also Note [Injective type families] in GHC.Core.TyCon+-}+++-- | Check whether an open type family equation can be added to already existing+-- instance environment without causing conflicts with supplied injectivity+-- annotations.  Returns list of conflicting axioms (type instance+-- declarations).+lookupFamInstEnvInjectivityConflicts+    :: [Bool]         -- injectivity annotation for this type family instance+                      -- INVARIANT: list contains at least one True value+    ->  FamInstEnvs   -- all type instances seens so far+    ->  FamInst       -- new type instance that we're checking+    -> [CoAxBranch]   -- conflicting instance declarations+lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie)+                             fam_inst@(FamInst { fi_axiom = new_axiom })+  -- See Note [Verifying injectivity annotation]. This function implements+  -- check (1.B1) for open type families described there.+  = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie+    where+      fam        = famInstTyCon fam_inst+      new_branch = coAxiomSingleBranch new_axiom++      -- filtering function used by `lookup_inj_fam_conflicts` to check whether+      -- a pair of equations conflicts with the injectivity annotation.+      isInjConflict (FamInst { fi_axiom = old_axiom })+          | InjectivityAccepted <-+            injectiveBranches injList (coAxiomSingleBranch old_axiom) new_branch+          = False -- no conflict+          | otherwise = True++      lookup_inj_fam_conflicts ie+          | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie fam+          = map (coAxiomSingleBranch . fi_axiom) $+            filter isInjConflict insts+          | otherwise = []+++--------------------------------------------------------------------------------+--                    Type family overlap checking bits                       --+--------------------------------------------------------------------------------++{-+Note [Family instance overlap conflicts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+- In the case of data family instances, any overlap is fundamentally a+  conflict (as these instances imply injective type mappings).++- In the case of type family instances, overlap is admitted as long as+  the right-hand sides of the overlapping rules coincide under the+  overlap substitution.  eg+       type instance F a Int = a+       type instance F Int b = b+  These two overlap on (F Int Int) but then both RHSs are Int,+  so all is well. We require that they are syntactically equal;+  anything else would be difficult to test for at this stage.+-}++------------------------------------------------------------+-- Might be a one-way match or a unifier+type MatchFun =  FamInst                -- The FamInst template+              -> TyVarSet -> [Type]     --   fi_tvs, fi_tys of that FamInst+              -> [Type]                 -- Target to match against+              -> Maybe TCvSubst++lookup_fam_inst_env'          -- The worker, local to this module+    :: MatchFun+    -> FamInstEnv+    -> TyCon -> [Type]        -- What we are looking for+    -> [FamInstMatch]+lookup_fam_inst_env' match_fun ie fam match_tys+  | isOpenFamilyTyCon fam+  , Just (FamIE insts) <- lookupUDFM ie fam+  = find insts    -- The common case+  | otherwise = []+  where++    find [] = []+    find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs+                        , fi_tys = tpl_tys }) : rest)+        -- Fast check for no match, uses the "rough match" fields+      | instanceCantMatch rough_tcs mb_tcs+      = find rest++        -- Proper check+      | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1+      = (FamInstMatch { fim_instance = item+                      , fim_tys      = substTyVars subst tpl_tvs `chkAppend` match_tys2+                      , fim_cos      = ASSERT( all (isJust . lookupCoVar subst) tpl_cvs )+                                       substCoVars subst tpl_cvs+                      })+        : find rest++        -- No match => try next+      | otherwise+      = find rest+      where+        (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys++      -- Precondition: the tycon is saturated (or over-saturated)++    -- Deal with over-saturation+    -- See Note [Over-saturated matches]+    split_tys tpl_tys+      | isTypeFamilyTyCon fam+      = pre_rough_split_tys++      | otherwise+      = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys+            rough_tcs = roughMatchTcs match_tys1+        in (rough_tcs, match_tys1, match_tys2)++    (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys+    pre_rough_split_tys+      = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2)++lookup_fam_inst_env           -- The worker, local to this module+    :: MatchFun+    -> FamInstEnvs+    -> TyCon -> [Type]        -- What we are looking for+    -> [FamInstMatch]         -- Successful matches++-- Precondition: the tycon is saturated (or over-saturated)++lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys+  =  lookup_fam_inst_env' match_fun home_ie fam tys+  ++ lookup_fam_inst_env' match_fun pkg_ie  fam tys++{-+Note [Over-saturated matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's ok to look up an over-saturated type constructor.  E.g.+     type family F a :: * -> *+     type instance F (a,b) = Either (a->b)++The type instance gives rise to a newtype TyCon (at a higher kind+which you can't do in Haskell!):+     newtype FPair a b = FP (Either (a->b))++Then looking up (F (Int,Bool) Char) will return a FamInstMatch+     (FPair, [Int,Bool,Char])+The "extra" type argument [Char] just stays on the end.++We handle data families and type families separately here:++ * For type families, all instances of a type family must have the+   same arity, so we can precompute the split between the match_tys+   and the overflow tys. This is done in pre_rough_split_tys.++ * For data family instances, though, we need to re-split for each+   instance, because the breakdown might be different for each+   instance.  Why?  Because of eta reduction; see+   Note [Eta reduction for data families].+-}++-- checks if one LHS is dominated by a list of other branches+-- in other words, if an application would match the first LHS, it is guaranteed+-- to match at least one of the others. The RHSs are ignored.+-- This algorithm is conservative:+--   True -> the LHS is definitely covered by the others+--   False -> no information+-- It is currently (Oct 2012) used only for generating errors for+-- inaccessible branches. If these errors go unreported, no harm done.+-- This is defined here to avoid a dependency from CoAxiom to Unify+isDominatedBy :: CoAxBranch -> [CoAxBranch] -> Bool+isDominatedBy branch branches+  = or $ map match branches+    where+      lhs = coAxBranchLHS branch+      match (CoAxBranch { cab_lhs = tys })+        = isJust $ tcMatchTys tys lhs++{-+************************************************************************+*                                                                      *+                Choosing an axiom application+*                                                                      *+************************************************************************++The lookupFamInstEnv function does a nice job for *open* type families,+but we also need to handle closed ones when normalising a type:+-}++reduceTyFamApp_maybe :: FamInstEnvs+                     -> Role              -- Desired role of result coercion+                     -> TyCon -> [Type]+                     -> Maybe (Coercion, Type)+-- Attempt to do a *one-step* reduction of a type-family application+--    but *not* newtypes+-- Works on type-synonym families always; data-families only if+--     the role we seek is representational+-- It does *not* normalise the type arguments first, so this may not+--     go as far as you want. If you want normalised type arguments,+--     use normaliseTcArgs first.+--+-- The TyCon can be oversaturated.+-- Works on both open and closed families+--+-- Always returns a *homogeneous* coercion -- type family reductions are always+-- homogeneous+reduceTyFamApp_maybe envs role tc tys+  | Phantom <- role+  = Nothing++  | case role of+      Representational -> isOpenFamilyTyCon     tc+      _                -> isOpenTypeFamilyTyCon tc+       -- If we seek a representational coercion+       -- (e.g. the call in topNormaliseType_maybe) then we can+       -- unwrap data families as well as type-synonym families;+       -- otherwise only type-synonym families+  , FamInstMatch { fim_instance = FamInst { fi_axiom = ax }+                 , fim_tys      = inst_tys+                 , fim_cos      = inst_cos } : _ <- lookupFamInstEnv envs tc tys+      -- NB: Allow multiple matches because of compatible overlap++  = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos+        ty = coercionRKind co+    in Just (co, ty)++  | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc+  , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys+  = let co = mkAxInstCo role ax ind inst_tys inst_cos+        ty = coercionRKind co+    in Just (co, ty)++  | Just ax           <- isBuiltInSynFamTyCon_maybe tc+  , Just (coax,ts,ty) <- sfMatchFam ax tys+  = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)+    in Just (co, ty)++  | otherwise+  = Nothing++-- The axiom can be oversaturated. (Closed families only.)+chooseBranch :: CoAxiom Branched -> [Type]+             -> Maybe (BranchIndex, [Type], [Coercion])  -- found match, with args+chooseBranch axiom tys+  = do { let num_pats = coAxiomNumPats axiom+             (target_tys, extra_tys) = splitAt num_pats tys+             branches = coAxiomBranches axiom+       ; (ind, inst_tys, inst_cos)+           <- findBranch (unMkBranches branches) target_tys+       ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) }++-- The axiom must *not* be oversaturated+findBranch :: Array BranchIndex CoAxBranch+           -> [Type]+           -> Maybe (BranchIndex, [Type], [Coercion])+    -- coercions relate requested types to returned axiom LHS at role N+findBranch branches target_tys+  = foldr go Nothing (assocs branches)+  where+    go :: (BranchIndex, CoAxBranch)+       -> Maybe (BranchIndex, [Type], [Coercion])+       -> Maybe (BranchIndex, [Type], [Coercion])+    go (index, branch) other+      = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs+                        , cab_lhs = tpl_lhs+                        , cab_incomps = incomps }) = branch+            in_scope = mkInScopeSet (unionVarSets $+                            map (tyCoVarsOfTypes . coAxBranchLHS) incomps)+            -- See Note [Flattening] below+            flattened_target = flattenTys in_scope target_tys+        in case tcMatchTys tpl_lhs target_tys of+        Just subst -- matching worked. now, check for apartness.+          |  apartnessCheck flattened_target branch+          -> -- matching worked & we're apart from all incompatible branches.+             -- success+             ASSERT( all (isJust . lookupCoVar subst) tpl_cvs )+             Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs)++        -- failure. keep looking+        _ -> other++-- | Do an apartness check, as described in the "Closed Type Families" paper+-- (POPL '14). This should be used when determining if an equation+-- ('CoAxBranch') of a closed type family can be used to reduce a certain target+-- type family application.+apartnessCheck :: [Type]     -- ^ /flattened/ target arguments. Make sure+                             -- they're flattened! See Note [Flattening].+                             -- (NB: This "flat" is a different+                             -- "flat" than is used in TcFlatten.)+               -> CoAxBranch -- ^ the candidate equation we wish to use+                             -- Precondition: this matches the target+               -> Bool       -- ^ True <=> equation can fire+apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps })+  = all (isSurelyApart+         . tcUnifyTysFG (const BindMe) flattened_target+         . coAxBranchLHS) incomps+  where+    isSurelyApart SurelyApart = True+    isSurelyApart _           = False++{-+************************************************************************+*                                                                      *+                Looking up a family instance+*                                                                      *+************************************************************************++Note [Normalising types]+~~~~~~~~~~~~~~~~~~~~~~~~+The topNormaliseType function removes all occurrences of type families+and newtypes from the top-level structure of a type. normaliseTcApp does+the type family lookup and is fairly straightforward. normaliseType is+a little more involved.++The complication comes from the fact that a type family might be used in the+kind of a variable bound in a forall. We wish to remove this type family+application, but that means coming up with a fresh variable (with the new+kind). Thus, we need a substitution to be built up as we recur through the+type. However, an ordinary TCvSubst just won't do: when we hit a type variable+whose kind has changed during normalisation, we need both the new type+variable *and* the coercion. We could conjure up a new VarEnv with just this+property, but a usable substitution environment already exists:+LiftingContexts from the liftCoSubst family of functions, defined in GHC.Core.Coercion.+A LiftingContext maps a type variable to a coercion and a coercion variable to+a pair of coercions. Let's ignore coercion variables for now. Because the+coercion a type variable maps to contains the destination type (via+coercionKind), we don't need to store that destination type separately. Thus,+a LiftingContext has what we need: a map from type variables to (Coercion,+Type) pairs.++We also benefit because we can piggyback on the liftCoSubstVarBndr function to+deal with binders. However, I had to modify that function to work with this+application. Thus, we now have liftCoSubstVarBndrUsing, which takes+a function used to process the kind of the binder. We don't wish+to lift the kind, but instead normalise it. So, we pass in a callback function+that processes the kind of the binder.++After that brilliant explanation of all this, I'm sure you've forgotten the+dangling reference to coercion variables. What do we do with those? Nothing at+all. The point of normalising types is to remove type family applications, but+there's no sense in removing these from coercions. We would just get back a+new coercion witnessing the equality between the same types as the original+coercion. Because coercions are irrelevant anyway, there is no point in doing+this. So, whenever we encounter a coercion, we just say that it won't change.+That's what the CoercionTy case is doing within normalise_type.++Note [Normalisation and type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to be a bit careful about normalising in the presence of type+synonyms (#13035).  Suppose S is a type synonym, and we have+   S t1 t2+If S is family-free (on its RHS) we can just normalise t1 and t2 and+reconstruct (S t1' t2').   Expanding S could not reveal any new redexes+because type families are saturated.++But if S has a type family on its RHS we expand /before/ normalising+the args t1, t2.  If we normalise t1, t2 first, we'll re-normalise them+after expansion, and that can lead to /exponential/ behaviour; see #13035.++Notice, though, that expanding first can in principle duplicate t1,t2,+which might contain redexes. I'm sure you could conjure up an exponential+case by that route too, but it hasn't happened in practice yet!+-}++topNormaliseType :: FamInstEnvs -> Type -> Type+topNormaliseType env ty = case topNormaliseType_maybe env ty of+                            Just (_co, ty') -> ty'+                            Nothing         -> ty++topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type)++-- ^ Get rid of *outermost* (or toplevel)+--      * type function redex+--      * data family redex+--      * newtypes+-- returning an appropriate Representational coercion.  Specifically, if+--   topNormaliseType_maybe env ty = Just (co, ty')+-- then+--   (a) co :: ty ~R ty'+--   (b) ty' is not a newtype, and is not a type-family or data-family redex+--+-- However, ty' can be something like (Maybe (F ty)), where+-- (F ty) is a redex.+--+-- Always operates homogeneously: the returned type has the same kind as the+-- original type, and the returned coercion is always homogeneous.+topNormaliseType_maybe env ty+  = do { ((co, mkind_co), nty) <- topNormaliseTypeX stepper combine ty+       ; return $ case mkind_co of+           MRefl       -> (co, nty)+           MCo kind_co -> let nty_casted = nty `mkCastTy` mkSymCo kind_co+                              final_co   = mkCoherenceRightCo Representational nty+                                                              (mkSymCo kind_co) co+                          in (final_co, nty_casted) }+  where+    stepper = unwrapNewTypeStepper' `composeSteppers` tyFamStepper++    combine (c1, mc1) (c2, mc2) = (c1 `mkTransCo` c2, mc1 `mkTransMCo` mc2)++    unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN)+    unwrapNewTypeStepper' rec_nts tc tys+      = mapStepResult (, MRefl) $ unwrapNewTypeStepper rec_nts tc tys++      -- second coercion below is the kind coercion relating the original type's kind+      -- to the normalised type's kind+    tyFamStepper :: NormaliseStepper (Coercion, MCoercionN)+    tyFamStepper rec_nts tc tys  -- Try to step a type/data family+      = let (args_co, ntys, res_co) = normaliseTcArgs env Representational tc tys in+        case reduceTyFamApp_maybe env Representational tc ntys of+          Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co, MCo res_co)+          _              -> NS_Done++---------------+normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type)+-- See comments on normaliseType for the arguments of this function+normaliseTcApp env role tc tys+  = initNormM env role (tyCoVarsOfTypes tys) $+    normalise_tc_app tc tys++-- See Note [Normalising types] about the LiftingContext+normalise_tc_app :: TyCon -> [Type] -> NormM (Coercion, Type)+normalise_tc_app tc tys+  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys+  , not (isFamFreeTyCon tc)  -- Expand and try again+  = -- A synonym with type families in the RHS+    -- Expand and try again+    -- See Note [Normalisation and type synonyms]+    normalise_type (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')++  | isFamilyTyCon tc+  = -- A type-family application+    do { env <- getEnv+       ; role <- getRole+       ; (args_co, ntys, res_co) <- normalise_tc_args tc tys+       ; case reduceTyFamApp_maybe env role tc ntys of+           Just (first_co, ty')+             -> do { (rest_co,nty) <- normalise_type ty'+                   ; return (assemble_result role nty+                                             (args_co `mkTransCo` first_co `mkTransCo` rest_co)+                                             res_co) }+           _ -> -- No unique matching family instance exists;+                -- we do not do anything+                return (assemble_result role (mkTyConApp tc ntys) args_co res_co) }++  | otherwise+  = -- A synonym with no type families in the RHS; or data type etc+    -- Just normalise the arguments and rebuild+    do { (args_co, ntys, res_co) <- normalise_tc_args tc tys+       ; role <- getRole+       ; return (assemble_result role (mkTyConApp tc ntys) args_co res_co) }++  where+    assemble_result :: Role       -- r, ambient role in NormM monad+                    -> Type       -- nty, result type, possibly of changed kind+                    -> Coercion   -- orig_ty ~r nty, possibly heterogeneous+                    -> CoercionN  -- typeKind(orig_ty) ~N typeKind(nty)+                    -> (Coercion, Type)   -- (co :: orig_ty ~r nty_casted, nty_casted)+                                          -- where nty_casted has same kind as orig_ty+    assemble_result r nty orig_to_nty kind_co+      = ( final_co, nty_old_kind )+      where+        nty_old_kind = nty `mkCastTy` mkSymCo kind_co+        final_co     = mkCoherenceRightCo r nty (mkSymCo kind_co) orig_to_nty++---------------+-- | Normalise arguments to a tycon+normaliseTcArgs :: FamInstEnvs          -- ^ env't with family instances+                -> Role                 -- ^ desired role of output coercion+                -> TyCon                -- ^ tc+                -> [Type]               -- ^ tys+                -> (Coercion, [Type], CoercionN)+                                        -- ^ co :: tc tys ~ tc new_tys+                                        -- NB: co might not be homogeneous+                                        -- last coercion :: kind(tc tys) ~ kind(tc new_tys)+normaliseTcArgs env role tc tys+  = initNormM env role (tyCoVarsOfTypes tys) $+    normalise_tc_args tc tys++normalise_tc_args :: TyCon -> [Type]             -- tc tys+                  -> NormM (Coercion, [Type], CoercionN)+                  -- (co, new_tys), where+                  -- co :: tc tys ~ tc new_tys; might not be homogeneous+                  -- res_co :: typeKind(tc tys) ~N typeKind(tc new_tys)+normalise_tc_args tc tys+  = do { role <- getRole+       ; (args_cos, nargs, res_co) <- normalise_args (tyConKind tc) (tyConRolesX role tc) tys+       ; return (mkTyConAppCo role tc args_cos, nargs, res_co) }++---------------+normaliseType :: FamInstEnvs+              -> Role  -- desired role of coercion+              -> Type -> (Coercion, Type)+normaliseType env role ty+  = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty++normalise_type :: Type                     -- old type+               -> NormM (Coercion, Type)   -- (coercion, new type), where+                                           -- co :: old-type ~ new_type+-- Normalise the input type, by eliminating *all* type-function redexes+-- but *not* newtypes (which are visible to the programmer)+-- Returns with Refl if nothing happens+-- Does nothing to newtypes+-- The returned coercion *must* be *homogeneous*+-- See Note [Normalising types]+-- Try not to disturb type synonyms if possible++normalise_type ty+  = go ty+  where+    go (TyConApp tc tys) = normalise_tc_app tc tys+    go ty@(LitTy {})     = do { r <- getRole+                              ; return (mkReflCo r ty, ty) }++    go (AppTy ty1 ty2) = go_app_tys ty1 [ty2]++    go ty@(FunTy { ft_arg = ty1, ft_res = ty2 })+      = do { (co1, nty1) <- go ty1+           ; (co2, nty2) <- go ty2+           ; r <- getRole+           ; return (mkFunCo r co1 co2, ty { ft_arg = nty1, ft_res = nty2 }) }+    go (ForAllTy (Bndr tcvar vis) ty)+      = do { (lc', tv', h, ki') <- normalise_var_bndr tcvar+           ; (co, nty)          <- withLC lc' $ normalise_type ty+           ; let tv2 = setTyVarKind tv' ki'+           ; return (mkForAllCo tv' h co, ForAllTy (Bndr tv2 vis) nty) }+    go (TyVarTy tv)    = normalise_tyvar tv+    go (CastTy ty co)+      = do { (nco, nty) <- go ty+           ; lc <- getLC+           ; let co' = substRightCo lc co+           ; return (castCoercionKind nco Nominal ty nty co co'+                    , mkCastTy nty co') }+    go (CoercionTy co)+      = do { lc <- getLC+           ; r <- getRole+           ; let right_co = substRightCo lc co+           ; return ( mkProofIrrelCo r+                         (liftCoSubst Nominal lc (coercionType co))+                         co right_co+                    , mkCoercionTy right_co ) }++    go_app_tys :: Type   -- function+               -> [Type] -- args+               -> NormM (Coercion, Type)+    -- cf. TcFlatten.flatten_app_ty_args+    go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys)+    go_app_tys fun_ty arg_tys+      = do { (fun_co, nfun) <- go fun_ty+           ; case tcSplitTyConApp_maybe nfun of+               Just (tc, xis) ->+                 do { (second_co, nty) <- go (mkTyConApp tc (xis ++ arg_tys))+                   -- flatten_app_ty_args avoids redundantly processing the xis,+                   -- but that's a much more performance-sensitive function.+                   -- This type normalisation is not called in a loop.+                    ; return (mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransCo` second_co, nty) }+               Nothing ->+                 do { (args_cos, nargs, res_co) <- normalise_args (typeKind nfun)+                                                                  (repeat Nominal)+                                                                  arg_tys+                    ; role <- getRole+                    ; let nty = mkAppTys nfun nargs+                          nco = mkAppCos fun_co args_cos+                          nty_casted = nty `mkCastTy` mkSymCo res_co+                          final_co = mkCoherenceRightCo role nty (mkSymCo res_co) nco+                    ; return (final_co, nty_casted) } }++normalise_args :: Kind    -- of the function+               -> [Role]  -- roles at which to normalise args+               -> [Type]  -- args+               -> NormM ([Coercion], [Type], Coercion)+-- returns (cos, xis, res_co), where each xi is the normalised+-- version of the corresponding type, each co is orig_arg ~ xi,+-- and the res_co :: kind(f orig_args) ~ kind(f xis)+-- NB: The xis might *not* have the same kinds as the input types,+-- but the resulting application *will* be well-kinded+-- cf. TcFlatten.flatten_args_slow+normalise_args fun_ki roles args+  = do { normed_args <- zipWithM normalise1 roles args+       ; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args+       ; return (map mkSymCo cos, xis, mkSymCo res_co) }+  where+    (ki_binders, inner_ki) = splitPiTys fun_ki+    fvs = tyCoVarsOfTypes args++    -- flattener conventions are different from ours+    impedance_match :: NormM (Coercion, Type) -> NormM (Type, Coercion)+    impedance_match action = do { (co, ty) <- action+                                ; return (ty, mkSymCo co) }++    normalise1 role ty+      = impedance_match $ withRole role $ normalise_type ty++normalise_tyvar :: TyVar -> NormM (Coercion, Type)+normalise_tyvar tv+  = ASSERT( isTyVar tv )+    do { lc <- getLC+       ; r  <- getRole+       ; return $ case liftCoSubstTyVar lc r tv of+           Just co -> (co, coercionRKind co)+           Nothing -> (mkReflCo r ty, ty) }+  where ty = mkTyVarTy tv++normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Coercion, Kind)+normalise_var_bndr tcvar+  -- works for both tvar and covar+  = do { lc1 <- getLC+       ; env <- getEnv+       ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal+       ; return $ liftCoSubstVarBndrUsing callback lc1 tcvar }++-- | a monad for the normalisation functions, reading 'FamInstEnvs',+-- a 'LiftingContext', and a 'Role'.+newtype NormM a = NormM { runNormM ::+                            FamInstEnvs -> LiftingContext -> Role -> a }+    deriving (Functor)++initNormM :: FamInstEnvs -> Role+          -> TyCoVarSet   -- the in-scope variables+          -> NormM a -> a+initNormM env role vars (NormM thing_inside)+  = thing_inside env lc role+  where+    in_scope = mkInScopeSet vars+    lc       = emptyLiftingContext in_scope++getRole :: NormM Role+getRole = NormM (\ _ _ r -> r)++getLC :: NormM LiftingContext+getLC = NormM (\ _ lc _ -> lc)++getEnv :: NormM FamInstEnvs+getEnv = NormM (\ env _ _ -> env)++withRole :: Role -> NormM a -> NormM a+withRole r thing = NormM $ \ envs lc _old_r -> runNormM thing envs lc r++withLC :: LiftingContext -> NormM a -> NormM a+withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r++instance Monad NormM where+  ma >>= fmb = NormM $ \env lc r ->+               let a = runNormM ma env lc r in+               runNormM (fmb a) env lc r++instance Applicative NormM where+  pure x = NormM $ \ _ _ _ -> x+  (<*>)  = ap++{-+************************************************************************+*                                                                      *+              Flattening+*                                                                      *+************************************************************************++Note [Flattening]+~~~~~~~~~~~~~~~~~+As described in "Closed type families with overlapping equations"+http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf+we need to flatten core types before unifying them, when checking for "surely-apart"+against earlier equations of a closed type family.+Flattening means replacing all top-level uses of type functions with+fresh variables, *taking care to preserve sharing*. That is, the type+(Either (F a b) (F a b)) should flatten to (Either c c), never (Either+c d).++Here is a nice example of why it's all necessary:++  type family F a b where+    F Int Bool = Char+    F a   b    = Double+  type family G a         -- open, no instances++How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match,+while the second equation does. But, before reducing, we must make sure that the+target can never become (F Int Bool). Well, no matter what G Float becomes, it+certainly won't become *both* Int and Bool, so indeed we're safe reducing+(F (G Float) (G Float)) to Double.++This is necessary not only to get more reductions (which we might be+willing to give up on), but for substitutivity. If we have (F x x), we+can see that (F x x) can reduce to Double. So, it had better be the+case that (F blah blah) can reduce to Double, no matter what (blah)+is!  Flattening as done below ensures this.++The algorithm works by building up a TypeMap TyVar, mapping+type family applications to fresh variables. This mapping must+be threaded through all the function calls, as any entry in+the mapping must be propagated to all future nodes in the tree.++The algorithm also must track the set of in-scope variables, in+order to make fresh variables as it flattens. (We are far from a+source of fresh Uniques.) See Wrinkle 2, below.++There are wrinkles, of course:++1. The flattening algorithm must account for the possibility+   of inner `forall`s. (A `forall` seen here can happen only+   because of impredicativity. However, the flattening operation+   is an algorithm in Core, which is impredicative.)+   Suppose we have (forall b. F b) -> (forall b. F b). Of course,+   those two bs are entirely unrelated, and so we should certainly+   not flatten the two calls F b to the same variable. Instead, they+   must be treated separately. We thus carry a substitution that+   freshens variables; we must apply this substitution (in+   `coreFlattenTyFamApp`) before looking up an application in the environment.+   Note that the range of the substitution contains only TyVars, never anything+   else.++   For the sake of efficiency, we only apply this substitution when absolutely+   necessary. Namely:++   * We do not perform the substitution at all if it is empty.+   * We only need to worry about the arguments of a type family that are within+     the arity of said type family, so we can get away with not applying the+     substitution to any oversaturated type family arguments.+   * Importantly, we do /not/ achieve this substitution by recursively+     flattening the arguments, as this would be wrong. Consider `F (G a)`,+     where F and G are type families. We might decide that `F (G a)` flattens+     to `beta`. Later, the substitution is non-empty (but does not map `a`) and+     so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course,+     `F gamma` is unknown, and so we flatten it to `delta`, but it really+     should have been `beta`! Argh!++     Moral of the story: instead of flattening the arguments, just substitute+     them directly.++2. There are two different reasons we might add a variable+   to the in-scope set as we work:++     A. We have just invented a new flattening variable.+     B. We have entered a `forall`.++   Annoying here is that in-scope variable source (A) must be+   threaded through the calls. For example, consider (F b -> forall c. F c).+   Suppose that, when flattening F b, we invent a fresh variable c.+   Now, when we encounter (forall c. F c), we need to know c is already in+   scope so that we locally rename c to c'. However, if we don't thread through+   the in-scope set from one argument of (->) to the other, we won't know this+   and might get very confused.++   In contrast, source (B) increases only as we go deeper, as in-scope sets+   normally do. However, even here we must be careful. The TypeMap TyVar that+   contains mappings from type family applications to freshened variables will+   be threaded through both sides of (forall b. F b) -> (forall b. F b). We+   thus must make sure that the two `b`s don't get renamed to the same b1. (If+   they did, then looking up `F b1` would yield the same flatten var for+   each.) So, even though `forall`-bound variables should really be in the+   in-scope set only when they are in scope, we retain these variables even+   outside of their scope. This ensures that, if we encounter a fresh+   `forall`-bound b, we will rename it to b2, not b1. Note that keeping a+   larger in-scope set than strictly necessary is always OK, as in-scope sets+   are only ever used to avoid collisions.++   Sadly, the freshening substitution described in (1) really mustn't bind+   variables outside of their scope: note that its domain is the *unrenamed*+   variables. This means that the substitution gets "pushed down" (like a+   reader monad) while the in-scope set gets threaded (like a state monad).+   Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst;+   instead, we just carry a TvSubstEnv down, tying it to the InScopeSet+   traveling separately as necessary.++3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k:++     type family F ty_1 ... ty_k :: res_k++   It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a+   flattening skolem. But we must instead flatten it to+   `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the+   type family.++   Why is this better? Consider the following concrete example from #16995:++     type family Param :: Type -> Type++     type family LookupParam (a :: Type) :: Type where+       LookupParam (f Char) = Bool+       LookupParam x        = Int++     foo :: LookupParam (Param ())+     foo = 42++   In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to+   `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if+   `alpha` is apart from `f Char`, so it won't fall through to the second+   equation. But since the `Param` type family has arity 0, we can instead+   flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is+   apart from `f Char`, permitting the second equation to be reached.++   Not only does this allow more programs to be accepted, it's also important+   for correctness. Not doing this was the root cause of the Core Lint error+   in #16995.++flattenTys is defined here because of module dependencies.+-}++data FlattenEnv+  = FlattenEnv { fe_type_map :: TypeMap TyVar+                 -- domain: exactly-saturated type family applications+                 -- range: fresh variables+               , fe_in_scope :: InScopeSet }+                 -- See Note [Flattening]++emptyFlattenEnv :: InScopeSet -> FlattenEnv+emptyFlattenEnv in_scope+  = FlattenEnv { fe_type_map = emptyTypeMap+               , fe_in_scope = in_scope }++updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv+updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) }++flattenTys :: InScopeSet -> [Type] -> [Type]+-- See Note [Flattening]+-- NB: the returned types may mention fresh type variables,+--     arising from the flattening.  We don't return the+--     mapping from those fresh vars to the ty-fam+--     applications they stand for (we could, but no need)+flattenTys in_scope tys+  = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys++coreFlattenTys :: TvSubstEnv -> FlattenEnv+               -> [Type] -> (FlattenEnv, [Type])+coreFlattenTys subst = mapAccumL (coreFlattenTy subst)++coreFlattenTy :: TvSubstEnv -> FlattenEnv+              -> Type -> (FlattenEnv, Type)+coreFlattenTy subst = go+  where+    go env ty | Just ty' <- coreView ty = go env ty'++    go env (TyVarTy tv)+      | Just ty <- lookupVarEnv subst tv = (env, ty)+      | otherwise                        = let (env', ki) = go env (tyVarKind tv) in+                                           (env', mkTyVarTy $ setTyVarKind tv ki)+    go env (AppTy ty1 ty2) = let (env1, ty1') = go env  ty1+                                 (env2, ty2') = go env1 ty2 in+                             (env2, AppTy ty1' ty2')+    go env (TyConApp tc tys)+         -- NB: Don't just check if isFamilyTyCon: this catches *data* families,+         -- which are generative and thus can be preserved during flattening+      | not (isGenerativeTyCon tc Nominal)+      = coreFlattenTyFamApp subst env tc tys++      | otherwise+      = let (env', tys') = coreFlattenTys subst env tys in+        (env', mkTyConApp tc tys')++    go env ty@(FunTy { ft_arg = ty1, ft_res = ty2 })+      = let (env1, ty1') = go env  ty1+            (env2, ty2') = go env1 ty2 in+        (env2, ty { ft_arg = ty1', ft_res = ty2' })++    go env (ForAllTy (Bndr tv vis) ty)+      = let (env1, subst', tv') = coreFlattenVarBndr subst env tv+            (env2, ty') = coreFlattenTy subst' env1 ty in+        (env2, ForAllTy (Bndr tv' vis) ty')++    go env ty@(LitTy {}) = (env, ty)++    go env (CastTy ty co)+      = let (env1, ty') = go env ty+            (env2, co') = coreFlattenCo subst env1 co in+        (env2, CastTy ty' co')++    go env (CoercionTy co)+      = let (env', co') = coreFlattenCo subst env co in+        (env', CoercionTy co')++-- when flattening, we don't care about the contents of coercions.+-- so, just return a fresh variable of the right (flattened) type+coreFlattenCo :: TvSubstEnv -> FlattenEnv+              -> Coercion -> (FlattenEnv, Coercion)+coreFlattenCo subst env co+  = (env2, mkCoVarCo covar)+  where+    (env1, kind') = coreFlattenTy subst env (coercionType co)+    covar         = mkFlattenFreshCoVar (fe_in_scope env1) kind'+    -- Add the covar to the FlattenEnv's in-scope set.+    -- See Note [Flattening], wrinkle 2A.+    env2          = updateInScopeSet env1 (flip extendInScopeSet covar)++coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv+                   -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar)+coreFlattenVarBndr subst env tv+  = (env2, subst', tv')+  where+    -- See Note [Flattening], wrinkle 2B.+    kind          = varType tv+    (env1, kind') = coreFlattenTy subst env kind+    tv'           = uniqAway (fe_in_scope env1) (setVarType tv kind')+    subst'        = extendVarEnv subst tv (mkTyVarTy tv')+    env2          = updateInScopeSet env1 (flip extendInScopeSet tv')++coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv+                    -> TyCon         -- type family tycon+                    -> [Type]        -- args, already flattened+                    -> (FlattenEnv, Type)+coreFlattenTyFamApp tv_subst env fam_tc fam_args+  = case lookupTypeMap type_map fam_ty of+      Just tv -> (env', mkAppTys (mkTyVarTy tv) leftover_args')+      Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc+                     tv         = uniqAway in_scope $+                                  mkTyVar tyvar_name (typeKind fam_ty)++                     ty'   = mkAppTys (mkTyVarTy tv) leftover_args'+                     env'' = env' { fe_type_map = extendTypeMap type_map fam_ty tv+                                  , fe_in_scope = extendInScopeSet in_scope tv }+                 in (env'', ty')+  where+    arity = tyConArity fam_tc+    tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv+    (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args )+                                    splitAt arity fam_args+    -- Apply the substitution before looking up an application in the+    -- environment. See Note [Flattening], wrinkle 1.+    -- NB: substTys short-cuts the common case when the substitution is empty.+    sat_fam_args' = substTys tcv_subst sat_fam_args+    (env', leftover_args') = coreFlattenTys tv_subst env leftover_args+    -- `fam_tc` may be over-applied to `fam_args` (see Note [Flattening],+    -- wrinkle 3), so we split it into the arguments needed to saturate it+    -- (sat_fam_args') and the rest (leftover_args')+    fam_ty = mkTyConApp fam_tc sat_fam_args'+    FlattenEnv { fe_type_map = type_map+               , fe_in_scope = in_scope } = env'++mkFlattenFreshTyName :: Uniquable a => a -> Name+mkFlattenFreshTyName unq+  = mkSysTvName (getUnique unq) (fsLit "flt")++mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar+mkFlattenFreshCoVar in_scope kind+  = let uniq = unsafeGetFreshLocalUnique in_scope+        name = mkSystemVarName uniq (fsLit "flc")+    in mkCoVar name kind
+ compiler/GHC/Core/InstEnv.hs view
@@ -0,0 +1,1030 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[InstEnv]{Utilities for typechecking instance declarations}++The bits common to TcInstDcls and TcDeriv.+-}++{-# LANGUAGE CPP, DeriveDataTypeable #-}++module GHC.Core.InstEnv (+        DFunId, InstMatch, ClsInstLookupResult,+        OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,+        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,+        instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,+        instanceDFunId, updateClsInstDFun, instanceRoughTcs,+        fuzzyClsInstCmp, orphNamesOfClsInst,++        InstEnvs(..), VisibleOrphanModules, InstEnv,+        emptyInstEnv, extendInstEnv,+        deleteFromInstEnv, deleteDFunFromInstEnv,+        identicalClsInstHead,+        extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses,+        memberInstEnv,+        instIsVisible,+        classInstances, instanceBindFun,+        instanceCantMatch, roughMatchTcs,+        isOverlappable, isOverlapping, isIncoherent+    ) where++#include "HsVersions.h"++import GhcPrelude++import TcType -- InstEnv is really part of the type checker,+              -- and depends on TcType in many ways+import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor )+import GHC.Types.Module+import GHC.Core.Class+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Core.Unify+import Outputable+import ErrUtils+import GHC.Types.Basic+import GHC.Types.Unique.DFM+import Util+import GHC.Types.Id+import Data.Data        ( Data )+import Data.Maybe       ( isJust, isNothing )++{-+************************************************************************+*                                                                      *+           ClsInst: the data type for type-class instances+*                                                                      *+************************************************************************+-}++-- | A type-class instance. Note that there is some tricky laziness at work+-- here. See Note [ClsInst laziness and the rough-match fields] for more+-- details.+data ClsInst+  = ClsInst {   -- Used for "rough matching"; see+                -- Note [ClsInst laziness and the rough-match fields]+                -- INVARIANT: is_tcs = roughMatchTcs is_tys+               is_cls_nm :: Name        -- ^ Class name+             , is_tcs  :: [Maybe Name]  -- ^ Top of type args++               -- | @is_dfun_name = idName . is_dfun@.+               --+               -- We use 'is_dfun_name' for the visibility check,+               -- 'instIsVisible', which needs to know the 'Module' which the+               -- dictionary is defined in. However, we cannot use the 'Module'+               -- attached to 'is_dfun' since doing so would mean we would+               -- potentially pull in an entire interface file unnecessarily.+               -- This was the cause of #12367.+             , is_dfun_name :: Name++                -- Used for "proper matching"; see Note [Proper-match fields]+             , is_tvs  :: [TyVar]       -- Fresh template tyvars for full match+                                        -- See Note [Template tyvars are fresh]+             , is_cls  :: Class         -- The real class+             , is_tys  :: [Type]        -- Full arg types (mentioning is_tvs)+                -- INVARIANT: is_dfun Id has type+                --      forall is_tvs. (...) => is_cls is_tys+                -- (modulo alpha conversion)++             , is_dfun :: DFunId -- See Note [Haddock assumptions]++             , is_flag :: OverlapFlag   -- See detailed comments with+                                        -- the decl of BasicTypes.OverlapFlag+             , is_orphan :: IsOrphan+    }+  deriving Data++-- | A fuzzy comparison function for class instances, intended for sorting+-- instances before displaying them to the user.+fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering+fuzzyClsInstCmp x y =+    stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend`+    mconcat (map cmp (zip (is_tcs x) (is_tcs y)))+  where+    cmp (Nothing, Nothing) = EQ+    cmp (Nothing, Just _) = LT+    cmp (Just _, Nothing) = GT+    cmp (Just x, Just y) = stableNameCmp x y++isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool+isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i))+isOverlapping  i = hasOverlappingFlag  (overlapMode (is_flag i))+isIncoherent   i = hasIncoherentFlag   (overlapMode (is_flag i))++{-+Note [ClsInst laziness and the rough-match fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we load 'instance A.C B.T' from A.hi, but suppose that the type B.T is+otherwise unused in the program. Then it's stupid to load B.hi, the data type+declaration for B.T -- and perhaps further instance declarations!++We avoid this as follows:++* is_cls_nm, is_tcs, is_dfun_name are all Names. We can poke them to our heart's+  content.++* Proper-match fields. is_dfun, and its related fields is_tvs, is_cls, is_tys+  contain TyVars, Class, Type, Class etc, and so are all lazy thunks. When we+  poke any of these fields we'll typecheck the DFunId declaration, and hence+  pull in interfaces that it refers to. See Note [Proper-match fields].++* Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and+  is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking+  inside the DFunId. The rough-match fields allow us to say "definitely does not+  match", based only on Names.++  This laziness is very important; see #12367. Try hard to avoid pulling on+  the structured fields unless you really need the instance.++* Another place to watch is InstEnv.instIsVisible, which needs the module to+  which the ClsInst belongs. We can get this from is_dfun_name.++* In is_tcs,+    Nothing  means that this type arg is a type variable++    (Just n) means that this type arg is a+                TyConApp with a type constructor of n.+                This is always a real tycon, never a synonym!+                (Two different synonyms might match, but two+                different real tycons can't.)+                NB: newtypes are not transparent, though!+-}++{-+Note [Template tyvars are fresh]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The is_tvs field of a ClsInst has *completely fresh* tyvars.+That is, they are+  * distinct from any other ClsInst+  * distinct from any tyvars free in predicates that may+    be looked up in the class instance environment+Reason for freshness: we use unification when checking for overlap+etc, and that requires the tyvars to be distinct.++The invariant is checked by the ASSERT in lookupInstEnv'.++Note [Proper-match fields]+~~~~~~~~~~~~~~~~~~~~~~~~~+The is_tvs, is_cls, is_tys fields are simply cached values, pulled+out (lazily) from the dfun id. They are cached here simply so+that we don't need to decompose the DFunId each time we want+to match it.  The hope is that the rough-match fields mean+that we often never poke the proper-match fields.++However, note that:+ * is_tvs must be a superset of the free vars of is_tys++ * is_tvs, is_tys may be alpha-renamed compared to the ones in+   the dfun Id++Note [Haddock assumptions]+~~~~~~~~~~~~~~~~~~~~~~~~~~+For normal user-written instances, Haddock relies on++ * the SrcSpan of+ * the Name of+ * the is_dfun of+ * an Instance++being equal to++  * the SrcSpan of+  * the instance head type of+  * the InstDecl used to construct the Instance.+-}++instanceDFunId :: ClsInst -> DFunId+instanceDFunId = is_dfun++updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst+updateClsInstDFun tidy_dfun ispec+  = ispec { is_dfun = tidy_dfun (is_dfun ispec) }++instanceRoughTcs :: ClsInst -> [Maybe Name]+instanceRoughTcs = is_tcs+++instance NamedThing ClsInst where+   getName ispec = getName (is_dfun ispec)++instance Outputable ClsInst where+   ppr = pprInstance++pprInstance :: ClsInst -> SDoc+-- Prints the ClsInst as an instance declaration+pprInstance ispec+  = hang (pprInstanceHdr ispec)+       2 (vcat [ text "--" <+> pprDefinedAt (getName ispec)+               , whenPprDebug (ppr (is_dfun ispec)) ])++-- * pprInstanceHdr is used in VStudio to populate the ClassView tree+pprInstanceHdr :: ClsInst -> SDoc+-- Prints the ClsInst as an instance declaration+pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun })+  = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun)++pprInstances :: [ClsInst] -> SDoc+pprInstances ispecs = vcat (map pprInstance ispecs)++instanceHead :: ClsInst -> ([TyVar], Class, [Type])+-- Returns the head, using the fresh tyavs from the ClsInst+instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun })+   = (tvs, cls, tys)+   where+     (_, _, cls, _) = tcSplitDFunTy (idType dfun)++-- | Collects the names of concrete types and type constructors that make+-- up the head of a class instance. For instance, given `class Foo a b`:+--+-- `instance Foo (Either (Maybe Int) a) Bool` would yield+--      [Either, Maybe, Int, Bool]+--+-- Used in the implementation of ":info" in GHCi.+--+-- The 'tcSplitSigmaTy' is because of+--      instance Foo a => Baz T where ...+-- The decl is an orphan if Baz and T are both not locally defined,+--      even if Foo *is* locally defined+orphNamesOfClsInst :: ClsInst -> NameSet+orphNamesOfClsInst (ClsInst { is_cls_nm = cls_nm, is_tys = tys })+  = orphNamesOfTypes tys `unionNameSet` unitNameSet cls_nm++instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type])+-- Decomposes the DFunId+instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec))++mkLocalInstance :: DFunId -> OverlapFlag+                -> [TyVar] -> Class -> [Type]+                -> ClsInst+-- Used for local instances, where we can safely pull on the DFunId.+-- Consider using newClsInst instead; this will also warn if+-- the instance is an orphan.+mkLocalInstance dfun oflag tvs cls tys+  = ClsInst { is_flag = oflag, is_dfun = dfun+            , is_tvs = tvs+            , is_dfun_name = dfun_name+            , is_cls = cls, is_cls_nm = cls_name+            , is_tys = tys, is_tcs = roughMatchTcs tys+            , is_orphan = orph+            }+  where+    cls_name = className cls+    dfun_name = idName dfun+    this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name+    is_local name = nameIsLocalOrFrom this_mod name++        -- Compute orphanhood.  See Note [Orphans] in GHC.Core.InstEnv+    (cls_tvs, fds) = classTvsFds cls+    arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys]++    -- See Note [When exactly is an instance decl an orphan?]+    orph | is_local cls_name = NotOrphan (nameOccName cls_name)+         | all notOrphan mb_ns  = ASSERT( not (null mb_ns) ) head mb_ns+         | otherwise         = IsOrphan++    notOrphan NotOrphan{} = True+    notOrphan _ = False++    mb_ns :: [IsOrphan]    -- One for each fundep; a locally-defined name+                           -- that is not in the "determined" arguments+    mb_ns | null fds   = [choose_one arg_names]+          | otherwise  = map do_one fds+    do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names+                                            , not (tv `elem` rtvs)]++    choose_one nss = chooseOrphanAnchor (unionNameSets nss)++mkImportedInstance :: Name         -- ^ the name of the class+                   -> [Maybe Name] -- ^ the types which the class was applied to+                   -> Name         -- ^ the 'Name' of the dictionary binding+                   -> DFunId       -- ^ the 'Id' of the dictionary.+                   -> OverlapFlag  -- ^ may this instance overlap?+                   -> IsOrphan     -- ^ is this instance an orphan?+                   -> ClsInst+-- Used for imported instances, where we get the rough-match stuff+-- from the interface file+-- The bound tyvars of the dfun are guaranteed fresh, because+-- the dfun has been typechecked out of the same interface file+mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan+  = ClsInst { is_flag = oflag, is_dfun = dfun+            , is_tvs = tvs, is_tys = tys+            , is_dfun_name = dfun_name+            , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs+            , is_orphan = orphan }+  where+    (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)++{-+Note [When exactly is an instance decl an orphan?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  (see GHC.Iface.Make.instanceToIfaceInst, which implements this)+Roughly speaking, an instance is an orphan if its head (after the =>)+mentions nothing defined in this module.++Functional dependencies complicate the situation though. Consider++  module M where { class C a b | a -> b }++and suppose we are compiling module X:++  module X where+        import M+        data T = ...+        instance C Int T where ...++This instance is an orphan, because when compiling a third module Y we+might get a constraint (C Int v), and we'd want to improve v to T.  So+we must make sure X's instances are loaded, even if we do not directly+use anything from X.++More precisely, an instance is an orphan iff++  If there are no fundeps, then at least of the names in+  the instance head is locally defined.++  If there are fundeps, then for every fundep, at least one of the+  names free in a *non-determined* part of the instance head is+  defined in this module.++(Note that these conditions hold trivially if the class is locally+defined.)+++************************************************************************+*                                                                      *+                InstEnv, ClsInstEnv+*                                                                      *+************************************************************************++A @ClsInstEnv@ all the instances of that class.  The @Id@ inside a+ClsInstEnv mapping is the dfun for that instance.++If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then++        forall a b, C t1 t2 t3  can be constructed by dfun++or, to put it another way, we have++        instance (...) => C t1 t2 t3,  witnessed by dfun+-}++---------------------------------------------------+{-+Note [InstEnv determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We turn InstEnvs into a list in some places that don't directly affect+the ABI. That happens when we create output for `:info`.+Unfortunately that nondeterminism is nonlocal and it's hard to tell what it+affects without following a chain of functions. It's also easy to accidentally+make that nondeterminism affect the ABI. Furthermore the envs should be+relatively small, so it should be free to use deterministic maps here.+Testing with nofib and validate detected no difference between UniqFM and+UniqDFM. See also Note [Deterministic UniqFM]+-}++type InstEnv = UniqDFM ClsInstEnv      -- Maps Class to instances for that class+  -- See Note [InstEnv determinism]++-- | 'InstEnvs' represents the combination of the global type class instance+-- environment, the local type class instance environment, and the set of+-- transitively reachable orphan modules (according to what modules have been+-- directly imported) used to test orphan instance visibility.+data InstEnvs = InstEnvs {+        ie_global  :: InstEnv,               -- External-package instances+        ie_local   :: InstEnv,               -- Home-package instances+        ie_visible :: VisibleOrphanModules   -- Set of all orphan modules transitively+                                             -- reachable from the module being compiled+                                             -- See Note [Instance lookup and orphan instances]+    }++-- | Set of visible orphan modules, according to what modules have been directly+-- imported.  This is based off of the dep_orphs field, which records+-- transitively reachable orphan modules (modules that define orphan instances).+type VisibleOrphanModules = ModuleSet++newtype ClsInstEnv+  = ClsIE [ClsInst]    -- The instances for a particular class, in any order++instance Outputable ClsInstEnv where+  ppr (ClsIE is) = pprInstances is++-- INVARIANTS:+--  * The is_tvs are distinct in each ClsInst+--      of a ClsInstEnv (so we can safely unify them)++-- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:+--      [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]+-- The "a" in the pattern must be one of the forall'd variables in+-- the dfun type.++emptyInstEnv :: InstEnv+emptyInstEnv = emptyUDFM++instEnvElts :: InstEnv -> [ClsInst]+instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts]+  -- See Note [InstEnv determinism]++instEnvClasses :: InstEnv -> [Class]+instEnvClasses ie = [is_cls e | ClsIE (e : _) <- eltsUDFM ie]++-- | Test if an instance is visible, by checking that its origin module+-- is in 'VisibleOrphanModules'.+-- See Note [Instance lookup and orphan instances]+instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool+instIsVisible vis_mods ispec+  -- NB: Instances from the interactive package always are visible. We can't+  -- add interactive modules to the set since we keep creating new ones+  -- as a GHCi session progresses.+  = case nameModule_maybe (is_dfun_name ispec) of+      Nothing -> True+      Just mod | isInteractiveModule mod     -> True+               | IsOrphan <- is_orphan ispec -> mod `elemModuleSet` vis_mods+               | otherwise                   -> True++classInstances :: InstEnvs -> Class -> [ClsInst]+classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls+  = get home_ie ++ get pkg_ie+  where+    get env = case lookupUDFM env cls of+                Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts+                Nothing            -> []++-- | Checks for an exact match of ClsInst in the instance environment.+-- We use this when we do signature checking in TcRnDriver+memberInstEnv :: InstEnv -> ClsInst -> Bool+memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) =+    maybe False (\(ClsIE items) -> any (identicalDFunType ins_item) items)+          (lookupUDFM inst_env cls_nm)+ where+  identicalDFunType cls1 cls2 =+    eqType (varType (is_dfun cls1)) (varType (is_dfun cls2))++extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv+extendInstEnvList inst_env ispecs = foldl' extendInstEnv inst_env ispecs++extendInstEnv :: InstEnv -> ClsInst -> InstEnv+extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })+  = addToUDFM_C add inst_env cls_nm (ClsIE [ins_item])+  where+    add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts)++deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv+deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })+  = adjustUDFM adjust inst_env cls_nm+  where+    adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items)++deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv+-- Delete a specific instance fron an InstEnv+deleteDFunFromInstEnv inst_env dfun+  = adjustUDFM adjust inst_env cls+  where+    (_, _, cls, _) = tcSplitDFunTy (idType dfun)+    adjust (ClsIE items) = ClsIE (filterOut same_dfun items)+    same_dfun (ClsInst { is_dfun = dfun' }) = dfun == dfun'++identicalClsInstHead :: ClsInst -> ClsInst -> Bool+-- ^ True when when the instance heads are the same+-- e.g.  both are   Eq [(a,b)]+-- Used for overriding in GHCi+-- Obviously should be insensitive to alpha-renaming+identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tys = tys1 })+                     (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tys = tys2 })+  =  cls_nm1 == cls_nm2+  && not (instanceCantMatch rough1 rough2)  -- Fast check for no match, uses the "rough match" fields+  && isJust (tcMatchTys tys1 tys2)+  && isJust (tcMatchTys tys2 tys1)++{-+************************************************************************+*                                                                      *+        Looking up an instance+*                                                                      *+************************************************************************++@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match.  Since+the env is kept ordered, the first match must be the only one.  The+thing we are looking up can have an arbitrary "flexi" part.++Note [Instance lookup and orphan instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are compiling a module M, and we have a zillion packages+loaded, and we are looking up an instance for C (T W).  If we find a+match in module 'X' from package 'p', should be "in scope"; that is,++  is p:X in the transitive closure of modules imported from M?++The difficulty is that the "zillion packages" might include ones loaded+through earlier invocations of the GHC API, or earlier module loads in GHCi.+They might not be in the dependencies of M itself; and if not, the instances+in them should not be visible.  #2182, #8427.++There are two cases:+  * If the instance is *not an orphan*, then module X defines C, T, or W.+    And in order for those types to be involved in typechecking M, it+    must be that X is in the transitive closure of M's imports.  So we+    can use the instance.++  * If the instance *is an orphan*, the above reasoning does not apply.+    So we keep track of the set of orphan modules transitively below M;+    this is the ie_visible field of InstEnvs, of type VisibleOrphanModules.++    If module p:X is in this set, then we can use the instance, otherwise+    we can't.++Note [Rules for instance lookup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+These functions implement the carefully-written rules in the user+manual section on "overlapping instances". At risk of duplication,+here are the rules.  If the rules change, change this text and the+user manual simultaneously.  The link may be this:+http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap++The willingness to be overlapped or incoherent is a property of the+instance declaration itself, controlled as follows:++ * An instance is "incoherent"+   if it has an INCOHERENT pragma, or+   if it appears in a module compiled with -XIncoherentInstances.++ * An instance is "overlappable"+   if it has an OVERLAPPABLE or OVERLAPS pragma, or+   if it appears in a module compiled with -XOverlappingInstances, or+   if the instance is incoherent.++ * An instance is "overlapping"+   if it has an OVERLAPPING or OVERLAPS pragma, or+   if it appears in a module compiled with -XOverlappingInstances, or+   if the instance is incoherent.+     compiled with -XOverlappingInstances.++Now suppose that, in some client module, we are searching for an instance+of the target constraint (C ty1 .. tyn). The search works like this.++*  Find all instances `I` that *match* the target constraint; that is, the+   target constraint is a substitution instance of `I`. These instance+   declarations are the *candidates*.++*  Eliminate any candidate `IX` for which both of the following hold:++   -  There is another candidate `IY` that is strictly more specific; that+      is, `IY` is a substitution instance of `IX` but not vice versa.++   -  Either `IX` is *overlappable*, or `IY` is *overlapping*. (This+      "either/or" design, rather than a "both/and" design, allow a+      client to deliberately override an instance from a library,+      without requiring a change to the library.)++-  If exactly one non-incoherent candidate remains, select it. If all+   remaining candidates are incoherent, select an arbitrary one.+   Otherwise the search fails (i.e. when more than one surviving+   candidate is not incoherent).++-  If the selected candidate (from the previous step) is incoherent, the+   search succeeds, returning that candidate.++-  If not, find all instances that *unify* with the target constraint,+   but do not *match* it. Such non-candidate instances might match when+   the target constraint is further instantiated. If all of them are+   incoherent, the search succeeds, returning the selected candidate; if+   not, the search fails.++Notice that these rules are not influenced by flag settings in the+client module, where the instances are *used*. These rules make it+possible for a library author to design a library that relies on+overlapping instances without the client having to know.++Note [Overlapping instances]   (NB: these notes are quite old)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Overlap is permitted, but only in such a way that one can make+a unique choice when looking up.  That is, overlap is only permitted if+one template matches the other, or vice versa.  So this is ok:++  [a]  [Int]++but this is not++  (Int,a)  (b,Int)++If overlap is permitted, the list is kept most specific first, so that+the first lookup is the right choice.+++For now we just use association lists.++\subsection{Avoiding a problem with overlapping}++Consider this little program:++\begin{pseudocode}+     class C a        where c :: a+     class C a => D a where d :: a++     instance C Int where c = 17+     instance D Int where d = 13++     instance C a => C [a] where c = [c]+     instance ({- C [a], -} D a) => D [a] where d = c++     instance C [Int] where c = [37]++     main = print (d :: [Int])+\end{pseudocode}++What do you think `main' prints  (assuming we have overlapping instances, and+all that turned on)?  Well, the instance for `D' at type `[a]' is defined to+be `c' at the same type, and we've got an instance of `C' at `[Int]', so the+answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because+the `C [Int]' instance is more specific).++Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong.  That+was easy ;-)  Let's just consult hugs for good measure.  Wait - if I use old+hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it+doesn't even compile!  What's going on!?++What hugs complains about is the `D [a]' instance decl.++\begin{pseudocode}+     ERROR "mj.hs" (line 10): Cannot build superclass instance+     *** Instance            : D [a]+     *** Context supplied    : D a+     *** Required superclass : C [a]+\end{pseudocode}++You might wonder what hugs is complaining about.  It's saying that you+need to add `C [a]' to the context of the `D [a]' instance (as appears+in comments).  But there's that `C [a]' instance decl one line above+that says that I can reduce the need for a `C [a]' instance to the+need for a `C a' instance, and in this case, I already have the+necessary `C a' instance (since we have `D a' explicitly in the+context, and `C' is a superclass of `D').++Unfortunately, the above reasoning indicates a premature commitment to the+generic `C [a]' instance.  I.e., it prematurely rules out the more specific+instance `C [Int]'.  This is the mistake that ghc-4.06 makes.  The fix is to+add the context that hugs suggests (uncomment the `C [a]'), effectively+deferring the decision about which instance to use.++Now, interestingly enough, 4.04 has this same bug, but it's covered up+in this case by a little known `optimization' that was disabled in+4.06.  Ghc-4.04 silently inserts any missing superclass context into+an instance declaration.  In this case, it silently inserts the `C+[a]', and everything happens to work out.++(See `basicTypes/MkId:mkDictFunId' for the code in question.  Search for+`Mark Jones', although Mark claims no credit for the `optimization' in+question, and would rather it stopped being called the `Mark Jones+optimization' ;-)++So, what's the fix?  I think hugs has it right.  Here's why.  Let's try+something else out with ghc-4.04.  Let's add the following line:++    d' :: D a => [a]+    d' = c++Everyone raise their hand who thinks that `d :: [Int]' should give a+different answer from `d' :: [Int]'.  Well, in ghc-4.04, it does.  The+`optimization' only applies to instance decls, not to regular+bindings, giving inconsistent behavior.++Old hugs had this same bug.  Here's how we fixed it: like GHC, the+list of instances for a given class is ordered, so that more specific+instances come before more generic ones.  For example, the instance+list for C might contain:+    ..., C Int, ..., C a, ...+When we go to look for a `C Int' instance we'll get that one first.+But what if we go looking for a `C b' (`b' is unconstrained)?  We'll+pass the `C Int' instance, and keep going.  But if `b' is+unconstrained, then we don't know yet if the more specific instance+will eventually apply.  GHC keeps going, and matches on the generic `C+a'.  The fix is to, at each step, check to see if there's a reverse+match, and if so, abort the search.  This prevents hugs from+prematurely choosing a generic instance when a more specific one+exists.++--Jeff++BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in+this test.  Suppose the instance envt had+    ..., forall a b. C a a b, ..., forall a b c. C a b c, ...+(still most specific first)+Now suppose we are looking for (C x y Int), where x and y are unconstrained.+        C x y Int  doesn't match the template {a,b} C a a b+but neither does+        C a a b  match the template {x,y} C x y Int+But still x and y might subsequently be unified so they *do* match.++Simple story: unify, don't match.+-}++type DFunInstType = Maybe Type+        -- Just ty   => Instantiate with this type+        -- Nothing   => Instantiate with any type of this tyvar's kind+        -- See Note [DFunInstType: instantiating types]++type InstMatch = (ClsInst, [DFunInstType])++type ClsInstLookupResult+     = ( [InstMatch]     -- Successful matches+       , [ClsInst]       -- These don't match but do unify+       , [InstMatch] )   -- Unsafe overlapped instances under Safe Haskell+                         -- (see Note [Safe Haskell Overlapping Instances] in+                         -- TcSimplify).++{-+Note [DFunInstType: instantiating types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A successful match is a ClsInst, together with the types at which+        the dfun_id in the ClsInst should be instantiated+The instantiating types are (Either TyVar Type)s because the dfun+might have some tyvars that *only* appear in arguments+        dfun :: forall a b. C a b, Ord b => D [a]+When we match this against D [ty], we return the instantiating types+        [Just ty, Nothing]+where the 'Nothing' indicates that 'b' can be freely instantiated.+(The caller instantiates it to a flexi type variable, which will+ presumably later become fixed via functional dependencies.)+-}++-- |Look up an instance in the given instance environment. The given class application must match exactly+-- one instance and the match may not contain any flexi type variables.  If the lookup is unsuccessful,+-- yield 'Left errorMessage'.+lookupUniqueInstEnv :: InstEnvs+                    -> Class -> [Type]+                    -> Either MsgDoc (ClsInst, [Type])+lookupUniqueInstEnv instEnv cls tys+  = case lookupInstEnv False instEnv cls tys of+      ([(inst, inst_tys)], _, _)+             | noFlexiVar -> Right (inst, inst_tys')+             | otherwise  -> Left $ text "flexible type variable:" <+>+                                    (ppr $ mkTyConApp (classTyCon cls) tys)+             where+               inst_tys'  = [ty | Just ty <- inst_tys]+               noFlexiVar = all isJust inst_tys+      _other -> Left $ text "instance not found" <+>+                       (ppr $ mkTyConApp (classTyCon cls) tys)++lookupInstEnv' :: InstEnv          -- InstEnv to look in+               -> VisibleOrphanModules   -- But filter against this+               -> Class -> [Type]  -- What we are looking for+               -> ([InstMatch],    -- Successful matches+                   [ClsInst])      -- These don't match but do unify+                                   -- (no incoherent ones in here)+-- The second component of the result pair happens when we look up+--      Foo [a]+-- in an InstEnv that has entries for+--      Foo [Int]+--      Foo [b]+-- Then which we choose would depend on the way in which 'a'+-- is instantiated.  So we report that Foo [b] is a match (mapping b->a)+-- but Foo [Int] is a unifier.  This gives the caller a better chance of+-- giving a suitable error message++lookupInstEnv' ie vis_mods cls tys+  = lookup ie+  where+    rough_tcs  = roughMatchTcs tys+    all_tvs    = all isNothing rough_tcs++    --------------+    lookup env = case lookupUDFM env cls of+                   Nothing -> ([],[])   -- No instances for this class+                   Just (ClsIE insts) -> find [] [] insts++    --------------+    find ms us [] = (ms, us)+    find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs+                              , is_tys = tpl_tys }) : rest)+      | not (instIsVisible vis_mods item)+      = find ms us rest  -- See Note [Instance lookup and orphan instances]++        -- Fast check for no match, uses the "rough match" fields+      | instanceCantMatch rough_tcs mb_tcs+      = find ms us rest++      | Just subst <- tcMatchTys tpl_tys tys+      = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest++        -- Does not match, so next check whether the things unify+        -- See Note [Overlapping instances]+        -- Ignore ones that are incoherent: Note [Incoherent instances]+      | isIncoherent item+      = find ms us rest++      | otherwise+      = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set,+                 (ppr cls <+> ppr tys <+> ppr all_tvs) $$+                 (ppr tpl_tvs <+> ppr tpl_tys)+                )+                -- Unification will break badly if the variables overlap+                -- They shouldn't because we allocate separate uniques for them+                -- See Note [Template tyvars are fresh]+        case tcUnifyTys instanceBindFun tpl_tys tys of+            Just _   -> find ms (item:us) rest+            Nothing  -> find ms us        rest+      where+        tpl_tv_set = mkVarSet tpl_tvs++---------------+-- This is the common way to call this function.+lookupInstEnv :: Bool              -- Check Safe Haskell overlap restrictions+              -> InstEnvs          -- External and home package inst-env+              -> Class -> [Type]   -- What we are looking for+              -> ClsInstLookupResult+-- ^ See Note [Rules for instance lookup]+-- ^ See Note [Safe Haskell Overlapping Instances] in TcSimplify+-- ^ See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify+lookupInstEnv check_overlap_safe+              (InstEnvs { ie_global = pkg_ie+                        , ie_local = home_ie+                        , ie_visible = vis_mods })+              cls+              tys+  = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $+    (final_matches, final_unifs, unsafe_overlapped)+  where+    (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys+    (pkg_matches,  pkg_unifs)  = lookupInstEnv' pkg_ie  vis_mods cls tys+    all_matches = home_matches ++ pkg_matches+    all_unifs   = home_unifs   ++ pkg_unifs+    final_matches = foldr insert_overlapping [] all_matches+        -- Even if the unifs is non-empty (an error situation)+        -- we still prune the matches, so that the error message isn't+        -- misleading (complaining of multiple matches when some should be+        -- overlapped away)++    unsafe_overlapped+       = case final_matches of+           [match] -> check_safe match+           _       -> []++    -- If the selected match is incoherent, discard all unifiers+    final_unifs = case final_matches of+                    (m:_) | isIncoherent (fst m) -> []+                    _                            -> all_unifs++    -- NOTE [Safe Haskell isSafeOverlap]+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -- We restrict code compiled in 'Safe' mode from overriding code+    -- compiled in any other mode. The rationale is that code compiled+    -- in 'Safe' mode is code that is untrusted by the ghc user. So+    -- we shouldn't let that code change the behaviour of code the+    -- user didn't compile in 'Safe' mode since that's the code they+    -- trust. So 'Safe' instances can only overlap instances from the+    -- same module. A same instance origin policy for safe compiled+    -- instances.+    check_safe (inst,_)+        = case check_overlap_safe && unsafeTopInstance inst of+                -- make sure it only overlaps instances from the same module+                True -> go [] all_matches+                -- most specific is from a trusted location.+                False -> []+        where+            go bad [] = bad+            go bad (i@(x,_):unchecked) =+                if inSameMod x || isOverlappable x+                    then go bad unchecked+                    else go (i:bad) unchecked++            inSameMod b =+                let na = getName $ getName inst+                    la = isInternalName na+                    nb = getName $ getName b+                    lb = isInternalName nb+                in (la && lb) || (nameModule na == nameModule nb)++    -- We consider the most specific instance unsafe when it both:+    --   (1) Comes from a module compiled as `Safe`+    --   (2) Is an orphan instance, OR, an instance for a MPTC+    unsafeTopInstance inst = isSafeOverlap (is_flag inst) &&+        (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1)++---------------+insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch]+-- ^ Add a new solution, knocking out strictly less specific ones+-- See Note [Rules for instance lookup]+insert_overlapping new_item [] = [new_item]+insert_overlapping new_item@(new_inst,_) (old_item@(old_inst,_) : old_items)+  | new_beats_old        -- New strictly overrides old+  , not old_beats_new+  , new_inst `can_override` old_inst+  = insert_overlapping new_item old_items++  | old_beats_new        -- Old strictly overrides new+  , not new_beats_old+  , old_inst `can_override` new_inst+  = old_item : old_items++  -- Discard incoherent instances; see Note [Incoherent instances]+  | isIncoherent old_inst      -- Old is incoherent; discard it+  = insert_overlapping new_item old_items+  | isIncoherent new_inst      -- New is incoherent; discard it+  = old_item : old_items++  -- Equal or incomparable, and neither is incoherent; keep both+  | otherwise+  = old_item : insert_overlapping new_item old_items+  where++    new_beats_old = new_inst `more_specific_than` old_inst+    old_beats_new = old_inst `more_specific_than` new_inst++    -- `instB` can be instantiated to match `instA`+    -- or the two are equal+    instA `more_specific_than` instB+      = isJust (tcMatchTys (is_tys instB) (is_tys instA))++    instA `can_override` instB+       = isOverlapping instA || isOverlappable instB+       -- Overlap permitted if either the more specific instance+       -- is marked as overlapping, or the more general one is+       -- marked as overlappable.+       -- Latest change described in: #9242.+       -- Previous change: #3877, Dec 10.++{-+Note [Incoherent instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+For some classes, the choice of a particular instance does not matter, any one+is good. E.g. consider++        class D a b where { opD :: a -> b -> String }+        instance D Int b where ...+        instance D a Int where ...++        g (x::Int) = opD x x  -- Wanted: D Int Int++For such classes this should work (without having to add an "instance D Int+Int", and using -XOverlappingInstances, which would then work). This is what+-XIncoherentInstances is for: Telling GHC "I don't care which instance you use;+if you can use one, use it."++Should this logic only work when *all* candidates have the incoherent flag, or+even when all but one have it? The right choice is the latter, which can be+justified by comparing the behaviour with how -XIncoherentInstances worked when+it was only about the unify-check (note [Overlapping instances]):++Example:+        class C a b c where foo :: (a,b,c)+        instance C [a] b Int+        instance [incoherent] [Int] b c+        instance [incoherent] C a Int c+Thanks to the incoherent flags,+        [Wanted]  C [a] b Int+works: Only instance one matches, the others just unify, but are marked+incoherent.++So I can write+        (foo :: ([a],b,Int)) :: ([Int], Int, Int).+but if that works then I really want to be able to write+        foo :: ([Int], Int, Int)+as well. Now all three instances from above match. None is more specific than+another, so none is ruled out by the normal overlapping rules. One of them is+not incoherent, but we still want this to compile. Hence the+"all-but-one-logic".++The implementation is in insert_overlapping, where we remove matching+incoherent instances as long as there are others.++++************************************************************************+*                                                                      *+        Binding decisions+*                                                                      *+************************************************************************+-}++instanceBindFun :: TyCoVar -> BindFlag+instanceBindFun tv | isOverlappableTyVar tv = Skolem+                   | otherwise              = BindMe+   -- Note [Binding when looking up instances]++{-+Note [Binding when looking up instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When looking up in the instance environment, or family-instance environment,+we are careful about multiple matches, as described above in+Note [Overlapping instances]++The key_tys can contain skolem constants, and we can guarantee that those+are never going to be instantiated to anything, so we should not involve+them in the unification test.  Example:+        class Foo a where { op :: a -> Int }+        instance Foo a => Foo [a]       -- NB overlap+        instance Foo [Int]              -- NB overlap+        data T = forall a. Foo a => MkT a+        f :: T -> Int+        f (MkT x) = op [x,x]+The op [x,x] means we need (Foo [a]).  Without the filterVarSet we'd+complain, saying that the choice of instance depended on the instantiation+of 'a'; but of course it isn't *going* to be instantiated.++We do this only for isOverlappableTyVar skolems.  For example we reject+        g :: forall a => [a] -> Int+        g x = op x+on the grounds that the correct instance depends on the instantiation of 'a'+-}
compiler/GHC/Core/Make.hs view
@@ -56,36 +56,35 @@  import GhcPrelude -import Id-import Var      ( EvVar, setTyVarUnique )+import GHC.Types.Id+import GHC.Types.Var  ( EvVar, setTyVarUnique )  import GHC.Core import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec )-import Literal+import GHC.Types.Literal import GHC.Driver.Types+import GHC.Platform  import TysWiredIn import PrelNames -import GHC.Hs.Utils     ( mkChunkified, chunkify )-import Type-import Coercion         ( isCoVar )+import GHC.Hs.Utils      ( mkChunkified, chunkify )+import GHC.Core.Type+import GHC.Core.Coercion ( isCoVar )+import GHC.Core.DataCon  ( DataCon, dataConWorkId ) import TysPrim-import DataCon          ( DataCon, dataConWorkId )-import IdInfo-import Demand-import Cpr-import Name      hiding ( varName )+import GHC.Types.Id.Info+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Types.Name      hiding ( varName ) import Outputable import FastString-import UniqSupply-import BasicTypes+import GHC.Types.Unique.Supply+import GHC.Types.Basic import Util-import GHC.Driver.Session import Data.List  import Data.Char        ( ord )-import Control.Monad.Fail as MonadFail ( MonadFail )  infixl 4 `mkCoreApp`, `mkCoreApps` @@ -101,7 +100,7 @@ -- and then other Ids -- It is a deterministic sort, meaining it doesn't look at the values of -- Uniques. For explanation why it's important See Note [Unique Determinism]--- in Unique.+-- in GHC.Types.Unique. sortQuantVars vs = sorted_tcvs ++ ids   where     (tcvs, ids) = partition (isTyVar <||> isCoVar) vs@@ -193,7 +192,7 @@ -- that you expect to use only at a *binding* site.  Do not use it at -- occurrence sites because it has a single, fixed unique, and it's very -- easy to get into difficulties with shadowing.  That's why it is used so little.--- See Note [WildCard binders] in SimplEnv+-- See Note [WildCard binders] in GHC.Core.Op.Simplify.Env mkWildValBinder :: Type -> Id mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty   -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors@@ -250,20 +249,20 @@ -}  -- | Create a 'CoreExpr' which will evaluate to the given @Int@-mkIntExpr :: DynFlags -> Integer -> CoreExpr        -- Result = I# i :: Int-mkIntExpr dflags i = mkCoreConApps intDataCon  [mkIntLit dflags i]+mkIntExpr :: Platform -> Integer -> CoreExpr        -- Result = I# i :: Int+mkIntExpr platform i = mkCoreConApps intDataCon  [mkIntLit platform i]  -- | Create a 'CoreExpr' which will evaluate to the given @Int@-mkIntExprInt :: DynFlags -> Int -> CoreExpr         -- Result = I# i :: Int-mkIntExprInt dflags i = mkCoreConApps intDataCon  [mkIntLitInt dflags i]+mkIntExprInt :: Platform -> Int -> CoreExpr         -- Result = I# i :: Int+mkIntExprInt platform i = mkCoreConApps intDataCon  [mkIntLitInt platform i]  -- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value-mkWordExpr :: DynFlags -> Integer -> CoreExpr-mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w]+mkWordExpr :: Platform -> Integer -> CoreExpr+mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w]  -- | Create a 'CoreExpr' which will evaluate to the given @Word@-mkWordExprWord :: DynFlags -> Word -> CoreExpr-mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w]+mkWordExprWord :: Platform -> Word -> CoreExpr+mkWordExprWord platform w = mkCoreConApps wordDataCon [mkWordLitWord platform w]  -- | Create a 'CoreExpr' which will evaluate to the given @Integer@ mkIntegerExpr  :: MonadThings m => Integer -> m CoreExpr  -- Result :: Integer@@ -576,7 +575,7 @@   = FloatLet  CoreBind   | FloatCase CoreExpr Id AltCon [Var]       -- case e of y { C ys -> ... }-      -- See Note [Floating single-alternative cases] in SetLevels+      -- See Note [Floating single-alternative cases] in GHC.Core.Op.SetLevels  instance Outputable FloatBind where   ppr (FloatLet b) = text "LET" <+> ppr b@@ -640,14 +639,14 @@            `App` list)  -- | Make a 'build' expression applied to a locally-bound worker function-mkBuildExpr :: (MonadFail.MonadFail m, MonadThings m, MonadUnique m)+mkBuildExpr :: (MonadFail m, MonadThings m, MonadUnique m)             => Type                                     -- ^ Type of list elements to be built             -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's                                                         -- of the binders for the build worker function, returns                                                         -- the body of that worker             -> m CoreExpr mkBuildExpr elt_ty mk_build_inside = do-    [n_tyvar] <- newTyVars [alphaTyVar]+    n_tyvar <- newTyVar alphaTyVar     let n_ty = mkTyVarTy n_tyvar         c_ty = mkVisFunTys [elt_ty, n_ty] n_ty     [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty]@@ -657,9 +656,9 @@     build_id <- lookupId buildName     return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside   where-    newTyVars tyvar_tmpls = do-      uniqs <- getUniquesM-      return (zipWith setTyVarUnique tyvar_tmpls uniqs)+    newTyVar tyvar_tmpl = do+      uniq <- getUniqueM+      return (setTyVarUnique tyvar_tmpl uniq)  {- ************************************************************************@@ -880,7 +879,7 @@    \x. case x of MkT a b -> g ($WMkT b a) where $WMkT is the wrapper for MkT that evaluates its arguments.  We apply the same w/w split to this unfolding (see Note [Worker-wrapper-for INLINEABLE functions] in WorkWrap) so the template ends up like+for INLINEABLE functions] in GHC.Core.Op.WorkWrap) so the template ends up like    \b. let a = absentError "blah"            x = MkT a b         in case x of MkT a b -> g ($WMkT b a)@@ -925,7 +924,7 @@  where    absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy addrPrimTy alphaTy)    -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for-   -- lifted-type things; see Note [Absent errors] in WwLib+   -- lifted-type things; see Note [Absent errors] in GHC.Core.Op.WorkWrap.Lib    arity_info = vanillaIdInfo `setArityInfo` 1    -- NB: no bottoming strictness info, unlike other error-ids.    -- See Note [aBSENT_ERROR_ID]
compiler/GHC/Core/Map.hs view
@@ -41,18 +41,18 @@  import TrieMap import GHC.Core-import Coercion-import Name-import Type-import TyCoRep-import Var+import GHC.Core.Coercion+import GHC.Types.Name+import GHC.Core.Type+import GHC.Core.TyCo.Rep+import GHC.Types.Var import FastString(FastString) import Util  import qualified Data.Map    as Map import qualified Data.IntMap as IntMap-import VarEnv-import NameEnv+import GHC.Types.Var.Env+import GHC.Types.Name.Env import Outputable import Control.Monad( (>=>) ) @@ -475,10 +475,10 @@        , tm_tylit  :: TyLitMap a        , tm_coerce :: Maybe a        }-    -- Note that there is no tyconapp case; see Note [Equality on AppTys] in Type+    -- Note that there is no tyconapp case; see Note [Equality on AppTys] in GHC.Core.Type  -- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the--- last one? See Note [Equality on AppTys] in Type+-- last one? See Note [Equality on AppTys] in GHC.Core.Type -- -- Note, however, that we keep Constraint and Type apart here, despite the fact -- that they are both synonyms of TYPE 'LiftedRep (see #11715).@@ -515,7 +515,7 @@                 (Just bv, Just bv') -> bv == bv'                 (Nothing, Nothing)  -> v == v'                 _ -> False-                -- See Note [Equality on AppTys] in Type+                -- See Note [Equality on AppTys] in GHC.Core.Type         (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s             -> D env t1 == D env' t1' && D env t2 == D env' t2'         (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s
+ compiler/GHC/Core/Op/ConstantFold.hs view
@@ -0,0 +1,2254 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[ConFold]{Constant Folder}++Conceptually, constant folding should be parameterized with the kind+of target machine to get identical behaviour during compilation time+and runtime. We cheat a little bit here...++ToDo:+   check boundaries before folding, e.g. we can fold the Float addition+   (i1 + i2) only if it results in a valid Float.+-}++{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards,+    DeriveFunctor #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}++module GHC.Core.Op.ConstantFold+   ( primOpRules+   , builtinRules+   , caseRules+   )+where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, magicDictId )++import GHC.Core+import GHC.Core.Make+import GHC.Types.Id+import GHC.Types.Literal+import GHC.Core.SimpleOpt ( exprIsLiteral_maybe )+import PrimOp             ( PrimOp(..), tagToEnumKey )+import TysWiredIn+import TysPrim+import GHC.Core.TyCon+   ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon+   , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons+   , tyConFamilySize )+import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )+import GHC.Core.Utils  ( cheapEqExpr, cheapEqExpr', exprIsHNF, exprType+                       , stripTicksTop, stripTicksTopT, mkTicks )+import GHC.Core.Unfold ( exprIsConApp_maybe )+import GHC.Core.Type+import GHC.Types.Name.Occurrence ( occNameFS )+import PrelNames+import Maybes      ( orElse )+import GHC.Types.Name ( Name, nameOccName )+import Outputable+import FastString+import GHC.Types.Basic+import GHC.Platform+import Util+import GHC.Core.Coercion   (mkUnbranchedAxInstCo,mkSymCo,Role(..))++import Control.Applicative ( Alternative(..) )++import Control.Monad+import Data.Bits as Bits+import qualified Data.ByteString as BS+import Data.Int+import Data.Ratio+import Data.Word++{-+Note [Constant folding]+~~~~~~~~~~~~~~~~~~~~~~~+primOpRules generates a rewrite rule for each primop+These rules do what is often called "constant folding"+E.g. the rules for +# might say+        4 +# 5 = 9+Well, of course you'd need a lot of rules if you did it+like that, so we use a BuiltinRule instead, so that we+can match in any two literal values.  So the rule is really+more like+        (Lit x) +# (Lit y) = Lit (x+#y)+where the (+#) on the rhs is done at compile time++That is why these rules are built in here.+-}++primOpRules ::  Name -> PrimOp -> Maybe CoreRule+primOpRules nm = \case+   TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ]+   DataToTagOp -> mkPrimOpRule nm 2 [ dataToTagRule ]++   -- Int operations+   IntAddOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))+                                    , identityPlatform zeroi+                                    , numFoldingRules IntAddOp intPrimOps+                                    ]+   IntSubOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))+                                    , rightIdentityPlatform zeroi+                                    , equalArgs >> retLit zeroi+                                    , numFoldingRules IntSubOp intPrimOps+                                    ]+   IntAddCOp   -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+))+                                    , identityCPlatform zeroi ]+   IntSubCOp   -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-))+                                    , rightIdentityCPlatform zeroi+                                    , equalArgs >> retLitNoC zeroi ]+   IntMulOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))+                                    , zeroElem zeroi+                                    , identityPlatform onei+                                    , numFoldingRules IntMulOp intPrimOps+                                    ]+   IntQuotOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)+                                    , leftZero zeroi+                                    , rightIdentityPlatform onei+                                    , equalArgs >> retLit onei ]+   IntRemOp    -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)+                                    , leftZero zeroi+                                    , do l <- getLiteral 1+                                         platform <- getPlatform+                                         guard (l == onei platform)+                                         retLit zeroi+                                    , equalArgs >> retLit zeroi+                                    , equalArgs >> retLit zeroi ]+   AndIOp      -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.))+                                    , idempotent+                                    , zeroElem zeroi ]+   OrIOp       -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))+                                    , idempotent+                                    , identityPlatform zeroi ]+   XorIOp      -> mkPrimOpRule nm 2 [ binaryLit (intOp2 xor)+                                    , identityPlatform zeroi+                                    , equalArgs >> retLit zeroi ]+   NotIOp      -> mkPrimOpRule nm 1 [ unaryLit complementOp+                                    , inversePrimOp NotIOp ]+   IntNegOp    -> mkPrimOpRule nm 1 [ unaryLit negOp+                                    , inversePrimOp IntNegOp ]+   ISllOp      -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL)+                                    , rightIdentityPlatform zeroi ]+   ISraOp      -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR)+                                    , rightIdentityPlatform zeroi ]+   ISrlOp      -> mkPrimOpRule nm 2 [ shiftRule shiftRightLogical+                                    , rightIdentityPlatform zeroi ]++   -- Word operations+   WordAddOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))+                                    , identityPlatform zerow+                                    , numFoldingRules WordAddOp wordPrimOps+                                    ]+   WordSubOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))+                                    , rightIdentityPlatform zerow+                                    , equalArgs >> retLit zerow+                                    , numFoldingRules WordSubOp wordPrimOps+                                    ]+   WordAddCOp  -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+))+                                    , identityCPlatform zerow ]+   WordSubCOp  -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-))+                                    , rightIdentityCPlatform zerow+                                    , equalArgs >> retLitNoC zerow ]+   WordMulOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))+                                    , identityPlatform onew+                                    , numFoldingRules WordMulOp wordPrimOps+                                    ]+   WordQuotOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)+                                    , rightIdentityPlatform onew ]+   WordRemOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)+                                    , leftZero zerow+                                    , do l <- getLiteral 1+                                         platform <- getPlatform+                                         guard (l == onew platform)+                                         retLit zerow+                                    , equalArgs >> retLit zerow ]+   AndOp       -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))+                                    , idempotent+                                    , zeroElem zerow ]+   OrOp        -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))+                                    , idempotent+                                    , identityPlatform zerow ]+   XorOp       -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)+                                    , identityPlatform zerow+                                    , equalArgs >> retLit zerow ]+   NotOp       -> mkPrimOpRule nm 1 [ unaryLit complementOp+                                    , inversePrimOp NotOp ]+   SllOp       -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ]+   SrlOp       -> mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ]++   -- coercions+   Word2IntOp     -> mkPrimOpRule nm 1 [ liftLitPlatform word2IntLit+                                       , inversePrimOp Int2WordOp ]+   Int2WordOp     -> mkPrimOpRule nm 1 [ liftLitPlatform int2WordLit+                                       , inversePrimOp Word2IntOp ]+   Narrow8IntOp   -> mkPrimOpRule nm 1 [ liftLit narrow8IntLit+                                       , subsumedByPrimOp Narrow8IntOp+                                       , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp+                                       , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp+                                       , narrowSubsumesAnd AndIOp Narrow8IntOp 8 ]+   Narrow16IntOp  -> mkPrimOpRule nm 1 [ liftLit narrow16IntLit+                                       , subsumedByPrimOp Narrow8IntOp+                                       , subsumedByPrimOp Narrow16IntOp+                                       , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp+                                       , narrowSubsumesAnd AndIOp Narrow16IntOp 16 ]+   Narrow32IntOp  -> mkPrimOpRule nm 1 [ liftLit narrow32IntLit+                                       , subsumedByPrimOp Narrow8IntOp+                                       , subsumedByPrimOp Narrow16IntOp+                                       , subsumedByPrimOp Narrow32IntOp+                                       , removeOp32+                                       , narrowSubsumesAnd AndIOp Narrow32IntOp 32 ]+   Narrow8WordOp  -> mkPrimOpRule nm 1 [ liftLit narrow8WordLit+                                       , subsumedByPrimOp Narrow8WordOp+                                       , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp+                                       , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp+                                       , narrowSubsumesAnd AndOp Narrow8WordOp 8 ]+   Narrow16WordOp -> mkPrimOpRule nm 1 [ liftLit narrow16WordLit+                                       , subsumedByPrimOp Narrow8WordOp+                                       , subsumedByPrimOp Narrow16WordOp+                                       , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp+                                       , narrowSubsumesAnd AndOp Narrow16WordOp 16 ]+   Narrow32WordOp -> mkPrimOpRule nm 1 [ liftLit narrow32WordLit+                                       , subsumedByPrimOp Narrow8WordOp+                                       , subsumedByPrimOp Narrow16WordOp+                                       , subsumedByPrimOp Narrow32WordOp+                                       , removeOp32+                                       , narrowSubsumesAnd AndOp Narrow32WordOp 32 ]+   OrdOp          -> mkPrimOpRule nm 1 [ liftLit char2IntLit+                                       , inversePrimOp ChrOp ]+   ChrOp          -> mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs+                                            guard (litFitsInChar lit)+                                            liftLit int2CharLit+                                       , inversePrimOp OrdOp ]+   Float2IntOp    -> mkPrimOpRule nm 1 [ liftLit float2IntLit ]+   Int2FloatOp    -> mkPrimOpRule nm 1 [ liftLit int2FloatLit ]+   Double2IntOp   -> mkPrimOpRule nm 1 [ liftLit double2IntLit ]+   Int2DoubleOp   -> mkPrimOpRule nm 1 [ liftLit int2DoubleLit ]+   -- SUP: Not sure what the standard says about precision in the following 2 cases+   Float2DoubleOp -> mkPrimOpRule nm 1 [ liftLit float2DoubleLit ]+   Double2FloatOp -> mkPrimOpRule nm 1 [ liftLit double2FloatLit ]++   -- Float+   FloatAddOp   -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))+                                     , identity zerof ]+   FloatSubOp   -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))+                                     , rightIdentity zerof ]+   FloatMulOp   -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))+                                     , identity onef+                                     , strengthReduction twof FloatAddOp  ]+             -- zeroElem zerof doesn't hold because of NaN+   FloatDivOp   -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))+                                     , rightIdentity onef ]+   FloatNegOp   -> mkPrimOpRule nm 1 [ unaryLit negOp+                                     , inversePrimOp FloatNegOp ]++   -- Double+   DoubleAddOp   -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))+                                      , identity zerod ]+   DoubleSubOp   -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))+                                      , rightIdentity zerod ]+   DoubleMulOp   -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))+                                      , identity oned+                                      , strengthReduction twod DoubleAddOp  ]+              -- zeroElem zerod doesn't hold because of NaN+   DoubleDivOp   -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))+                                      , rightIdentity oned ]+   DoubleNegOp   -> mkPrimOpRule nm 1 [ unaryLit negOp+                                      , inversePrimOp DoubleNegOp ]++   -- Relational operators++   IntEqOp    -> mkRelOpRule nm (==) [ litEq True ]+   IntNeOp    -> mkRelOpRule nm (/=) [ litEq False ]+   CharEqOp   -> mkRelOpRule nm (==) [ litEq True ]+   CharNeOp   -> mkRelOpRule nm (/=) [ litEq False ]++   IntGtOp    -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   IntGeOp    -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   IntLeOp    -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   IntLtOp    -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   CharGtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   CharGeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   CharLeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   CharLtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   FloatGtOp  -> mkFloatingRelOpRule nm (>)+   FloatGeOp  -> mkFloatingRelOpRule nm (>=)+   FloatLeOp  -> mkFloatingRelOpRule nm (<=)+   FloatLtOp  -> mkFloatingRelOpRule nm (<)+   FloatEqOp  -> mkFloatingRelOpRule nm (==)+   FloatNeOp  -> mkFloatingRelOpRule nm (/=)++   DoubleGtOp -> mkFloatingRelOpRule nm (>)+   DoubleGeOp -> mkFloatingRelOpRule nm (>=)+   DoubleLeOp -> mkFloatingRelOpRule nm (<=)+   DoubleLtOp -> mkFloatingRelOpRule nm (<)+   DoubleEqOp -> mkFloatingRelOpRule nm (==)+   DoubleNeOp -> mkFloatingRelOpRule nm (/=)++   WordGtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   WordGeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   WordLeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   WordLtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]+   WordEqOp   -> mkRelOpRule nm (==) [ litEq True ]+   WordNeOp   -> mkRelOpRule nm (/=) [ litEq False ]++   AddrAddOp  -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ]++   SeqOp      -> mkPrimOpRule nm 4 [ seqRule ]+   SparkOp    -> mkPrimOpRule nm 4 [ sparkRule ]++   _          -> Nothing++{-+************************************************************************+*                                                                      *+\subsection{Doing the business}+*                                                                      *+************************************************************************+-}++-- useful shorthands+mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule+mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)++mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)+            -> [RuleM CoreExpr] -> Maybe CoreRule+mkRelOpRule nm cmp extra+  = mkPrimOpRule nm 2 $+    binaryCmpLit cmp : equal_rule : extra+  where+        -- x `cmp` x does not depend on x, so+        -- compute it for the arbitrary value 'True'+        -- and use that result+    equal_rule = do { equalArgs+                    ; platform <- getPlatform+                    ; return (if cmp True True+                              then trueValInt  platform+                              else falseValInt platform) }++{- Note [Rules for floating-point comparisons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need different rules for floating-point values because for floats+it is not true that x = x (for NaNs); so we do not want the equal_rule+rule that mkRelOpRule uses.++Note also that, in the case of equality/inequality, we do /not/+want to switch to a case-expression.  For example, we do not want+to convert+   case (eqFloat# x 3.8#) of+     True -> this+     False -> that+to+  case x of+    3.8#::Float# -> this+    _            -> that+See #9238.  Reason: comparing floating-point values for equality+delicate, and we don't want to implement that delicacy in the code for+case expressions.  So we make it an invariant of Core that a case+expression never scrutinises a Float# or Double#.++This transformation is what the litEq rule does;+see Note [The litEq rule: converting equality to case].+So we /refrain/ from using litEq for mkFloatingRelOpRule.+-}++mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)+                    -> Maybe CoreRule+-- See Note [Rules for floating-point comparisons]+mkFloatingRelOpRule nm cmp+  = mkPrimOpRule nm 2 [binaryCmpLit cmp]++-- common constants+zeroi, onei, zerow, onew :: Platform -> Literal+zeroi platform = mkLitInt  platform 0+onei  platform = mkLitInt  platform 1+zerow platform = mkLitWord platform 0+onew  platform = mkLitWord platform 1++zerof, onef, twof, zerod, oned, twod :: Literal+zerof = mkLitFloat 0.0+onef  = mkLitFloat 1.0+twof  = mkLitFloat 2.0+zerod = mkLitDouble 0.0+oned  = mkLitDouble 1.0+twod  = mkLitDouble 2.0++cmpOp :: Platform -> (forall a . Ord a => a -> a -> Bool)+      -> Literal -> Literal -> Maybe CoreExpr+cmpOp platform cmp = go+  where+    done True  = Just $ trueValInt  platform+    done False = Just $ falseValInt platform++    -- These compares are at different types+    go (LitChar i1)   (LitChar i2)   = done (i1 `cmp` i2)+    go (LitFloat i1)  (LitFloat i2)  = done (i1 `cmp` i2)+    go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2)+    go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _)+      | nt1 /= nt2 = Nothing+      | otherwise  = done (i1 `cmp` i2)+    go _               _               = Nothing++--------------------------++negOp :: RuleOpts -> Literal -> Maybe CoreExpr  -- Negate+negOp env = \case+   (LitFloat 0.0)  -> Nothing  -- can't represent -0.0 as a Rational+   (LitFloat f)    -> Just (mkFloatVal env (-f))+   (LitDouble 0.0) -> Nothing+   (LitDouble d)   -> Just (mkDoubleVal env (-d))+   (LitNumber nt i t)+      | litNumIsSigned nt -> Just (Lit (mkLitNumberWrap (roPlatform env) nt (-i) t))+   _ -> Nothing++complementOp :: RuleOpts -> Literal -> Maybe CoreExpr  -- Binary complement+complementOp env (LitNumber nt i t) =+   Just (Lit (mkLitNumberWrap (roPlatform env) nt (complement i) t))+complementOp _      _            = Nothing++--------------------------+intOp2 :: (Integral a, Integral b)+       => (a -> b -> Integer)+       -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+intOp2 = intOp2' . const++intOp2' :: (Integral a, Integral b)+        => (RuleOpts -> a -> b -> Integer)+        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+intOp2' op env (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) =+  let o = op env+  in  intResult (roPlatform env) (fromInteger i1 `o` fromInteger i2)+intOp2' _  _      _            _            = Nothing  -- Could find LitLit++intOpC2 :: (Integral a, Integral b)+        => (a -> b -> Integer)+        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+intOpC2 op env (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do+  intCResult (roPlatform env) (fromInteger i1 `op` fromInteger i2)+intOpC2 _  _      _            _            = Nothing  -- Could find LitLit++shiftRightLogical :: Platform -> Integer -> Int -> Integer+-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do+-- Do this by converting to Word and back.  Obviously this won't work for big+-- values, but its ok as we use it here+shiftRightLogical platform x n =+    case platformWordSize platform of+      PW4 -> fromIntegral (fromInteger x `shiftR` n :: Word32)+      PW8 -> fromIntegral (fromInteger x `shiftR` n :: Word64)++--------------------------+retLit :: (Platform -> Literal) -> RuleM CoreExpr+retLit l = do platform <- getPlatform+              return $ Lit $ l platform++retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr+retLitNoC l = do platform <- getPlatform+                 let lit = l platform+                 let ty = literalType lit+                 return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi platform)]++wordOp2 :: (Integral a, Integral b)+        => (a -> b -> Integer)+        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+wordOp2 op env (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _)+    = wordResult (roPlatform env) (fromInteger w1 `op` fromInteger w2)+wordOp2 _ _ _ _ = Nothing  -- Could find LitLit++wordOpC2 :: (Integral a, Integral b)+        => (a -> b -> Integer)+        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+wordOpC2 op env (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) =+  wordCResult (roPlatform env) (fromInteger w1 `op` fromInteger w2)+wordOpC2 _ _ _ _ = Nothing  -- Could find LitLit++shiftRule :: (Platform -> Integer -> Int -> Integer) -> RuleM CoreExpr+-- Shifts take an Int; hence third arg of op is Int+-- Used for shift primops+--    ISllOp, ISraOp, ISrlOp :: Word# -> Int# -> Word#+--    SllOp, SrlOp           :: Word# -> Int# -> Word#+shiftRule shift_op+  = do { platform <- getPlatform+       ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs+       ; case e1 of+           _ | shift_len == 0+             -> return e1+             -- See Note [Guarding against silly shifts]+             | shift_len < 0 || shift_len > toInteger (platformWordSizeInBits platform)+             -> return $ Lit $ mkLitNumberWrap platform LitNumInt 0 (exprType e1)++           -- Do the shift at type Integer, but shift length is Int+           Lit (LitNumber nt x t)+             | 0 < shift_len+             , shift_len <= toInteger (platformWordSizeInBits platform)+             -> let op = shift_op platform+                    y  = x `op` fromInteger shift_len+                in  liftMaybe $ Just (Lit (mkLitNumberWrap platform nt y t))++           _ -> mzero }++--------------------------+floatOp2 :: (Rational -> Rational -> Rational)+         -> RuleOpts -> Literal -> Literal+         -> Maybe (Expr CoreBndr)+floatOp2 op env (LitFloat f1) (LitFloat f2)+  = Just (mkFloatVal env (f1 `op` f2))+floatOp2 _ _ _ _ = Nothing++--------------------------+doubleOp2 :: (Rational -> Rational -> Rational)+          -> RuleOpts -> Literal -> Literal+          -> Maybe (Expr CoreBndr)+doubleOp2 op env (LitDouble f1) (LitDouble f2)+  = Just (mkDoubleVal env (f1 `op` f2))+doubleOp2 _ _ _ _ = Nothing++--------------------------+{- Note [The litEq rule: converting equality to case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This stuff turns+     n ==# 3#+into+     case n of+       3# -> True+       m  -> False++This is a Good Thing, because it allows case-of case things+to happen, and case-default absorption to happen.  For+example:++     if (n ==# 3#) || (n ==# 4#) then e1 else e2+will transform to+     case n of+       3# -> e1+       4# -> e1+       m  -> e2+(modulo the usual precautions to avoid duplicating e1)+-}++litEq :: Bool  -- True <=> equality, False <=> inequality+      -> RuleM CoreExpr+litEq is_eq = msum+  [ do [Lit lit, expr] <- getArgs+       platform <- getPlatform+       do_lit_eq platform lit expr+  , do [expr, Lit lit] <- getArgs+       platform <- getPlatform+       do_lit_eq platform lit expr ]+  where+    do_lit_eq platform lit expr = do+      guard (not (litIsLifted lit))+      return (mkWildCase expr (literalType lit) intPrimTy+                    [(DEFAULT,    [], val_if_neq),+                     (LitAlt lit, [], val_if_eq)])+      where+        val_if_eq  | is_eq     = trueValInt  platform+                   | otherwise = falseValInt platform+        val_if_neq | is_eq     = falseValInt platform+                   | otherwise = trueValInt  platform+++-- | Check if there is comparison with minBound or maxBound, that is+-- always true or false. For instance, an Int cannot be smaller than its+-- minBound, so we can replace such comparison with False.+boundsCmp :: Comparison -> RuleM CoreExpr+boundsCmp op = do+  platform <- getPlatform+  [a, b] <- getArgs+  liftMaybe $ mkRuleFn platform op a b++data Comparison = Gt | Ge | Lt | Le++mkRuleFn :: Platform -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr+mkRuleFn platform Gt (Lit lit) _ | isMinBound platform lit = Just $ falseValInt platform+mkRuleFn platform Le (Lit lit) _ | isMinBound platform lit = Just $ trueValInt  platform+mkRuleFn platform Ge _ (Lit lit) | isMinBound platform lit = Just $ trueValInt  platform+mkRuleFn platform Lt _ (Lit lit) | isMinBound platform lit = Just $ falseValInt platform+mkRuleFn platform Ge (Lit lit) _ | isMaxBound platform lit = Just $ trueValInt  platform+mkRuleFn platform Lt (Lit lit) _ | isMaxBound platform lit = Just $ falseValInt platform+mkRuleFn platform Gt _ (Lit lit) | isMaxBound platform lit = Just $ falseValInt platform+mkRuleFn platform Le _ (Lit lit) | isMaxBound platform lit = Just $ trueValInt  platform+mkRuleFn _ _ _ _                                           = Nothing++isMinBound :: Platform -> Literal -> Bool+isMinBound _        (LitChar c)        = c == minBound+isMinBound platform (LitNumber nt i _) = case nt of+   LitNumInt     -> i == platformMinInt platform+   LitNumInt64   -> i == toInteger (minBound :: Int64)+   LitNumWord    -> i == 0+   LitNumWord64  -> i == 0+   LitNumNatural -> i == 0+   LitNumInteger -> False+isMinBound _        _                  = False++isMaxBound :: Platform -> Literal -> Bool+isMaxBound _        (LitChar c)        = c == maxBound+isMaxBound platform (LitNumber nt i _) = case nt of+   LitNumInt     -> i == platformMaxInt platform+   LitNumInt64   -> i == toInteger (maxBound :: Int64)+   LitNumWord    -> i == platformMaxWord platform+   LitNumWord64  -> i == toInteger (maxBound :: Word64)+   LitNumNatural -> False+   LitNumInteger -> False+isMaxBound _        _                  = False++-- | Create an Int literal expression while ensuring the given Integer is in the+-- target Int range+intResult :: Platform -> Integer -> Maybe CoreExpr+intResult platform result = Just (intResult' platform result)++intResult' :: Platform -> Integer -> CoreExpr+intResult' platform result = Lit (mkLitIntWrap platform result)++-- | Create an unboxed pair of an Int literal expression, ensuring the given+-- Integer is in the target Int range and the corresponding overflow flag+-- (@0#@/@1#@) if it wasn't.+intCResult :: Platform -> Integer -> Maybe CoreExpr+intCResult platform result = Just (mkPair [Lit lit, Lit c])+  where+    mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]+    (lit, b) = mkLitIntWrapC platform result+    c = if b then onei platform else zeroi platform++-- | Create a Word literal expression while ensuring the given Integer is in the+-- target Word range+wordResult :: Platform -> Integer -> Maybe CoreExpr+wordResult platform result = Just (wordResult' platform result)++wordResult' :: Platform -> Integer -> CoreExpr+wordResult' platform result = Lit (mkLitWordWrap platform result)++-- | Create an unboxed pair of a Word literal expression, ensuring the given+-- Integer is in the target Word range and the corresponding carry flag+-- (@0#@/@1#@) if it wasn't.+wordCResult :: Platform -> Integer -> Maybe CoreExpr+wordCResult platform result = Just (mkPair [Lit lit, Lit c])+  where+    mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]+    (lit, b) = mkLitWordWrapC platform result+    c = if b then onei platform else zeroi platform++inversePrimOp :: PrimOp -> RuleM CoreExpr+inversePrimOp primop = do+  [Var primop_id `App` e] <- getArgs+  matchPrimOpId primop primop_id+  return e++subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr+this `subsumesPrimOp` that = do+  [Var primop_id `App` e] <- getArgs+  matchPrimOpId that primop_id+  return (Var (mkPrimOpId this) `App` e)++subsumedByPrimOp :: PrimOp -> RuleM CoreExpr+subsumedByPrimOp primop = do+  [e@(Var primop_id `App` _)] <- getArgs+  matchPrimOpId primop primop_id+  return e++-- | narrow subsumes bitwise `and` with full mask (cf #16402):+--+--       narrowN (x .&. m)+--       m .&. (2^N-1) = 2^N-1+--       ==> narrowN x+--+-- e.g.  narrow16 (x .&. 0xFFFF)+--       ==> narrow16 x+--+narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr+narrowSubsumesAnd and_primop narrw n = do+  [Var primop_id `App` x `App` y] <- getArgs+  matchPrimOpId and_primop primop_id+  let mask = bit n -1+      g v (Lit (LitNumber _ m _)) = do+         guard (m .&. mask == mask)+         return (Var (mkPrimOpId narrw) `App` v)+      g _ _ = mzero+  g x y <|> g y x++idempotent :: RuleM CoreExpr+idempotent = do [e1, e2] <- getArgs+                guard $ cheapEqExpr e1 e2+                return e1++{-+Note [Guarding against silly shifts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this code:++  import Data.Bits( (.|.), shiftL )+  chunkToBitmap :: [Bool] -> Word32+  chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]++This optimises to:+Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->+    case w1_sCT of _ {+      [] -> 0##;+      : x_aAW xs_aAX ->+        case x_aAW of _ {+          GHC.Types.False ->+            case w_sCS of wild2_Xh {+              __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;+              9223372036854775807 -> 0## };+          GHC.Types.True ->+            case GHC.Prim.>=# w_sCS 64 of _ {+              GHC.Types.False ->+                case w_sCS of wild3_Xh {+                  __DEFAULT ->+                    case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->+                      GHC.Prim.or# (GHC.Prim.narrow32Word#+                                      (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))+                                   ww_sCW+                     };+                  9223372036854775807 ->+                    GHC.Prim.narrow32Word#+!!!!-->                  (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)+                };+              GHC.Types.True ->+                case w_sCS of wild3_Xh {+                  __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;+                  9223372036854775807 -> 0##+                } } } }++Note the massive shift on line "!!!!".  It can't happen, because we've checked+that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this!+Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we+can't constant fold it, but if it gets to the assembler we get+     Error: operand type mismatch for `shl'++So the best thing to do is to rewrite the shift with a call to error,+when the second arg is large. However, in general we cannot do this; consider+this case++    let x = I# (uncheckedIShiftL# n 80)+    in ...++Here x contains an invalid shift and consequently we would like to rewrite it+as follows:++    let x = I# (error "invalid shift)+    in ...++This was originally done in the fix to #16449 but this breaks the let/app+invariant (see Note [Core let/app invariant] in GHC.Core) as noted in #16742.+For the reasons discussed in Note [Checking versus non-checking primops] (in+the PrimOp module) there is no safe way rewrite the argument of I# such that+it bottoms.++Consequently we instead take advantage of the fact that large shifts are+undefined behavior (see associated documentation in primops.txt.pp) and+transform the invalid shift into an "obviously incorrect" value.++There are two cases:++- Shifting fixed-width things: the primops ISll, Sll, etc+  These are handled by shiftRule.++  We are happy to shift by any amount up to wordSize but no more.++- Shifting Integers: the function shiftLInteger, shiftRInteger+  from the 'integer' library.   These are handled by rule_shift_op,+  and match_Integer_shift_op.++  Here we could in principle shift by any amount, but we arbitrary+  limit the shift to 4 bits; in particular we do not want shift by a+  huge amount, which can happen in code like that above.++The two cases are more different in their code paths that is comfortable,+but that is only a historical accident.+++************************************************************************+*                                                                      *+\subsection{Vaguely generic functions}+*                                                                      *+************************************************************************+-}++mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule+-- Gives the Rule the same name as the primop itself+mkBasicRule op_name n_args rm+  = BuiltinRule { ru_name  = occNameFS (nameOccName op_name),+                  ru_fn    = op_name,+                  ru_nargs = n_args,+                  ru_try   = runRuleM rm }++newtype RuleM r = RuleM+  { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r }+  deriving (Functor)++instance Applicative RuleM where+    pure x = RuleM $ \_ _ _ _ -> Just x+    (<*>) = ap++instance Monad RuleM where+  RuleM f >>= g+    = RuleM $ \env iu fn args ->+              case f env iu fn args of+                Nothing -> Nothing+                Just r  -> runRuleM (g r) env iu fn args++instance MonadFail RuleM where+    fail _ = mzero++instance Alternative RuleM where+  empty = RuleM $ \_ _ _ _ -> Nothing+  RuleM f1 <|> RuleM f2 = RuleM $ \env iu fn args ->+    f1 env iu fn args <|> f2 env iu fn args++instance MonadPlus RuleM++getPlatform :: RuleM Platform+getPlatform = roPlatform <$> getEnv++getEnv :: RuleM RuleOpts+getEnv = RuleM $ \env _ _ _ -> Just env++liftMaybe :: Maybe a -> RuleM a+liftMaybe Nothing = mzero+liftMaybe (Just x) = return x++liftLit :: (Literal -> Literal) -> RuleM CoreExpr+liftLit f = liftLitPlatform (const f)++liftLitPlatform :: (Platform -> Literal -> Literal) -> RuleM CoreExpr+liftLitPlatform f = do+  platform <- getPlatform+  [Lit lit] <- getArgs+  return $ Lit (f platform lit)++removeOp32 :: RuleM CoreExpr+removeOp32 = do+  platform <- getPlatform+  case platformWordSize platform of+    PW4 -> do+      [e] <- getArgs+      return e+    PW8 ->+      mzero++getArgs :: RuleM [CoreExpr]+getArgs = RuleM $ \_ _ _ args -> Just args++getInScopeEnv :: RuleM InScopeEnv+getInScopeEnv = RuleM $ \_ iu _ _ -> Just iu++getFunction :: RuleM Id+getFunction = RuleM $ \_ _ fn _ -> Just fn++-- return the n-th argument of this rule, if it is a literal+-- argument indices start from 0+getLiteral :: Int -> RuleM Literal+getLiteral n = RuleM $ \_ _ _ exprs -> case drop n exprs of+  (Lit l:_) -> Just l+  _ -> Nothing++unaryLit :: (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr+unaryLit op = do+  env <- getEnv+  [Lit l] <- getArgs+  liftMaybe $ op env (convFloating env l)++binaryLit :: (RuleOpts -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr+binaryLit op = do+  env <- getEnv+  [Lit l1, Lit l2] <- getArgs+  liftMaybe $ op env (convFloating env l1) (convFloating env l2)++binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr+binaryCmpLit op = do+  platform <- getPlatform+  binaryLit (\_ -> cmpOp platform op)++leftIdentity :: Literal -> RuleM CoreExpr+leftIdentity id_lit = leftIdentityPlatform (const id_lit)++rightIdentity :: Literal -> RuleM CoreExpr+rightIdentity id_lit = rightIdentityPlatform (const id_lit)++identity :: Literal -> RuleM CoreExpr+identity lit = leftIdentity lit `mplus` rightIdentity lit++leftIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr+leftIdentityPlatform id_lit = do+  platform <- getPlatform+  [Lit l1, e2] <- getArgs+  guard $ l1 == id_lit platform+  return e2++-- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in+-- addition to the result, we have to indicate that no carry/overflow occurred.+leftIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr+leftIdentityCPlatform id_lit = do+  platform <- getPlatform+  [Lit l1, e2] <- getArgs+  guard $ l1 == id_lit platform+  let no_c = Lit (zeroi platform)+  return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c])++rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr+rightIdentityPlatform id_lit = do+  platform <- getPlatform+  [e1, Lit l2] <- getArgs+  guard $ l2 == id_lit platform+  return e1++-- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in+-- addition to the result, we have to indicate that no carry/overflow occurred.+rightIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr+rightIdentityCPlatform id_lit = do+  platform <- getPlatform+  [e1, Lit l2] <- getArgs+  guard $ l2 == id_lit platform+  let no_c = Lit (zeroi platform)+  return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c])++identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr+identityPlatform lit =+  leftIdentityPlatform lit `mplus` rightIdentityPlatform lit++-- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition+-- to the result, we have to indicate that no carry/overflow occurred.+identityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr+identityCPlatform lit =+  leftIdentityCPlatform lit `mplus` rightIdentityCPlatform lit++leftZero :: (Platform -> Literal) -> RuleM CoreExpr+leftZero zero = do+  platform <- getPlatform+  [Lit l1, _] <- getArgs+  guard $ l1 == zero platform+  return $ Lit l1++rightZero :: (Platform -> Literal) -> RuleM CoreExpr+rightZero zero = do+  platform <- getPlatform+  [_, Lit l2] <- getArgs+  guard $ l2 == zero platform+  return $ Lit l2++zeroElem :: (Platform -> Literal) -> RuleM CoreExpr+zeroElem lit = leftZero lit `mplus` rightZero lit++equalArgs :: RuleM ()+equalArgs = do+  [e1, e2] <- getArgs+  guard $ e1 `cheapEqExpr` e2++nonZeroLit :: Int -> RuleM ()+nonZeroLit n = getLiteral n >>= guard . not . isZeroLit++-- When excess precision is not requested, cut down the precision of the+-- Rational value to that of Float/Double. We confuse host architecture+-- and target architecture here, but it's convenient (and wrong :-).+convFloating :: RuleOpts -> Literal -> Literal+convFloating env (LitFloat  f) | not (roExcessRationalPrecision env) =+   LitFloat  (toRational (fromRational f :: Float ))+convFloating env (LitDouble d) | not (roExcessRationalPrecision env) =+   LitDouble (toRational (fromRational d :: Double))+convFloating _ l = l++guardFloatDiv :: RuleM ()+guardFloatDiv = do+  [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs+  guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]+       && f2 /= 0            -- avoid NaN and Infinity/-Infinity++guardDoubleDiv :: RuleM ()+guardDoubleDiv = do+  [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs+  guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]+       && d2 /= 0            -- avoid NaN and Infinity/-Infinity+-- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to+-- zero, but we might want to preserve the negative zero here which+-- is representable in Float/Double but not in (normalised)+-- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?++strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr+strengthReduction two_lit add_op = do -- Note [Strength reduction]+  arg <- msum [ do [arg, Lit mult_lit] <- getArgs+                   guard (mult_lit == two_lit)+                   return arg+              , do [Lit mult_lit, arg] <- getArgs+                   guard (mult_lit == two_lit)+                   return arg ]+  return $ Var (mkPrimOpId add_op) `App` arg `App` arg++-- Note [Strength reduction]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- This rule turns floating point multiplications of the form 2.0 * x and+-- x * 2.0 into x + x addition, because addition costs less than multiplication.+-- See #7116++-- Note [What's true and false]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- trueValInt and falseValInt represent true and false values returned by+-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.+-- True is represented as an unboxed 1# literal, while false is represented+-- as 0# literal.+-- We still need Bool data constructors (True and False) to use in a rule+-- for constant folding of equal Strings++trueValInt, falseValInt :: Platform -> Expr CoreBndr+trueValInt  platform = Lit $ onei  platform -- see Note [What's true and false]+falseValInt platform = Lit $ zeroi platform++trueValBool, falseValBool :: Expr CoreBndr+trueValBool   = Var trueDataConId -- see Note [What's true and false]+falseValBool  = Var falseDataConId++ltVal, eqVal, gtVal :: Expr CoreBndr+ltVal = Var ordLTDataConId+eqVal = Var ordEQDataConId+gtVal = Var ordGTDataConId++mkIntVal :: Platform -> Integer -> Expr CoreBndr+mkIntVal platform i = Lit (mkLitInt platform i)+mkFloatVal :: RuleOpts -> Rational -> Expr CoreBndr+mkFloatVal env f = Lit (convFloating env (LitFloat  f))+mkDoubleVal :: RuleOpts -> Rational -> Expr CoreBndr+mkDoubleVal env d = Lit (convFloating env (LitDouble d))++matchPrimOpId :: PrimOp -> Id -> RuleM ()+matchPrimOpId op id = do+  op' <- liftMaybe $ isPrimOpId_maybe id+  guard $ op == op'++{-+************************************************************************+*                                                                      *+\subsection{Special rules for seq, tagToEnum, dataToTag}+*                                                                      *+************************************************************************++Note [tagToEnum#]+~~~~~~~~~~~~~~~~~+Nasty check to ensure that tagToEnum# is applied to a type that is an+enumeration TyCon.  Unification may refine the type later, but this+check won't see that, alas.  It's crude but it works.++Here's are two cases that should fail+        f :: forall a. a+        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable++        g :: Int+        g = tagToEnum# 0        -- Int is not an enumeration++We used to make this check in the type inference engine, but it's quite+ugly to do so, because the delayed constraint solving means that we don't+really know what's going on until the end. It's very much a corner case+because we don't expect the user to call tagToEnum# at all; we merely+generate calls in derived instances of Enum.  So we compromise: a+rewrite rule rewrites a bad instance of tagToEnum# to an error call,+and emits a warning.+-}++tagToEnumRule :: RuleM CoreExpr+-- If     data T a = A | B | C+-- then   tagToEnum# (T ty) 2# -->  B ty+tagToEnumRule = do+  [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs+  case splitTyConApp_maybe ty of+    Just (tycon, tc_args) | isEnumerationTyCon tycon -> do+      let tag = fromInteger i+          correct_tag dc = (dataConTagZ dc) == tag+      (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])+      ASSERT(null rest) return ()+      return $ mkTyApps (Var (dataConWorkId dc)) tc_args++    -- See Note [tagToEnum#]+    _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )+         return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"++------------------------------+dataToTagRule :: RuleM CoreExpr+-- See Note [dataToTag#] in primops.txt.pp+dataToTagRule = a `mplus` b+  where+    -- dataToTag (tagToEnum x)   ==>   x+    a = do+      [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs+      guard $ tag_to_enum `hasKey` tagToEnumKey+      guard $ ty1 `eqType` ty2+      return tag++    -- dataToTag (K e1 e2)  ==>   tag-of K+    -- This also works (via exprIsConApp_maybe) for+    --   dataToTag x+    -- where x's unfolding is a constructor application+    b = do+      dflags <- getPlatform+      [_, val_arg] <- getArgs+      in_scope <- getInScopeEnv+      (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg+      ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()+      return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc)))++{- Note [dataToTag# magic]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The primop dataToTag# is unusual because it evaluates its argument.+Only `SeqOp` shares that property.  (Other primops do not do anything+as fancy as argument evaluation.)  The special handling for dataToTag#+is:++* GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp,+  (actually in app_ok).  Most primops with lifted arguments do not+  evaluate those arguments, but DataToTagOp and SeqOp are two+  exceptions.  We say that they are /never/ ok-for-speculation,+  regardless of the evaluated-ness of their argument.+  See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp]++* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr,+  that evaluates its argument and then extracts the tag from+  the returned value.++* An application like (dataToTag# (Just x)) is optimised by+  dataToTagRule in GHC.Core.Op.ConstantFold.++* A case expression like+     case (dataToTag# e) of <alts>+  gets transformed t+     case e of <transformed alts>+  by GHC.Core.Op.ConstantFold.caseRules; see Note [caseRules for dataToTag]++See #15696 for a long saga.+-}++{- *********************************************************************+*                                                                      *+             unsafeEqualityProof+*                                                                      *+********************************************************************* -}++-- unsafeEqualityProof k t t  ==>  UnsafeRefl (Refl t)+-- That is, if the two types are equal, it's not unsafe!++unsafeEqualityProofRule :: RuleM CoreExpr+unsafeEqualityProofRule+  = do { [Type rep, Type t1, Type t2] <- getArgs+       ; guard (t1 `eqType` t2)+       ; fn <- getFunction+       ; let (_, ue) = splitForAllTys (idType fn)+             tc      = tyConAppTyCon ue  -- tycon:    UnsafeEquality+             (dc:_)  = tyConDataCons tc  -- data con: UnsafeRefl+             -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r).+             --               UnsafeEquality r a a+       ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) }+++{- *********************************************************************+*                                                                      *+             Rules for seq# and spark#+*                                                                      *+********************************************************************* -}++{- Note [seq# magic]+~~~~~~~~~~~~~~~~~~~~+The primop+   seq# :: forall a s . a -> State# s -> (# State# s, a #)++is /not/ the same as the Prelude function seq :: a -> b -> b+as you can see from its type.  In fact, seq# is the implementation+mechanism for 'evaluate'++   evaluate :: a -> IO a+   evaluate a = IO $ \s -> seq# a s++The semantics of seq# is+  * evaluate its first argument+  * and return it++Things to note++* Why do we need a primop at all?  That is, instead of+      case seq# x s of (# x, s #) -> blah+  why not instead say this?+      case x of { DEFAULT -> blah)++  Reason (see #5129): if we saw+    catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler++  then we'd drop the 'case x' because the body of the case is bottom+  anyway. But we don't want to do that; the whole /point/ of+  seq#/evaluate is to evaluate 'x' first in the IO monad.++  In short, we /always/ evaluate the first argument and never+  just discard it.++* Why return the value?  So that we can control sharing of seq'd+  values: in+     let x = e in x `seq` ... x ...+  We don't want to inline x, so better to represent it as+       let x = e in case seq# x RW of (# _, x' #) -> ... x' ...+  also it matches the type of rseq in the Eval monad.++Implementing seq#.  The compiler has magic for SeqOp in++- GHC.Core.Op.ConstantFold.seqRule: eliminate (seq# <whnf> s)++- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#++- GHC.Core.Utils.exprOkForSpeculation;+  see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils++- Simplify.addEvals records evaluated-ness for the result; see+  Note [Adding evaluatedness info to pattern-bound variables]+  in GHC.Core.Op.Simplify+-}++seqRule :: RuleM CoreExpr+seqRule = do+  [Type ty_a, Type _ty_s, a, s] <- getArgs+  guard $ exprIsHNF a+  return $ mkCoreUbxTup [exprType s, ty_a] [s, a]++-- spark# :: forall a s . a -> State# s -> (# State# s, a #)+sparkRule :: RuleM CoreExpr+sparkRule = seqRule -- reduce on HNF, just the same+  -- XXX perhaps we shouldn't do this, because a spark eliminated by+  -- this rule won't be counted as a dud at runtime?++{-+************************************************************************+*                                                                      *+\subsection{Built in rules}+*                                                                      *+************************************************************************++Note [Scoping for Builtin rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When compiling a (base-package) module that defines one of the+functions mentioned in the RHS of a built-in rule, there's a danger+that we'll see++        f = ...(eq String x)....++        ....and lower down...++        eqString = ...++Then a rewrite would give++        f = ...(eqString x)...+        ....and lower down...+        eqString = ...++and lo, eqString is not in scope.  This only really matters when we+get to code generation.  But the occurrence analyser does a GlomBinds+step when necessary, that does a new SCC analysis on the whole set of+bindings (see occurAnalysePgm), which sorts out the dependency, so all+is fine.+-}++builtinRules :: [CoreRule]+-- Rules for non-primops that can't be expressed using a RULE pragma+builtinRules+  = [BuiltinRule { ru_name = fsLit "AppendLitString",+                   ru_fn = unpackCStringFoldrName,+                   ru_nargs = 4, ru_try = match_append_lit },+     BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,+                   ru_nargs = 2, ru_try = match_eq_string },+     BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,+                   ru_nargs = 2, ru_try = \_ _ _ -> match_inline },+     BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,+                   ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict },++     mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule,++     mkBasicRule divIntName 2 $ msum+        [ nonZeroLit 1 >> binaryLit (intOp2 div)+        , leftZero zeroi+        , do+          [arg, Lit (LitNumber LitNumInt d _)] <- getArgs+          Just n <- return $ exactLog2 d+          platform <- getPlatform+          return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal platform n+        ],++     mkBasicRule modIntName 2 $ msum+        [ nonZeroLit 1 >> binaryLit (intOp2 mod)+        , leftZero zeroi+        , do+          [arg, Lit (LitNumber LitNumInt d _)] <- getArgs+          Just _ <- return $ exactLog2 d+          platform <- getPlatform+          return $ Var (mkPrimOpId AndIOp)+            `App` arg `App` mkIntVal platform (d - 1)+        ]+     ]+ ++ builtinIntegerRules+ ++ builtinNaturalRules+{-# NOINLINE builtinRules #-}+-- there is no benefit to inlining these yet, despite this, GHC produces+-- unfoldings for this regardless since the floated list entries look small.++builtinIntegerRules :: [CoreRule]+builtinIntegerRules =+ [rule_IntToInteger   "smallInteger"        smallIntegerName,+  rule_WordToInteger  "wordToInteger"       wordToIntegerName,+  rule_Int64ToInteger  "int64ToInteger"     int64ToIntegerName,+  rule_Word64ToInteger "word64ToInteger"    word64ToIntegerName,+  rule_convert        "integerToWord"       integerToWordName       mkWordLitWord,+  rule_convert        "integerToInt"        integerToIntName        mkIntLitInt,+  rule_convert        "integerToWord64"     integerToWord64Name     (\_ -> mkWord64LitWord64),+  rule_convert        "integerToInt64"      integerToInt64Name      (\_ -> mkInt64LitInt64),+  rule_binop          "plusInteger"         plusIntegerName         (+),+  rule_binop          "minusInteger"        minusIntegerName        (-),+  rule_binop          "timesInteger"        timesIntegerName        (*),+  rule_unop           "negateInteger"       negateIntegerName       negate,+  rule_binop_Prim     "eqInteger#"          eqIntegerPrimName       (==),+  rule_binop_Prim     "neqInteger#"         neqIntegerPrimName      (/=),+  rule_unop           "absInteger"          absIntegerName          abs,+  rule_unop           "signumInteger"       signumIntegerName       signum,+  rule_binop_Prim     "leInteger#"          leIntegerPrimName       (<=),+  rule_binop_Prim     "gtInteger#"          gtIntegerPrimName       (>),+  rule_binop_Prim     "ltInteger#"          ltIntegerPrimName       (<),+  rule_binop_Prim     "geInteger#"          geIntegerPrimName       (>=),+  rule_binop_Ordering "compareInteger"      compareIntegerName      compare,+  rule_encodeFloat    "encodeFloatInteger"  encodeFloatIntegerName  mkFloatLitFloat,+  rule_convert        "floatFromInteger"    floatFromIntegerName    (\_ -> mkFloatLitFloat),+  rule_encodeFloat    "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,+  rule_decodeDouble   "decodeDoubleInteger" decodeDoubleIntegerName,+  rule_convert        "doubleFromInteger"   doubleFromIntegerName   (\_ -> mkDoubleLitDouble),+  rule_rationalTo     "rationalToFloat"     rationalToFloatName     mkFloatExpr,+  rule_rationalTo     "rationalToDouble"    rationalToDoubleName    mkDoubleExpr,+  rule_binop          "gcdInteger"          gcdIntegerName          gcd,+  rule_binop          "lcmInteger"          lcmIntegerName          lcm,+  rule_binop          "andInteger"          andIntegerName          (.&.),+  rule_binop          "orInteger"           orIntegerName           (.|.),+  rule_binop          "xorInteger"          xorIntegerName          xor,+  rule_unop           "complementInteger"   complementIntegerName   complement,+  rule_shift_op       "shiftLInteger"       shiftLIntegerName       shiftL,+  rule_shift_op       "shiftRInteger"       shiftRIntegerName       shiftR,+  rule_bitInteger     "bitInteger"          bitIntegerName,+  -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs+  rule_divop_one      "quotInteger"         quotIntegerName         quot,+  rule_divop_one      "remInteger"          remIntegerName          rem,+  rule_divop_one      "divInteger"          divIntegerName          div,+  rule_divop_one      "modInteger"          modIntegerName          mod,+  rule_divop_both     "divModInteger"       divModIntegerName       divMod,+  rule_divop_both     "quotRemInteger"      quotRemIntegerName      quotRem,+  -- These rules below don't actually have to be built in, but if we+  -- put them in the Haskell source then we'd have to duplicate them+  -- between all Integer implementations+  rule_XToIntegerToX "smallIntegerToInt"       integerToIntName    smallIntegerName,+  rule_XToIntegerToX "wordToIntegerToWord"     integerToWordName   wordToIntegerName,+  rule_XToIntegerToX "int64ToIntegerToInt64"   integerToInt64Name  int64ToIntegerName,+  rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName,+  rule_smallIntegerTo "smallIntegerToWord"   integerToWordName     Int2WordOp,+  rule_smallIntegerTo "smallIntegerToFloat"  floatFromIntegerName  Int2FloatOp,+  rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp+  ]+    where rule_convert str name convert+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_Integer_convert convert }+          rule_IntToInteger str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_IntToInteger }+          rule_WordToInteger str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_WordToInteger }+          rule_Int64ToInteger str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_Int64ToInteger }+          rule_Word64ToInteger str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_Word64ToInteger }+          rule_unop str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_Integer_unop op }+          rule_bitInteger str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_bitInteger }+          rule_binop str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Integer_binop op }+          rule_divop_both str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Integer_divop_both op }+          rule_divop_one str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Integer_divop_one op }+          rule_shift_op str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Integer_shift_op op }+          rule_binop_Prim str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Integer_binop_Prim op }+          rule_binop_Ordering str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Integer_binop_Ordering op }+          rule_encodeFloat str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Integer_Int_encodeFloat op }+          rule_decodeDouble str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_decodeDouble }+          rule_XToIntegerToX str name toIntegerName+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_XToIntegerToX toIntegerName }+          rule_smallIntegerTo str name primOp+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_smallIntegerTo primOp }+          rule_rationalTo str name mkLit+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_rationalTo mkLit }++builtinNaturalRules :: [CoreRule]+builtinNaturalRules =+ [rule_binop              "plusNatural"        plusNaturalName         (+)+ ,rule_partial_binop      "minusNatural"       minusNaturalName        (\a b -> if a >= b then Just (a - b) else Nothing)+ ,rule_binop              "timesNatural"       timesNaturalName        (*)+ ,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName+ ,rule_NaturalToInteger   "naturalToInteger"   naturalToIntegerName+ ,rule_WordToNatural      "wordToNatural"      wordToNaturalName+ ]+    where rule_binop str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Natural_binop op }+          rule_partial_binop str name op+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,+                           ru_try = match_Natural_partial_binop op }+          rule_NaturalToInteger str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_NaturalToInteger }+          rule_NaturalFromInteger str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_NaturalFromInteger }+          rule_WordToNatural str name+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,+                           ru_try = match_WordToNatural }++---------------------------------------------------+-- The rule is this:+--      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)+--      =  unpackFoldrCString# "foobaz" c n++match_append_lit :: RuleFun+match_append_lit _ id_unf _+        [ Type ty1+        , lit1+        , c1+        , e2+        ]+  -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the+  -- `lit` and `c` arguments, lest this may fail to fire when building with+  -- -g3. See #16740.+  | (strTicks, Var unpk `App` Type ty2+                        `App` lit2+                        `App` c2+                        `App` n) <- stripTicksTop tickishFloatable e2+  , unpk `hasKey` unpackCStringFoldrIdKey+  , cheapEqExpr' tickishFloatable c1 c2+  , (c1Ticks, c1') <- stripTicksTop tickishFloatable c1+  , c2Ticks <- stripTicksTopT tickishFloatable c2+  , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1+  , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2+  = ASSERT( ty1 `eqType` ty2 )+    Just $ mkTicks strTicks+         $ Var unpk `App` Type ty1+                    `App` Lit (LitString (s1 `BS.append` s2))+                    `App` mkTicks (c1Ticks ++ c2Ticks) c1'+                    `App` n++match_append_lit _ _ _ _ = Nothing++---------------------------------------------------+-- The rule is this:+--      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2++match_eq_string :: RuleFun+match_eq_string _ id_unf _+        [Var unpk1 `App` lit1, Var unpk2 `App` lit2]+  | unpk1 `hasKey` unpackCStringIdKey+  , unpk2 `hasKey` unpackCStringIdKey+  , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1+  , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2+  = Just (if s1 == s2 then trueValBool else falseValBool)++match_eq_string _ _ _ _ = Nothing+++---------------------------------------------------+-- The rule is this:+--      inline f_ty (f a b c) = <f's unfolding> a b c+-- (if f has an unfolding, EVEN if it's a loop breaker)+--+-- It's important to allow the argument to 'inline' to have args itself+-- (a) because its more forgiving to allow the programmer to write+--       inline f a b c+--   or  inline (f a b c)+-- (b) because a polymorphic f wll get a type argument that the+--     programmer can't avoid+--+-- Also, don't forget about 'inline's type argument!+match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)+match_inline (Type _ : e : _)+  | (Var f, args1) <- collectArgs e,+    Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)+             -- Ignore the IdUnfoldingFun here!+  = Just (mkApps unf args1)++match_inline _ = Nothing+++-- See Note [magicDictId magic] in `basicTypes/MkId.hs`+-- for a description of what is going on here.+match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)+match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ]+  | Just (fieldTy, _)   <- splitFunTy_maybe $ dropForAlls $ idType wrap+  , Just (dictTy, _)    <- splitFunTy_maybe fieldTy+  , Just dictTc         <- tyConAppTyCon_maybe dictTy+  , Just (_,_,co)       <- unwrapNewTyCon_maybe dictTc+  = Just+  $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] []))+      `App` y++match_magicDict _ = Nothing++-------------------------------------------------+-- Integer rules+--   smallInteger  (79::Int#)  = 79::Integer+--   wordToInteger (79::Word#) = 79::Integer+-- Similarly Int64, Word64++match_IntToInteger :: RuleFun+match_IntToInteger = match_IntToInteger_unop id++match_WordToInteger :: RuleFun+match_WordToInteger _ id_unf id [xl]+  | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl+  = case splitFunTy_maybe (idType id) of+    Just (_, integerTy) ->+        Just (Lit (mkLitInteger x integerTy))+    _ ->+        panic "match_WordToInteger: Id has the wrong type"+match_WordToInteger _ _ _ _ = Nothing++match_Int64ToInteger :: RuleFun+match_Int64ToInteger _ id_unf id [xl]+  | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl+  = case splitFunTy_maybe (idType id) of+    Just (_, integerTy) ->+        Just (Lit (mkLitInteger x integerTy))+    _ ->+        panic "match_Int64ToInteger: Id has the wrong type"+match_Int64ToInteger _ _ _ _ = Nothing++match_Word64ToInteger :: RuleFun+match_Word64ToInteger _ id_unf id [xl]+  | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl+  = case splitFunTy_maybe (idType id) of+    Just (_, integerTy) ->+        Just (Lit (mkLitInteger x integerTy))+    _ ->+        panic "match_Word64ToInteger: Id has the wrong type"+match_Word64ToInteger _ _ _ _ = Nothing++match_NaturalToInteger :: RuleFun+match_NaturalToInteger _ id_unf id [xl]+  | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl+  = case splitFunTy_maybe (idType id) of+    Just (_, naturalTy) ->+        Just (Lit (LitNumber LitNumInteger x naturalTy))+    _ ->+        panic "match_NaturalToInteger: Id has the wrong type"+match_NaturalToInteger _ _ _ _ = Nothing++match_NaturalFromInteger :: RuleFun+match_NaturalFromInteger _ id_unf id [xl]+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl+  , x >= 0+  = case splitFunTy_maybe (idType id) of+    Just (_, naturalTy) ->+        Just (Lit (LitNumber LitNumNatural x naturalTy))+    _ ->+        panic "match_NaturalFromInteger: Id has the wrong type"+match_NaturalFromInteger _ _ _ _ = Nothing++match_WordToNatural :: RuleFun+match_WordToNatural _ id_unf id [xl]+  | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl+  = case splitFunTy_maybe (idType id) of+    Just (_, naturalTy) ->+        Just (Lit (LitNumber LitNumNatural x naturalTy))+    _ ->+        panic "match_WordToNatural: Id has the wrong type"+match_WordToNatural _ _ _ _ = Nothing++-------------------------------------------------+{- Note [Rewriting bitInteger]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For most types the bitInteger operation can be implemented in terms of shifts.+The integer-gmp package, however, can do substantially better than this if+allowed to provide its own implementation. However, in so doing it previously lost+constant-folding (see #8832). The bitInteger rule above provides constant folding+specifically for this function.++There is, however, a bit of trickiness here when it comes to ranges. While the+AST encodes all integers as Integers, `bit` expects the bit+index to be given as an Int. Hence we coerce to an Int in the rule definition.+This will behave a bit funny for constants larger than the word size, but the user+should expect some funniness given that they will have at very least ignored a+warning in this case.+-}++match_bitInteger :: RuleFun+-- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer+match_bitInteger env id_unf fn [arg]+  | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg+  , x >= 0+  , x <= (toInteger (platformWordSizeInBits (roPlatform env)) - 1)+    -- Make sure x is small enough to yield a decently small integer+    -- Attempting to construct the Integer for+    --    (bitInteger 9223372036854775807#)+    -- would be a bad idea (#14959)+  , let x_int = fromIntegral x :: Int+  = case splitFunTy_maybe (idType fn) of+    Just (_, integerTy)+      -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy))+    _ -> panic "match_IntToInteger_unop: Id has the wrong type"++match_bitInteger _ _ _ _ = Nothing+++-------------------------------------------------+match_Integer_convert :: Num a+                      => (Platform -> a -> Expr CoreBndr)+                      -> RuleFun+match_Integer_convert convert env id_unf _ [xl]+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl+  = Just (convert (roPlatform env) (fromInteger x))+match_Integer_convert _ _ _ _ _ = Nothing++match_Integer_unop :: (Integer -> Integer) -> RuleFun+match_Integer_unop unop _ id_unf _ [xl]+  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl+  = Just (Lit (LitNumber LitNumInteger (unop x) i))+match_Integer_unop _ _ _ _ _ = Nothing++match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun+match_IntToInteger_unop unop _ id_unf fn [xl]+  | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl+  = case splitFunTy_maybe (idType fn) of+    Just (_, integerTy) ->+        Just (Lit (LitNumber LitNumInteger (unop x) integerTy))+    _ ->+        panic "match_IntToInteger_unop: Id has the wrong type"+match_IntToInteger_unop _ _ _ _ _ = Nothing++match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun+match_Integer_binop binop _ id_unf _ [xl,yl]+  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl+  = Just (Lit (mkLitInteger (x `binop` y) i))+match_Integer_binop _ _ _ _ _ = Nothing++match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun+match_Natural_binop binop _ id_unf _ [xl,yl]+  | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl+  , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl+  = Just (Lit (mkLitNatural (x `binop` y) i))+match_Natural_binop _ _ _ _ _ = Nothing++match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun+match_Natural_partial_binop binop _ id_unf _ [xl,yl]+  | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl+  , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl+  , Just z <- x `binop` y+  = Just (Lit (mkLitNatural z i))+match_Natural_partial_binop _ _ _ _ _ = Nothing++-- This helper is used for the quotRem and divMod functions+match_Integer_divop_both+   :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun+match_Integer_divop_both divop _ id_unf _ [xl,yl]+  | Just (LitNumber LitNumInteger x t) <- exprIsLiteral_maybe id_unf xl+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl+  , y /= 0+  , (r,s) <- x `divop` y+  = Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)]+match_Integer_divop_both _ _ _ _ _ = Nothing++-- This helper is used for the quot and rem functions+match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun+match_Integer_divop_one divop _ id_unf _ [xl,yl]+  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl+  , y /= 0+  = Just (Lit (mkLitInteger (x `divop` y) i))+match_Integer_divop_one _ _ _ _ _ = Nothing++match_Integer_shift_op :: (Integer -> Int -> Integer) -> RuleFun+-- Used for shiftLInteger, shiftRInteger :: Integer -> Int# -> Integer+-- See Note [Guarding against silly shifts]+match_Integer_shift_op binop _ id_unf _ [xl,yl]+  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl+  , Just (LitNumber LitNumInt y _)     <- exprIsLiteral_maybe id_unf yl+  , y >= 0+  , y <= 4   -- Restrict constant-folding of shifts on Integers, somewhat+             -- arbitrary.  We can get huge shifts in inaccessible code+             -- (#15673)+  = Just (Lit (mkLitInteger (x `binop` fromIntegral y) i))+match_Integer_shift_op _ _ _ _ _ = Nothing++match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun+match_Integer_binop_Prim binop env id_unf _ [xl, yl]+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl+  = Just (if x `binop` y then trueValInt (roPlatform env) else falseValInt (roPlatform env))+match_Integer_binop_Prim _ _ _ _ _ = Nothing++match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun+match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl+  = Just $ case x `binop` y of+             LT -> ltVal+             EQ -> eqVal+             GT -> gtVal+match_Integer_binop_Ordering _ _ _ _ _ = Nothing++match_Integer_Int_encodeFloat :: RealFloat a+                              => (a -> Expr CoreBndr)+                              -> RuleFun+match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl+  , Just (LitNumber LitNumInt y _)     <- exprIsLiteral_maybe id_unf yl+  = Just (mkLit $ encodeFloat x (fromInteger y))+match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing++---------------------------------------------------+-- constant folding for Float/Double+--+-- This turns+--      rationalToFloat n d+-- into a literal Float, and similarly for Doubles.+--+-- it's important to not match d == 0, because that may represent a+-- literal "0/0" or similar, and we can't produce a literal value for+-- NaN or +-Inf+match_rationalTo :: RealFloat a+                 => (a -> Expr CoreBndr)+                 -> RuleFun+match_rationalTo mkLit _ id_unf _ [xl, yl]+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl+  , y /= 0+  = Just (mkLit (fromRational (x % y)))+match_rationalTo _ _ _ _ _ = Nothing++match_decodeDouble :: RuleFun+match_decodeDouble env id_unf fn [xl]+  | Just (LitDouble x) <- exprIsLiteral_maybe id_unf xl+  = case splitFunTy_maybe (idType fn) of+    Just (_, res)+      | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res+      -> case decodeFloat (fromRational x :: Double) of+           (y, z) ->+             Just $ mkCoreUbxTup [integerTy, intHashTy]+                                 [Lit (mkLitInteger y integerTy),+                                  Lit (mkLitInt (roPlatform env) (toInteger z))]+    _ ->+        pprPanic "match_decodeDouble: Id has the wrong type"+          (ppr fn <+> dcolon <+> ppr (idType fn))+match_decodeDouble _ _ _ _ = Nothing++match_XToIntegerToX :: Name -> RuleFun+match_XToIntegerToX n _ _ _ [App (Var x) y]+  | idName x == n+  = Just y+match_XToIntegerToX _ _ _ _ _ = Nothing++match_smallIntegerTo :: PrimOp -> RuleFun+match_smallIntegerTo primOp _ _ _ [App (Var x) y]+  | idName x == smallIntegerName+  = Just $ App (Var (mkPrimOpId primOp)) y+match_smallIntegerTo _ _ _ _ _ = Nothing++++--------------------------------------------------------+-- Note [Constant folding through nested expressions]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We use rewrites rules to perform constant folding. It means that we don't+-- have a global view of the expression we are trying to optimise. As a+-- consequence we only perform local (small-step) transformations that either:+--    1) reduce the number of operations+--    2) rearrange the expression to increase the odds that other rules will+--    match+--+-- We don't try to handle more complex expression optimisation cases that would+-- require a global view. For example, rewriting expressions to increase+-- sharing (e.g., Horner's method); optimisations that require local+-- transformations increasing the number of operations; rearrangements to+-- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0).+--+-- We already have rules to perform constant folding on expressions with the+-- following shape (where a and/or b are literals):+--+--          D)    op+--                /\+--               /  \+--              /    \+--             a      b+--+-- To support nested expressions, we match three other shapes of expression+-- trees:+--+-- A)   op1          B)       op1       C)       op1+--      /\                    /\                 /\+--     /  \                  /  \               /  \+--    /    \                /    \             /    \+--   a     op2            op2     c          op2    op3+--          /\            /\                 /\      /\+--         /  \          /  \               /  \    /  \+--        b    c        a    b             a    b  c    d+--+--+-- R1) +/- simplification:+--    ops = + or -, two literals (not siblings)+--+--    Examples:+--       A: 5 + (10-x)  ==> 15-x+--       B: (10+x) + 5  ==> 15+x+--       C: (5+a)-(5-b) ==> 0+(a+b)+--+-- R2) * simplification+--    ops = *, two literals (not siblings)+--+--    Examples:+--       A: 5 * (10*x)  ==> 50*x+--       B: (10*x) * 5  ==> 50*x+--       C: (5*a)*(5*b) ==> 25*(a*b)+--+-- R3) * distribution over +/-+--    op1 = *, op2 = + or -, two literals (not siblings)+--+--    This transformation doesn't reduce the number of operations but switches+--    the outer and the inner operations so that the outer is (+) or (-) instead+--    of (*). It increases the odds that other rules will match after this one.+--+--    Examples:+--       A: 5 * (10-x)  ==> 50 - (5*x)+--       B: (10+x) * 5  ==> 50 + (5*x)+--       C: Not supported as it would increase the number of operations:+--          (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b+--+-- R4) Simple factorization+--+--    op1 = + or -, op2/op3 = *,+--    one literal for each innermost * operation (except in the D case),+--    the two other terms are equals+--+--    Examples:+--       A: x - (10*x)  ==> (-9)*x+--       B: (10*x) + x  ==> 11*x+--       C: (5*x)-(x*3) ==> 2*x+--       D: x+x         ==> 2*x+--+-- R5) +/- propagation+--+--    ops = + or -, one literal+--+--    This transformation doesn't reduce the number of operations but propagates+--    the constant to the outer level. It increases the odds that other rules+--    will match after this one.+--+--    Examples:+--       A: x - (10-y)  ==> (x+y) - 10+--       B: (10+x) - y  ==> 10 + (x-y)+--       C: N/A (caught by the A and B cases)+--+--------------------------------------------------------++-- | Rules to perform constant folding into nested expressions+--+--See Note [Constant folding through nested expressions]+numFoldingRules :: PrimOp -> (Platform -> PrimOps) -> RuleM CoreExpr+numFoldingRules op dict = do+  env <- getEnv+  if not (roNumConstantFolding env)+   then mzero+   else do+    [e1,e2] <- getArgs+    platform <- getPlatform+    let PrimOps{..} = dict platform+    case BinOpApp e1 op e2 of+     -- R1) +/- simplification+     x    :++: (y :++: v)          -> return $ mkL (x+y)   `add` v+     x    :++: (L y :-: v)         -> return $ mkL (x+y)   `sub` v+     x    :++: (v   :-: L y)       -> return $ mkL (x-y)   `add` v+     L x  :-:  (y :++: v)          -> return $ mkL (x-y)   `sub` v+     L x  :-:  (L y :-: v)         -> return $ mkL (x-y)   `add` v+     L x  :-:  (v   :-: L y)       -> return $ mkL (x+y)   `sub` v++     (y :++: v)    :-: L x         -> return $ mkL (y-x)   `add` v+     (L y :-: v)   :-: L x         -> return $ mkL (y-x)   `sub` v+     (v   :-: L y) :-: L x         -> return $ mkL (0-y-x) `add` v++     (x :++: w)  :+: (y :++: v)    -> return $ mkL (x+y)   `add` (w `add` v)+     (w :-: L x) :+: (L y :-: v)   -> return $ mkL (y-x)   `add` (w `sub` v)+     (w :-: L x) :+: (v   :-: L y) -> return $ mkL (0-x-y) `add` (w `add` v)+     (L x :-: w) :+: (L y :-: v)   -> return $ mkL (x+y)   `sub` (w `add` v)+     (L x :-: w) :+: (v   :-: L y) -> return $ mkL (x-y)   `add` (v `sub` w)+     (w :-: L x) :+: (y :++: v)    -> return $ mkL (y-x)   `add` (w `add` v)+     (L x :-: w) :+: (y :++: v)    -> return $ mkL (x+y)   `add` (v `sub` w)+     (y :++: v)  :+: (w :-: L x)   -> return $ mkL (y-x)   `add` (w `add` v)+     (y :++: v)  :+: (L x :-: w)   -> return $ mkL (x+y)   `add` (v `sub` w)++     (v   :-: L y) :-: (w :-: L x) -> return $ mkL (x-y)   `add` (v `sub` w)+     (v   :-: L y) :-: (L x :-: w) -> return $ mkL (0-x-y) `add` (v `add` w)+     (L y :-:   v) :-: (w :-: L x) -> return $ mkL (x+y)   `sub` (v `add` w)+     (L y :-:   v) :-: (L x :-: w) -> return $ mkL (y-x)   `add` (w `sub` v)+     (x :++: w)    :-: (y :++: v)  -> return $ mkL (x-y)   `add` (w `sub` v)+     (w :-: L x)   :-: (y :++: v)  -> return $ mkL (0-y-x) `add` (w `sub` v)+     (L x :-: w)   :-: (y :++: v)  -> return $ mkL (x-y)   `sub` (v `add` w)+     (y :++: v)    :-: (w :-: L x) -> return $ mkL (y+x)   `add` (v `sub` w)+     (y :++: v)    :-: (L x :-: w) -> return $ mkL (y-x)   `add` (v `add` w)++     -- R2) * simplification+     x :**: (y :**: v)             -> return $ mkL (x*y)   `mul` v+     (x :**: w) :*: (y :**: v)     -> return $ mkL (x*y)   `mul` (w `mul` v)++     -- R3) * distribution over +/-+     x :**: (y :++: v)             -> return $ mkL (x*y)   `add` (mkL x `mul` v)+     x :**: (L y :-: v)            -> return $ mkL (x*y)   `sub` (mkL x `mul` v)+     x :**: (v   :-: L y)          -> return $ (mkL x `mul` v) `sub` mkL (x*y)++     -- R4) Simple factorization+     v :+: w+      | w `cheapEqExpr` v          -> return $ mkL 2       `mul` v+     w :+: (y :**: v)+      | w `cheapEqExpr` v          -> return $ mkL (1+y)   `mul` v+     w :-: (y :**: v)+      | w `cheapEqExpr` v          -> return $ mkL (1-y)   `mul` v+     (y :**: v) :+: w+      | w `cheapEqExpr` v          -> return $ mkL (y+1)   `mul` v+     (y :**: v) :-: w+      | w `cheapEqExpr` v          -> return $ mkL (y-1)   `mul` v+     (x :**: w) :+: (y :**: v)+      | w `cheapEqExpr` v          -> return $ mkL (x+y)   `mul` v+     (x :**: w) :-: (y :**: v)+      | w `cheapEqExpr` v          -> return $ mkL (x-y)   `mul` v++     -- R5) +/- propagation+     w  :+: (y :++: v)             -> return $ mkL y `add` (w `add` v)+     (y :++: v) :+: w              -> return $ mkL y       `add` (w `add` v)+     w  :-: (y :++: v)             -> return $ (w `sub` v) `sub` mkL y+     (y :++: v) :-: w              -> return $ mkL y       `add` (v `sub` w)+     w    :-: (L y :-: v)          -> return $ (w `add` v) `sub` mkL y+     (L y :-: v) :-: w             -> return $ mkL y       `sub` (w `add` v)+     w    :+: (L y :-: v)          -> return $ mkL y       `add` (w `sub` v)+     w    :+: (v :-: L y)          -> return $ (w `add` v) `sub` mkL y+     (L y :-: v) :+: w             -> return $ mkL y       `add` (w `sub` v)+     (v :-: L y) :+: w             -> return $ (w `add` v) `sub` mkL y++     _                             -> mzero++++-- | Match the application of a binary primop+pattern BinOpApp  :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr+pattern BinOpApp  x op y =  OpVal op `App` x `App` y++-- | Match a primop+pattern OpVal   :: PrimOp  -> Arg CoreBndr+pattern OpVal   op     <- Var (isPrimOpId_maybe -> Just op) where+   OpVal op = Var (mkPrimOpId op)++++-- | Match a literal+pattern L :: Integer -> Arg CoreBndr+pattern L l <- Lit (isLitValue_maybe -> Just l)++-- | Match an addition+pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr+pattern x :+: y <- BinOpApp x (isAddOp -> True) y++-- | Match an addition with a literal (handle commutativity)+pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr+pattern l :++: x <- (isAdd -> Just (l,x))++isAdd :: CoreExpr -> Maybe (Integer,CoreExpr)+isAdd e = case e of+   L l :+: x   -> Just (l,x)+   x   :+: L l -> Just (l,x)+   _           -> Nothing++-- | Match a multiplication+pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr+pattern x :*: y <- BinOpApp x (isMulOp -> True) y++-- | Match a multiplication with a literal (handle commutativity)+pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr+pattern l :**: x <- (isMul -> Just (l,x))++isMul :: CoreExpr -> Maybe (Integer,CoreExpr)+isMul e = case e of+   L l :*: x   -> Just (l,x)+   x   :*: L l -> Just (l,x)+   _           -> Nothing+++-- | Match a subtraction+pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr+pattern x :-: y <- BinOpApp x (isSubOp -> True) y++isSubOp :: PrimOp -> Bool+isSubOp IntSubOp  = True+isSubOp WordSubOp = True+isSubOp _         = False++isAddOp :: PrimOp -> Bool+isAddOp IntAddOp  = True+isAddOp WordAddOp = True+isAddOp _         = False++isMulOp :: PrimOp -> Bool+isMulOp IntMulOp  = True+isMulOp WordMulOp = True+isMulOp _         = False++-- | Explicit "type-class"-like dictionary for numeric primops+--+-- Depends on Platform because creating a literal value depends on Platform+data PrimOps = PrimOps+   { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers+   , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers+   , mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers+   , mkL :: Integer -> CoreExpr              -- ^ Create a literal value+   }++intPrimOps :: Platform -> PrimOps+intPrimOps platform = PrimOps+   { add = \x y -> BinOpApp x IntAddOp y+   , sub = \x y -> BinOpApp x IntSubOp y+   , mul = \x y -> BinOpApp x IntMulOp y+   , mkL = intResult' platform+   }++wordPrimOps :: Platform -> PrimOps+wordPrimOps platform = PrimOps+   { add = \x y -> BinOpApp x WordAddOp y+   , sub = \x y -> BinOpApp x WordSubOp y+   , mul = \x y -> BinOpApp x WordMulOp y+   , mkL = wordResult' platform+   }+++--------------------------------------------------------+-- Constant folding through case-expressions+--+-- cf Scrutinee Constant Folding in simplCore/GHC.Core.Op.Simplify.Utils+--------------------------------------------------------++-- | Match the scrutinee of a case and potentially return a new scrutinee and a+-- function to apply to each literal alternative.+caseRules :: Platform+          -> CoreExpr                       -- Scrutinee+          -> Maybe ( CoreExpr               -- New scrutinee+                   , AltCon -> Maybe AltCon -- How to fix up the alt pattern+                                            --   Nothing <=> Unreachable+                                            -- See Note [Unreachable caseRules alternatives]+                   , Id -> CoreExpr)        -- How to reconstruct the original scrutinee+                                            -- from the new case-binder+-- e.g  case e of b {+--         ...;+--         con bs -> rhs;+--         ... }+--  ==>+--      case e' of b' {+--         ...;+--         fixup_altcon[con] bs -> let b = mk_orig[b] in rhs;+--         ... }++caseRules platform (App (App (Var f) v) (Lit l))   -- v `op` x#+  | Just op <- isPrimOpId_maybe f+  , Just x  <- isLitValue_maybe l+  , Just adjust_lit <- adjustDyadicRight op x+  = Just (v, tx_lit_con platform adjust_lit+           , \v -> (App (App (Var f) (Var v)) (Lit l)))++caseRules platform (App (App (Var f) (Lit l)) v)   -- x# `op` v+  | Just op <- isPrimOpId_maybe f+  , Just x  <- isLitValue_maybe l+  , Just adjust_lit <- adjustDyadicLeft x op+  = Just (v, tx_lit_con platform adjust_lit+           , \v -> (App (App (Var f) (Lit l)) (Var v)))+++caseRules platform (App (Var f) v              )   -- op v+  | Just op <- isPrimOpId_maybe f+  , Just adjust_lit <- adjustUnary op+  = Just (v, tx_lit_con platform adjust_lit+           , \v -> App (Var f) (Var v))++-- See Note [caseRules for tagToEnum]+caseRules platform (App (App (Var f) type_arg) v)+  | Just TagToEnumOp <- isPrimOpId_maybe f+  = Just (v, tx_con_tte platform+           , \v -> (App (App (Var f) type_arg) (Var v)))++-- See Note [caseRules for dataToTag]+caseRules _ (App (App (Var f) (Type ty)) v)       -- dataToTag x+  | Just DataToTagOp <- isPrimOpId_maybe f+  , Just (tc, _) <- tcSplitTyConApp_maybe ty+  , isAlgTyCon tc+  = Just (v, tx_con_dtt ty+           , \v -> App (App (Var f) (Type ty)) (Var v))++caseRules _ _ = Nothing+++tx_lit_con :: Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon+tx_lit_con _        _      DEFAULT    = Just DEFAULT+tx_lit_con platform adjust (LitAlt l) = Just $ LitAlt (mapLitValue platform adjust l)+tx_lit_con _        _      alt        = pprPanic "caseRules" (ppr alt)+   -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the+   -- literal alternatives remain in Word/Int target ranges+   -- (See Note [Word/Int underflow/overflow] in GHC.Types.Literal and #13172).++adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)+-- Given (x `op` lit) return a function 'f' s.t.  f (x `op` lit) = x+adjustDyadicRight op lit+  = case op of+         WordAddOp -> Just (\y -> y-lit      )+         IntAddOp  -> Just (\y -> y-lit      )+         WordSubOp -> Just (\y -> y+lit      )+         IntSubOp  -> Just (\y -> y+lit      )+         XorOp     -> Just (\y -> y `xor` lit)+         XorIOp    -> Just (\y -> y `xor` lit)+         _         -> Nothing++adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer)+-- Given (lit `op` x) return a function 'f' s.t.  f (lit `op` x) = x+adjustDyadicLeft lit op+  = case op of+         WordAddOp -> Just (\y -> y-lit      )+         IntAddOp  -> Just (\y -> y-lit      )+         WordSubOp -> Just (\y -> lit-y      )+         IntSubOp  -> Just (\y -> lit-y      )+         XorOp     -> Just (\y -> y `xor` lit)+         XorIOp    -> Just (\y -> y `xor` lit)+         _         -> Nothing+++adjustUnary :: PrimOp -> Maybe (Integer -> Integer)+-- Given (op x) return a function 'f' s.t.  f (op x) = x+adjustUnary op+  = case op of+         NotOp     -> Just (\y -> complement y)+         NotIOp    -> Just (\y -> complement y)+         IntNegOp  -> Just (\y -> negate y    )+         _         -> Nothing++tx_con_tte :: Platform -> AltCon -> Maybe AltCon+tx_con_tte _        DEFAULT         = Just DEFAULT+tx_con_tte _        alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt)+tx_con_tte platform (DataAlt dc)  -- See Note [caseRules for tagToEnum]+  = Just $ LitAlt $ mkLitInt platform $ toInteger $ dataConTagZ dc++tx_con_dtt :: Type -> AltCon -> Maybe AltCon+tx_con_dtt _  DEFAULT = Just DEFAULT+tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _))+   | tag >= 0+   , tag < n_data_cons+   = Just (DataAlt (data_cons !! tag))   -- tag is zero-indexed, as is (!!)+   | otherwise+   = Nothing+   where+     tag         = fromInteger i :: ConTagZ+     tc          = tyConAppTyCon ty+     n_data_cons = tyConFamilySize tc+     data_cons   = tyConDataCons tc++tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)+++{- Note [caseRules for tagToEnum]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to transform+   case tagToEnum x of+     False -> e1+     True  -> e2+into+   case x of+     0# -> e1+     1# -> e2++This rule eliminates a lot of boilerplate. For+  if (x>y) then e2 else e1+we generate+  case tagToEnum (x ># y) of+    False -> e1+    True  -> e2+and it is nice to then get rid of the tagToEnum.++Beware (#14768): avoid the temptation to map constructor 0 to+DEFAULT, in the hope of getting this+  case (x ># y) of+    DEFAULT -> e1+    1#      -> e2+That fails utterly in the case of+   data Colour = Red | Green | Blue+   case tagToEnum x of+      DEFAULT -> e1+      Red     -> e2++We don't want to get this!+   case x of+      DEFAULT -> e1+      DEFAULT -> e2++Instead, we deal with turning one branch into DEFAULT in GHC.Core.Op.Simplify.Utils+(add_default in mkCase3).++Note [caseRules for dataToTag]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [dataToTag#] in primpops.txt.pp++We want to transform+  case dataToTag x of+    DEFAULT -> e1+    1# -> e2+into+  case x of+    DEFAULT -> e1+    (:) _ _ -> e2++Note the need for some wildcard binders in+the 'cons' case.++For the time, we only apply this transformation when the type of `x` is a type+headed by a normal tycon. In particular, we do not apply this in the case of a+data family tycon, since that would require carefully applying coercion(s)+between the data family and the data family instance's representation type,+which caseRules isn't currently engineered to handle (#14680).++Note [Unreachable caseRules alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Take care if we see something like+  case dataToTag x of+    DEFAULT -> e1+    -1# -> e2+    100 -> e3+because there isn't a data constructor with tag -1 or 100. In this case the+out-of-range alternative is dead code -- we know the range of tags for x.++Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating+an alternative that is unreachable.++You may wonder how this can happen: check out #15436.+-}
+ compiler/GHC/Core/Op/Monad.hs view
@@ -0,0 +1,828 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.Core.Op.Monad (+    -- * Configuration of the core-to-core passes+    CoreToDo(..), runWhen, runMaybe,+    SimplMode(..),+    FloatOutSwitches(..),+    pprPassDetails,++    -- * Plugins+    CorePluginPass, bindsOnlyPass,++    -- * Counting+    SimplCount, doSimplTick, doFreeSimplTick, simplCountN,+    pprSimplCount, plusSimplCount, zeroSimplCount,+    isZeroSimplCount, hasDetailedCounts, Tick(..),++    -- * The monad+    CoreM, runCoreM,++    -- ** Reading from the monad+    getHscEnv, getRuleBase, getModule,+    getDynFlags, getPackageFamInstEnv,+    getVisibleOrphanMods, getUniqMask,+    getPrintUnqualified, getSrcSpanM,++    -- ** Writing to the monad+    addSimplCount,++    -- ** Lifting into the monad+    liftIO, liftIOWithCount,++    -- ** Dealing with annotations+    getAnnotations, getFirstAnnotations,++    -- ** Screen output+    putMsg, putMsgS, errorMsg, errorMsgS, warnMsg,+    fatalErrorMsg, fatalErrorMsgS,+    debugTraceMsg, debugTraceMsgS,+    dumpIfSet_dyn+  ) where++import GhcPrelude hiding ( read )++import GHC.Core+import GHC.Driver.Types+import GHC.Types.Module+import GHC.Driver.Session+import GHC.Types.Basic  ( CompilerPhase(..) )+import GHC.Types.Annotations++import IOEnv hiding     ( liftIO, failM, failWithM )+import qualified IOEnv  ( liftIO )+import GHC.Types.Var+import Outputable+import FastString+import ErrUtils( Severity(..), DumpFormat (..), dumpOptionsFromFlag )+import GHC.Types.Unique.Supply+import MonadUtils+import GHC.Types.Name.Env+import GHC.Types.SrcLoc+import Data.Bifunctor ( bimap )+import ErrUtils (dumpAction)+import Data.List (intersperse, groupBy, sortBy)+import Data.Ord+import Data.Dynamic+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Map.Strict as MapStrict+import Data.Word+import Control.Monad+import Control.Applicative ( Alternative(..) )+import Panic (throwGhcException, GhcException(..))++{-+************************************************************************+*                                                                      *+              The CoreToDo type and related types+          Abstraction of core-to-core passes to run.+*                                                                      *+************************************************************************+-}++data CoreToDo           -- These are diff core-to-core passes,+                        -- which may be invoked in any order,+                        -- as many times as you like.++  = CoreDoSimplify      -- The core-to-core simplifier.+        Int                    -- Max iterations+        SimplMode+  | CoreDoPluginPass String CorePluginPass+  | CoreDoFloatInwards+  | CoreDoFloatOutwards FloatOutSwitches+  | CoreLiberateCase+  | CoreDoPrintCore+  | CoreDoStaticArgs+  | CoreDoCallArity+  | CoreDoExitify+  | CoreDoDemand+  | CoreDoCpr+  | CoreDoWorkerWrapper+  | CoreDoSpecialising+  | CoreDoSpecConstr+  | CoreCSE+  | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules+                                           -- matching this string+  | CoreDoNothing                -- Useful when building up+  | CoreDoPasses [CoreToDo]      -- lists of these things++  | CoreDesugar    -- Right after desugaring, no simple optimisation yet!+  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces+                       --                 Core output, and hence useful to pass to endPass++  | CoreTidy+  | CorePrep+  | CoreOccurAnal++instance Outputable CoreToDo where+  ppr (CoreDoSimplify _ _)     = text "Simplifier"+  ppr (CoreDoPluginPass s _)   = text "Core plugin: " <+> text s+  ppr CoreDoFloatInwards       = text "Float inwards"+  ppr (CoreDoFloatOutwards f)  = text "Float out" <> parens (ppr f)+  ppr CoreLiberateCase         = text "Liberate case"+  ppr CoreDoStaticArgs         = text "Static argument"+  ppr CoreDoCallArity          = text "Called arity analysis"+  ppr CoreDoExitify            = text "Exitification transformation"+  ppr CoreDoDemand             = text "Demand analysis"+  ppr CoreDoCpr                = text "Constructed Product Result analysis"+  ppr CoreDoWorkerWrapper      = text "Worker Wrapper binds"+  ppr CoreDoSpecialising       = text "Specialise"+  ppr CoreDoSpecConstr         = text "SpecConstr"+  ppr CoreCSE                  = text "Common sub-expression"+  ppr CoreDesugar              = text "Desugar (before optimization)"+  ppr CoreDesugarOpt           = text "Desugar (after optimization)"+  ppr CoreTidy                 = text "Tidy Core"+  ppr CorePrep                 = text "CorePrep"+  ppr CoreOccurAnal            = text "Occurrence analysis"+  ppr CoreDoPrintCore          = text "Print core"+  ppr (CoreDoRuleCheck {})     = text "Rule check"+  ppr CoreDoNothing            = text "CoreDoNothing"+  ppr (CoreDoPasses passes)    = text "CoreDoPasses" <+> ppr passes++pprPassDetails :: CoreToDo -> SDoc+pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n+                                            , ppr md ]+pprPassDetails _ = Outputable.empty++data SimplMode             -- See comments in GHC.Core.Op.Simplify.Monad+  = SimplMode+        { sm_names      :: [String] -- Name(s) of the phase+        , sm_phase      :: CompilerPhase+        , sm_dflags     :: DynFlags -- Just for convenient non-monadic+                                    -- access; we don't override these+        , sm_rules      :: Bool     -- Whether RULES are enabled+        , sm_inline     :: Bool     -- Whether inlining is enabled+        , sm_case_case  :: Bool     -- Whether case-of-case is enabled+        , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled+        }++instance Outputable SimplMode where+    ppr (SimplMode { sm_phase = p, sm_names = ss+                   , sm_rules = r, sm_inline = i+                   , sm_eta_expand = eta, sm_case_case = cc })+       = text "SimplMode" <+> braces (+         sep [ text "Phase =" <+> ppr p <+>+               brackets (text (concat $ intersperse "," ss)) <> comma+             , pp_flag i   (sLit "inline") <> comma+             , pp_flag r   (sLit "rules") <> comma+             , pp_flag eta (sLit "eta-expand") <> comma+             , pp_flag cc  (sLit "case-of-case") ])+         where+           pp_flag f s = ppUnless f (text "no") <+> ptext s++data FloatOutSwitches = FloatOutSwitches {+  floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if+                                   -- doing so will abstract over n or fewer+                                   -- value variables+                                   -- Nothing <=> float all lambdas to top level,+                                   --             regardless of how many free variables+                                   -- Just 0 is the vanilla case: float a lambda+                                   --    iff it has no free vars++  floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,+                                   --            even if they do not escape a lambda+  floatOutOverSatApps :: Bool,+                             -- ^ True <=> float out over-saturated applications+                             --            based on arity information.+                             -- See Note [Floating over-saturated applications]+                             -- in GHC.Core.Op.SetLevels+  floatToTopLevelOnly :: Bool      -- ^ Allow floating to the top level only.+  }+instance Outputable FloatOutSwitches where+    ppr = pprFloatOutSwitches++pprFloatOutSwitches :: FloatOutSwitches -> SDoc+pprFloatOutSwitches sw+  = text "FOS" <+> (braces $+     sep $ punctuate comma $+     [ text "Lam ="    <+> ppr (floatOutLambdas sw)+     , text "Consts =" <+> ppr (floatOutConstants sw)+     , text "OverSatApps ="   <+> ppr (floatOutOverSatApps sw) ])++-- The core-to-core pass ordering is derived from the DynFlags:+runWhen :: Bool -> CoreToDo -> CoreToDo+runWhen True  do_this = do_this+runWhen False _       = CoreDoNothing++runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo+runMaybe (Just x) f = f x+runMaybe Nothing  _ = CoreDoNothing++{-++************************************************************************+*                                                                      *+             Types for Plugins+*                                                                      *+************************************************************************+-}++-- | A description of the plugin pass itself+type CorePluginPass = ModGuts -> CoreM ModGuts++bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts+bindsOnlyPass pass guts+  = do { binds' <- pass (mg_binds guts)+       ; return (guts { mg_binds = binds' }) }++{-+************************************************************************+*                                                                      *+             Counting and logging+*                                                                      *+************************************************************************+-}++getVerboseSimplStats :: (Bool -> SDoc) -> SDoc+getVerboseSimplStats = getPprDebug          -- For now, anyway++zeroSimplCount     :: DynFlags -> SimplCount+isZeroSimplCount   :: SimplCount -> Bool+hasDetailedCounts  :: SimplCount -> Bool+pprSimplCount      :: SimplCount -> SDoc+doSimplTick        :: DynFlags -> Tick -> SimplCount -> SimplCount+doFreeSimplTick    ::             Tick -> SimplCount -> SimplCount+plusSimplCount     :: SimplCount -> SimplCount -> SimplCount++data SimplCount+   = VerySimplCount !Int        -- Used when don't want detailed stats++   | SimplCount {+        ticks   :: !Int,        -- Total ticks+        details :: !TickCounts, -- How many of each type++        n_log   :: !Int,        -- N+        log1    :: [Tick],      -- Last N events; <= opt_HistorySize,+                                --   most recent first+        log2    :: [Tick]       -- Last opt_HistorySize events before that+                                -- Having log1, log2 lets us accumulate the+                                -- recent history reasonably efficiently+     }++type TickCounts = Map Tick Int++simplCountN :: SimplCount -> Int+simplCountN (VerySimplCount n)         = n+simplCountN (SimplCount { ticks = n }) = n++zeroSimplCount dflags+                -- This is where we decide whether to do+                -- the VerySimpl version or the full-stats version+  | dopt Opt_D_dump_simpl_stats dflags+  = SimplCount {ticks = 0, details = Map.empty,+                n_log = 0, log1 = [], log2 = []}+  | otherwise+  = VerySimplCount 0++isZeroSimplCount (VerySimplCount n)         = n==0+isZeroSimplCount (SimplCount { ticks = n }) = n==0++hasDetailedCounts (VerySimplCount {}) = False+hasDetailedCounts (SimplCount {})     = True++doFreeSimplTick tick sc@SimplCount { details = dts }+  = sc { details = dts `addTick` tick }+doFreeSimplTick _ sc = sc++doSimplTick dflags tick+    sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })+  | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 }+  | otherwise                = sc1 { n_log = nl+1, log1 = tick : l1 }+  where+    sc1 = sc { ticks = tks+1, details = dts `addTick` tick }++doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)+++addTick :: TickCounts -> Tick -> TickCounts+addTick fm tick = MapStrict.insertWith (+) tick 1 fm++plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })+               sc2@(SimplCount { ticks = tks2, details = dts2 })+  = log_base { ticks = tks1 + tks2+             , details = MapStrict.unionWith (+) dts1 dts2 }+  where+        -- A hackish way of getting recent log info+    log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2+             | null (log2 sc2) = sc2 { log2 = log1 sc1 }+             | otherwise       = sc2++plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)+plusSimplCount lhs                rhs                =+  throwGhcException . PprProgramError "plusSimplCount" $ vcat+    [ text "lhs"+    , pprSimplCount lhs+    , text "rhs"+    , pprSimplCount rhs+    ]+       -- We use one or the other consistently++pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n+pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })+  = vcat [text "Total ticks:    " <+> int tks,+          blankLine,+          pprTickCounts dts,+          getVerboseSimplStats $ \dbg -> if dbg+          then+                vcat [blankLine,+                      text "Log (most recent first)",+                      nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]+          else Outputable.empty+    ]++{- Note [Which transformations are innocuous]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At one point (Jun 18) I wondered if some transformations (ticks)+might be  "innocuous", in the sense that they do not unlock a later+transformation that does not occur in the same pass.  If so, we could+refrain from bumping the overall tick-count for such innocuous+transformations, and perhaps terminate the simplifier one pass+earlier.++But alas I found that virtually nothing was innocuous!  This Note+just records what I learned, in case anyone wants to try again.++These transformations are not innocuous:++*** NB: I think these ones could be made innocuous+          EtaExpansion+          LetFloatFromLet++LetFloatFromLet+    x = K (let z = e2 in Just z)+  prepareRhs transforms to+    x2 = let z=e2 in Just z+    x  = K xs+  And now more let-floating can happen in the+  next pass, on x2++PreInlineUnconditionally+  Example in spectral/cichelli/Auxil+     hinsert = ...let lo = e in+                  let j = ...lo... in+                  case x of+                    False -> ()+                    True -> case lo of I# lo' ->+                              ...j...+  When we PreInlineUnconditionally j, lo's occ-info changes to once,+  so it can be PreInlineUnconditionally in the next pass, and a+  cascade of further things can happen.++PostInlineUnconditionally+  let x = e in+  let y = ...x.. in+  case .. of { A -> ...x...y...+               B -> ...x...y... }+  Current postinlineUnconditinaly will inline y, and then x; sigh.++  But PostInlineUnconditionally might also unlock subsequent+  transformations for the same reason as PreInlineUnconditionally,+  so it's probably not innocuous anyway.++KnownBranch, BetaReduction:+  May drop chunks of code, and thereby enable PreInlineUnconditionally+  for some let-binding which now occurs once++EtaExpansion:+  Example in imaginary/digits-of-e1+    fail = \void. e          where e :: IO ()+  --> etaExpandRhs+    fail = \void. (\s. (e |> g) s) |> sym g      where g :: IO () ~ S -> (S,())+  --> Next iteration of simplify+    fail1 = \void. \s. (e |> g) s+    fail = fail1 |> Void#->sym g+  And now inline 'fail'++CaseMerge:+  case x of y {+    DEFAULT -> case y of z { pi -> ei }+    alts2 }+  ---> CaseMerge+    case x of { pi -> let z = y in ei+              ; alts2 }+  The "let z=y" case-binder-swap gets dealt with in the next pass+-}++pprTickCounts :: Map Tick Int -> SDoc+pprTickCounts counts+  = vcat (map pprTickGroup groups)+  where+    groups :: [[(Tick,Int)]]    -- Each group shares a common tag+                                -- toList returns common tags adjacent+    groups = groupBy same_tag (Map.toList counts)+    same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2++pprTickGroup :: [(Tick, Int)] -> SDoc+pprTickGroup group@((tick1,_):_)+  = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))+       2 (vcat [ int n <+> pprTickCts tick+                                    -- flip as we want largest first+               | (tick,n) <- sortBy (flip (comparing snd)) group])+pprTickGroup [] = panic "pprTickGroup"++data Tick  -- See Note [Which transformations are innocuous]+  = PreInlineUnconditionally    Id+  | PostInlineUnconditionally   Id++  | UnfoldingDone               Id+  | RuleFired                   FastString      -- Rule name++  | LetFloatFromLet+  | EtaExpansion                Id      -- LHS binder+  | EtaReduction                Id      -- Binder on outer lambda+  | BetaReduction               Id      -- Lambda binder+++  | CaseOfCase                  Id      -- Bndr on *inner* case+  | KnownBranch                 Id      -- Case binder+  | CaseMerge                   Id      -- Binder on outer case+  | AltMerge                    Id      -- Case binder+  | CaseElim                    Id      -- Case binder+  | CaseIdentity                Id      -- Case binder+  | FillInCaseDefault           Id      -- Case binder++  | SimplifierDone              -- Ticked at each iteration of the simplifier++instance Outputable Tick where+  ppr tick = text (tickString tick) <+> pprTickCts tick++instance Eq Tick where+  a == b = case a `cmpTick` b of+           EQ -> True+           _ -> False++instance Ord Tick where+  compare = cmpTick++tickToTag :: Tick -> Int+tickToTag (PreInlineUnconditionally _)  = 0+tickToTag (PostInlineUnconditionally _) = 1+tickToTag (UnfoldingDone _)             = 2+tickToTag (RuleFired _)                 = 3+tickToTag LetFloatFromLet               = 4+tickToTag (EtaExpansion _)              = 5+tickToTag (EtaReduction _)              = 6+tickToTag (BetaReduction _)             = 7+tickToTag (CaseOfCase _)                = 8+tickToTag (KnownBranch _)               = 9+tickToTag (CaseMerge _)                 = 10+tickToTag (CaseElim _)                  = 11+tickToTag (CaseIdentity _)              = 12+tickToTag (FillInCaseDefault _)         = 13+tickToTag SimplifierDone                = 16+tickToTag (AltMerge _)                  = 17++tickString :: Tick -> String+tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"+tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"+tickString (UnfoldingDone _)            = "UnfoldingDone"+tickString (RuleFired _)                = "RuleFired"+tickString LetFloatFromLet              = "LetFloatFromLet"+tickString (EtaExpansion _)             = "EtaExpansion"+tickString (EtaReduction _)             = "EtaReduction"+tickString (BetaReduction _)            = "BetaReduction"+tickString (CaseOfCase _)               = "CaseOfCase"+tickString (KnownBranch _)              = "KnownBranch"+tickString (CaseMerge _)                = "CaseMerge"+tickString (AltMerge _)                 = "AltMerge"+tickString (CaseElim _)                 = "CaseElim"+tickString (CaseIdentity _)             = "CaseIdentity"+tickString (FillInCaseDefault _)        = "FillInCaseDefault"+tickString SimplifierDone               = "SimplifierDone"++pprTickCts :: Tick -> SDoc+pprTickCts (PreInlineUnconditionally v) = ppr v+pprTickCts (PostInlineUnconditionally v)= ppr v+pprTickCts (UnfoldingDone v)            = ppr v+pprTickCts (RuleFired v)                = ppr v+pprTickCts LetFloatFromLet              = Outputable.empty+pprTickCts (EtaExpansion v)             = ppr v+pprTickCts (EtaReduction v)             = ppr v+pprTickCts (BetaReduction v)            = ppr v+pprTickCts (CaseOfCase v)               = ppr v+pprTickCts (KnownBranch v)              = ppr v+pprTickCts (CaseMerge v)                = ppr v+pprTickCts (AltMerge v)                 = ppr v+pprTickCts (CaseElim v)                 = ppr v+pprTickCts (CaseIdentity v)             = ppr v+pprTickCts (FillInCaseDefault v)        = ppr v+pprTickCts _                            = Outputable.empty++cmpTick :: Tick -> Tick -> Ordering+cmpTick a b = case (tickToTag a `compare` tickToTag b) of+                GT -> GT+                EQ -> cmpEqTick a b+                LT -> LT++cmpEqTick :: Tick -> Tick -> Ordering+cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b+cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b+cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b+cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b+cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b+cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b+cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b+cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b+cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b+cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b+cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b+cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b+cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b+cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b+cmpEqTick _                             _                               = EQ++{-+************************************************************************+*                                                                      *+             Monad and carried data structure definitions+*                                                                      *+************************************************************************+-}++data CoreReader = CoreReader {+        cr_hsc_env             :: HscEnv,+        cr_rule_base           :: RuleBase,+        cr_module              :: Module,+        cr_print_unqual        :: PrintUnqualified,+        cr_loc                 :: SrcSpan,   -- Use this for log/error messages so they+                                             -- are at least tagged with the right source file+        cr_visible_orphan_mods :: !ModuleSet,+        cr_uniq_mask           :: !Char      -- Mask for creating unique values+}++-- Note: CoreWriter used to be defined with data, rather than newtype.  If it+-- is defined that way again, the cw_simpl_count field, at least, must be+-- strict to avoid a space leak (#7702).+newtype CoreWriter = CoreWriter {+        cw_simpl_count :: SimplCount+}++emptyWriter :: DynFlags -> CoreWriter+emptyWriter dflags = CoreWriter {+        cw_simpl_count = zeroSimplCount dflags+    }++plusWriter :: CoreWriter -> CoreWriter -> CoreWriter+plusWriter w1 w2 = CoreWriter {+        cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)+    }++type CoreIOEnv = IOEnv CoreReader++-- | The monad used by Core-to-Core passes to register simplification statistics.+--  Also used to have common state (in the form of UniqueSupply) for generating Uniques.+newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) }+    deriving (Functor)++instance Monad CoreM where+    mx >>= f = CoreM $ do+            (x, w1) <- unCoreM mx+            (y, w2) <- unCoreM (f x)+            let w = w1 `plusWriter` w2+            return $ seq w (y, w)+            -- forcing w before building the tuple avoids a space leak+            -- (#7702)++instance Applicative CoreM where+    pure x = CoreM $ nop x+    (<*>) = ap+    m *> k = m >>= \_ -> k++instance Alternative CoreM where+    empty   = CoreM Control.Applicative.empty+    m <|> n = CoreM (unCoreM m <|> unCoreM n)++instance MonadPlus CoreM++instance MonadUnique CoreM where+    getUniqueSupplyM = do+        mask <- read cr_uniq_mask+        liftIO $! mkSplitUniqSupply mask++    getUniqueM = do+        mask <- read cr_uniq_mask+        liftIO $! uniqFromMask mask++runCoreM :: HscEnv+         -> RuleBase+         -> Char -- ^ Mask+         -> Module+         -> ModuleSet+         -> PrintUnqualified+         -> SrcSpan+         -> CoreM a+         -> IO (a, SimplCount)+runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m+  = liftM extract $ runIOEnv reader $ unCoreM m+  where+    reader = CoreReader {+            cr_hsc_env = hsc_env,+            cr_rule_base = rule_base,+            cr_module = mod,+            cr_visible_orphan_mods = orph_imps,+            cr_print_unqual = print_unqual,+            cr_loc = loc,+            cr_uniq_mask = mask+        }++    extract :: (a, CoreWriter) -> (a, SimplCount)+    extract (value, writer) = (value, cw_simpl_count writer)++{-+************************************************************************+*                                                                      *+             Core combinators, not exported+*                                                                      *+************************************************************************+-}++nop :: a -> CoreIOEnv (a, CoreWriter)+nop x = do+    r <- getEnv+    return (x, emptyWriter $ (hsc_dflags . cr_hsc_env) r)++read :: (CoreReader -> a) -> CoreM a+read f = CoreM $ getEnv >>= (\r -> nop (f r))++write :: CoreWriter -> CoreM ()+write w = CoreM $ return ((), w)++-- \subsection{Lifting IO into the monad}++-- | Lift an 'IOEnv' operation into 'CoreM'+liftIOEnv :: CoreIOEnv a -> CoreM a+liftIOEnv mx = CoreM (mx >>= (\x -> nop x))++instance MonadIO CoreM where+    liftIO = liftIOEnv . IOEnv.liftIO++-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'+liftIOWithCount :: IO (SimplCount, a) -> CoreM a+liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)++{-+************************************************************************+*                                                                      *+             Reader, writer and state accessors+*                                                                      *+************************************************************************+-}++getHscEnv :: CoreM HscEnv+getHscEnv = read cr_hsc_env++getRuleBase :: CoreM RuleBase+getRuleBase = read cr_rule_base++getVisibleOrphanMods :: CoreM ModuleSet+getVisibleOrphanMods = read cr_visible_orphan_mods++getPrintUnqualified :: CoreM PrintUnqualified+getPrintUnqualified = read cr_print_unqual++getSrcSpanM :: CoreM SrcSpan+getSrcSpanM = read cr_loc++addSimplCount :: SimplCount -> CoreM ()+addSimplCount count = write (CoreWriter { cw_simpl_count = count })++getUniqMask :: CoreM Char+getUniqMask = read cr_uniq_mask++-- Convenience accessors for useful fields of HscEnv++instance HasDynFlags CoreM where+    getDynFlags = fmap hsc_dflags getHscEnv++instance HasModule CoreM where+    getModule = read cr_module++getPackageFamInstEnv :: CoreM PackageFamInstEnv+getPackageFamInstEnv = do+    hsc_env <- getHscEnv+    eps <- liftIO $ hscEPS hsc_env+    return $ eps_fam_inst_env eps++{-+************************************************************************+*                                                                      *+             Dealing with annotations+*                                                                      *+************************************************************************+-}++-- | Get all annotations of a given type. This happens lazily, that is+-- no deserialization will take place until the [a] is actually demanded and+-- the [a] can also be empty (the UniqFM is not filtered).+--+-- This should be done once at the start of a Core-to-Core pass that uses+-- annotations.+--+-- See Note [Annotations]+getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])+getAnnotations deserialize guts = do+     hsc_env <- getHscEnv+     ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)+     return (deserializeAnns deserialize ann_env)++-- | Get at most one annotation of a given type per annotatable item.+getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a)+getFirstAnnotations deserialize guts+  = bimap mod name <$> getAnnotations deserialize guts+  where+    mod = mapModuleEnv head . filterModuleEnv (const $ not . null)+    name = mapNameEnv head . filterNameEnv (not . null)++{-+Note [Annotations]+~~~~~~~~~~~~~~~~~~+A Core-to-Core pass that wants to make use of annotations calls+getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with+annotations of a specific type. This produces all annotations from interface+files read so far. However, annotations from interface files read during the+pass will not be visible until getAnnotations is called again. This is similar+to how rules work and probably isn't too bad.++The current implementation could be optimised a bit: when looking up+annotations for a thing from the HomePackageTable, we could search directly in+the module where the thing is defined rather than building one UniqFM which+contains all annotations we know of. This would work because annotations can+only be given to things defined in the same module. However, since we would+only want to deserialise every annotation once, we would have to build a cache+for every module in the HTP. In the end, it's probably not worth it as long as+we aren't using annotations heavily.++************************************************************************+*                                                                      *+                Direct screen output+*                                                                      *+************************************************************************+-}++msg :: Severity -> WarnReason -> SDoc -> CoreM ()+msg sev reason doc+  = do { dflags <- getDynFlags+       ; loc    <- getSrcSpanM+       ; unqual <- getPrintUnqualified+       ; let sty = case sev of+                     SevError   -> err_sty+                     SevWarning -> err_sty+                     SevDump    -> dump_sty+                     _          -> user_sty+             err_sty  = mkErrStyle dflags unqual+             user_sty = mkUserStyle dflags unqual AllTheWay+             dump_sty = mkDumpStyle dflags unqual+       ; liftIO $ putLogMsg dflags reason sev loc sty doc }++-- | Output a String message to the screen+putMsgS :: String -> CoreM ()+putMsgS = putMsg . text++-- | Output a message to the screen+putMsg :: SDoc -> CoreM ()+putMsg = msg SevInfo NoReason++-- | Output an error to the screen. Does not cause the compiler to die.+errorMsgS :: String -> CoreM ()+errorMsgS = errorMsg . text++-- | Output an error to the screen. Does not cause the compiler to die.+errorMsg :: SDoc -> CoreM ()+errorMsg = msg SevError NoReason++warnMsg :: WarnReason -> SDoc -> CoreM ()+warnMsg = msg SevWarning++-- | Output a fatal error to the screen. Does not cause the compiler to die.+fatalErrorMsgS :: String -> CoreM ()+fatalErrorMsgS = fatalErrorMsg . text++-- | Output a fatal error to the screen. Does not cause the compiler to die.+fatalErrorMsg :: SDoc -> CoreM ()+fatalErrorMsg = msg SevFatal NoReason++-- | Output a string debugging message at verbosity level of @-v@ or higher+debugTraceMsgS :: String -> CoreM ()+debugTraceMsgS = debugTraceMsg . text++-- | Outputs a debugging message at verbosity level of @-v@ or higher+debugTraceMsg :: SDoc -> CoreM ()+debugTraceMsg = msg SevDump NoReason++-- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher+dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM ()+dumpIfSet_dyn flag str fmt doc+  = do { dflags <- getDynFlags+       ; unqual <- getPrintUnqualified+       ; when (dopt flag dflags) $ liftIO $ do+         let sty = mkDumpStyle dflags unqual+         dumpAction dflags sty (dumpOptionsFromFlag flag) str fmt doc }
+ compiler/GHC/Core/Op/Monad.hs-boot view
@@ -0,0 +1,30 @@+-- Created this hs-boot file to remove circular dependencies from the use of+-- Plugins. Plugins needs CoreToDo and CoreM types to define core-to-core+-- transformations.+-- However GHC.Core.Op.Monad does much more than defining these, and because Plugins are+-- activated in various modules, the imports become circular. To solve this I+-- extracted CoreToDo and CoreM into this file.+-- I needed to write the whole definition of these types, otherwise it created+-- a data-newtype conflict.++module GHC.Core.Op.Monad ( CoreToDo, CoreM ) where++import GhcPrelude++import IOEnv ( IOEnv )++type CoreIOEnv = IOEnv CoreReader++data CoreReader++newtype CoreWriter = CoreWriter {+        cw_simpl_count :: SimplCount+}++data SimplCount++newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) }++instance Monad CoreM++data CoreToDo
+ compiler/GHC/Core/Op/OccurAnal.hs view
@@ -0,0 +1,2898 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++************************************************************************+*                                                                      *+\section[OccurAnal]{Occurrence analysis pass}+*                                                                      *+************************************************************************++The occurrence analyser re-typechecks a core expression, returning a new+core expression with (hopefully) improved usage information.+-}++{-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns  #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.Core.Op.OccurAnal (+        occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Core+import GHC.Core.FVs+import GHC.Core.Utils   ( exprIsTrivial, isDefaultAlt, isExpandableApp,+                          stripTicksTopE, mkTicks )+import GHC.Core.Arity   ( joinRhsArity )+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Name( localiseName )+import GHC.Types.Basic+import GHC.Types.Module( Module )+import GHC.Core.Coercion+import GHC.Core.Type++import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Var+import GHC.Types.Demand ( argOneShots, argsOneShots )+import Digraph          ( SCC(..), Node(..)+                        , stronglyConnCompFromEdgedVerticesUniq+                        , stronglyConnCompFromEdgedVerticesUniqR )+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import Util+import Outputable+import Data.List+import Control.Arrow    ( second )++{-+************************************************************************+*                                                                      *+    occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap+*                                                                      *+************************************************************************++Here's the externally-callable interface:+-}++occurAnalysePgm :: Module         -- Used only in debug output+                -> (Id -> Bool)         -- Active unfoldings+                -> (Activation -> Bool) -- Active rules+                -> [CoreRule]+                -> CoreProgram -> CoreProgram+occurAnalysePgm this_mod active_unf active_rule imp_rules binds+  | isEmptyDetails final_usage+  = occ_anald_binds++  | otherwise   -- See Note [Glomming]+  = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon)+                   2 (ppr final_usage ) )+    occ_anald_glommed_binds+  where+    init_env = initOccEnv { occ_rule_act = active_rule+                          , occ_unf_act  = active_unf }++    (final_usage, occ_anald_binds) = go init_env binds+    (_, occ_anald_glommed_binds)   = occAnalRecBind init_env TopLevel+                                                    imp_rule_edges+                                                    (flattenBinds binds)+                                                    initial_uds+          -- It's crucial to re-analyse the glommed-together bindings+          -- so that we establish the right loop breakers. Otherwise+          -- we can easily create an infinite loop (#9583 is an example)+          --+          -- Also crucial to re-analyse the /original/ bindings+          -- in case the first pass accidentally discarded as dead code+          -- a binding that was actually needed (albeit before its+          -- definition site).  #17724 threw this up.++    initial_uds = addManyOccsSet emptyDetails+                            (rulesFreeVars imp_rules)+    -- The RULES declarations keep things alive!++    -- Note [Preventing loops due to imported functions rules]+    imp_rule_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv+                            [ mapVarEnv (const maps_to) $+                                getUniqSet (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule)+                            | imp_rule <- imp_rules+                            , not (isBuiltinRule imp_rule)  -- See Note [Plugin rules]+                            , let maps_to = exprFreeIds (ru_rhs imp_rule)+                                             `delVarSetList` ru_bndrs imp_rule+                            , arg <- ru_args imp_rule ]++    go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])+    go _ []+        = (initial_uds, [])+    go env (bind:binds)+        = (final_usage, bind' ++ binds')+        where+           (bs_usage, binds')   = go env binds+           (final_usage, bind') = occAnalBind env TopLevel imp_rule_edges bind+                                              bs_usage++occurAnalyseExpr :: CoreExpr -> CoreExpr+        -- Do occurrence analysis, and discard occurrence info returned+occurAnalyseExpr = occurAnalyseExpr' True -- do binder swap++occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr+occurAnalyseExpr_NoBinderSwap = occurAnalyseExpr' False -- do not do binder swap++occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr+occurAnalyseExpr' enable_binder_swap expr+  = snd (occAnal env expr)+  where+    env = initOccEnv { occ_binder_swap = enable_binder_swap }++{- Note [Plugin rules]+~~~~~~~~~~~~~~~~~~~~~~+Conal Elliott (#11651) built a GHC plugin that added some+BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to+do some domain-specific transformations that could not be expressed+with an ordinary pattern-matching CoreRule.  But then we can't extract+the dependencies (in imp_rule_edges) from ru_rhs etc, because a+BuiltinRule doesn't have any of that stuff.++So we simply assume that BuiltinRules have no dependencies, and filter+them out from the imp_rule_edges comprehension.+-}++{-+************************************************************************+*                                                                      *+                Bindings+*                                                                      *+************************************************************************++Note [Recursive bindings: the grand plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we come across a binding group+  Rec { x1 = r1; ...; xn = rn }+we treat it like this (occAnalRecBind):++1. Occurrence-analyse each right hand side, and build a+   "Details" for each binding to capture the results.++   Wrap the details in a Node (details, node-id, dep-node-ids),+   where node-id is just the unique of the binder, and+   dep-node-ids lists all binders on which this binding depends.+   We'll call these the "scope edges".+   See Note [Forming the Rec groups].++   All this is done by makeNode.++2. Do SCC-analysis on these Nodes.  Each SCC will become a new Rec or+   NonRec.  The key property is that every free variable of a binding+   is accounted for by the scope edges, so that when we are done+   everything is still in scope.++3. For each Cyclic SCC of the scope-edge SCC-analysis in (2), we+   identify suitable loop-breakers to ensure that inlining terminates.+   This is done by occAnalRec.++4. To do so we form a new set of Nodes, with the same details, but+   different edges, the "loop-breaker nodes". The loop-breaker nodes+   have both more and fewer dependencies than the scope edges+   (see Note [Choosing loop breakers])++   More edges: if f calls g, and g has an active rule that mentions h+               then we add an edge from f -> h++   Fewer edges: we only include dependencies on active rules, on rule+                RHSs (not LHSs) and if there is an INLINE pragma only+                on the stable unfolding (and vice versa).  The scope+                edges must be much more inclusive.++5.  The "weak fvs" of a node are, by definition:+       the scope fvs - the loop-breaker fvs+    See Note [Weak loop breakers], and the nd_weak field of Details++6.  Having formed the loop-breaker nodes++Note [Dead code]+~~~~~~~~~~~~~~~~+Dropping dead code for a cyclic Strongly Connected Component is done+in a very simple way:++        the entire SCC is dropped if none of its binders are mentioned+        in the body; otherwise the whole thing is kept.++The key observation is that dead code elimination happens after+dependency analysis: so 'occAnalBind' processes SCCs instead of the+original term's binding groups.++Thus 'occAnalBind' does indeed drop 'f' in an example like++        letrec f = ...g...+               g = ...(...g...)...+        in+           ...g...++when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in+'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes+'AcyclicSCC f', where 'body_usage' won't contain 'f'.++------------------------------------------------------------+Note [Forming Rec groups]+~~~~~~~~~~~~~~~~~~~~~~~~~+We put bindings {f = ef; g = eg } in a Rec group if "f uses g"+and "g uses f", no matter how indirectly.  We do a SCC analysis+with an edge f -> g if "f uses g".++More precisely, "f uses g" iff g should be in scope wherever f is.+That is, g is free in:+  a) the rhs 'ef'+  b) or the RHS of a rule for f (Note [Rules are extra RHSs])+  c) or the LHS or a rule for f (Note [Rule dependency info])++These conditions apply regardless of the activation of the RULE (eg it might be+inactive in this phase but become active later).  Once a Rec is broken up+it can never be put back together, so we must be conservative.++The principle is that, regardless of rule firings, every variable is+always in scope.++  * Note [Rules are extra RHSs]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~+    A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"+    keeps the specialised "children" alive.  If the parent dies+    (because it isn't referenced any more), then the children will die+    too (unless they are already referenced directly).++    To that end, we build a Rec group for each cyclic strongly+    connected component,+        *treating f's rules as extra RHSs for 'f'*.+    More concretely, the SCC analysis runs on a graph with an edge+    from f -> g iff g is mentioned in+        (a) f's rhs+        (b) f's RULES+    These are rec_edges.++    Under (b) we include variables free in *either* LHS *or* RHS of+    the rule.  The former might seems silly, but see Note [Rule+    dependency info].  So in Example [eftInt], eftInt and eftIntFB+    will be put in the same Rec, even though their 'main' RHSs are+    both non-recursive.++  * Note [Rule dependency info]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~+    The VarSet in a RuleInfo is used for dependency analysis in the+    occurrence analyser.  We must track free vars in *both* lhs and rhs.+    Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.+    Why both? Consider+        x = y+        RULE f x = v+4+    Then if we substitute y for x, we'd better do so in the+    rule's LHS too, so we'd better ensure the RULE appears to mention 'x'+    as well as 'v'++  * Note [Rules are visible in their own rec group]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    We want the rules for 'f' to be visible in f's right-hand side.+    And we'd like them to be visible in other functions in f's Rec+    group.  E.g. in Note [Specialisation rules] we want f' rule+    to be visible in both f's RHS, and fs's RHS.++    This means that we must simplify the RULEs first, before looking+    at any of the definitions.  This is done by Simplify.simplRecBind,+    when it calls addLetIdInfo.++------------------------------------------------------------+Note [Choosing loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Loop breaking is surprisingly subtle.  First read the section 4 of+"Secrets of the GHC inliner".  This describes our basic plan.+We avoid infinite inlinings by choosing loop breakers, and+ensuring that a loop breaker cuts each loop.++See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which+deals with a closely related source of infinite loops.++Fundamentally, we do SCC analysis on a graph.  For each recursive+group we choose a loop breaker, delete all edges to that node,+re-analyse the SCC, and iterate.++But what is the graph?  NOT the same graph as was used for Note+[Forming Rec groups]!  In particular, a RULE is like an equation for+'f' that is *always* inlined if it is applicable.  We do *not* disable+rules for loop-breakers.  It's up to whoever makes the rules to make+sure that the rules themselves always terminate.  See Note [Rules for+recursive functions] in GHC.Core.Op.Simplify++Hence, if+    f's RHS (or its INLINE template if it has one) mentions g, and+    g has a RULE that mentions h, and+    h has a RULE that mentions f++then we *must* choose f to be a loop breaker.  Example: see Note+[Specialisation rules].++In general, take the free variables of f's RHS, and augment it with+all the variables reachable by RULES from those starting points.  That+is the whole reason for computing rule_fv_env in occAnalBind.  (Of+course we only consider free vars that are also binders in this Rec+group.)  See also Note [Finding rule RHS free vars]++Note that when we compute this rule_fv_env, we only consider variables+free in the *RHS* of the rule, in contrast to the way we build the+Rec group in the first place (Note [Rule dependency info])++Note that if 'g' has RHS that mentions 'w', we should add w to+g's loop-breaker edges.  More concretely there is an edge from f -> g+iff+        (a) g is mentioned in f's RHS `xor` f's INLINE rhs+            (see Note [Inline rules])+        (b) or h is mentioned in f's RHS, and+            g appears in the RHS of an active RULE of h+            or a transitive sequence of active rules starting with h++Why "active rules"?  See Note [Finding rule RHS free vars]++Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is+chosen as a loop breaker, because their RHSs don't mention each other.+And indeed both can be inlined safely.++Note again that the edges of the graph we use for computing loop breakers+are not the same as the edges we use for computing the Rec blocks.+That's why we compute++- rec_edges          for the Rec block analysis+- loop_breaker_nodes for the loop breaker analysis++  * Note [Finding rule RHS free vars]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    Consider this real example from Data Parallel Haskell+         tagZero :: Array Int -> Array Tag+         {-# INLINE [1] tagZeroes #-}+         tagZero xs = pmap (\x -> fromBool (x==0)) xs++         {-# RULES "tagZero" [~1] forall xs n.+             pmap fromBool <blah blah> = tagZero xs #-}+    So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.+    However, tagZero can only be inlined in phase 1 and later, while+    the RULE is only active *before* phase 1.  So there's no problem.++    To make this work, we look for the RHS free vars only for+    *active* rules. That's the reason for the occ_rule_act field+    of the OccEnv.++  * Note [Weak loop breakers]+    ~~~~~~~~~~~~~~~~~~~~~~~~~+    There is a last nasty wrinkle.  Suppose we have++        Rec { f = f_rhs+              RULE f [] = g++              h = h_rhs+              g = h+              ...more...+        }++    Remember that we simplify the RULES before any RHS (see Note+    [Rules are visible in their own rec group] above).++    So we must *not* postInlineUnconditionally 'g', even though+    its RHS turns out to be trivial.  (I'm assuming that 'g' is+    not chosen as a loop breaker.)  Why not?  Because then we+    drop the binding for 'g', which leaves it out of scope in the+    RULE!++    Here's a somewhat different example of the same thing+        Rec { g = h+            ; h = ...f...+            ; f = f_rhs+              RULE f [] = g }+    Here the RULE is "below" g, but we *still* can't postInlineUnconditionally+    g, because the RULE for f is active throughout.  So the RHS of h+    might rewrite to     h = ...g...+    So g must remain in scope in the output program!++    We "solve" this by:++        Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True)+        iff g is a "missing free variable" of the Rec group++    A "missing free variable" x is one that is mentioned in an RHS or+    INLINE or RULE of a binding in the Rec group, but where the+    dependency on x may not show up in the loop_breaker_nodes (see+    note [Choosing loop breakers} above).++    A normal "strong" loop breaker has IAmLoopBreaker False.  So++                                    Inline  postInlineUnconditionally+   strong   IAmLoopBreaker False    no      no+   weak     IAmLoopBreaker True     yes     no+            other                   yes     yes++    The **sole** reason for this kind of loop breaker is so that+    postInlineUnconditionally does not fire.  Ugh.  (Typically it'll+    inline via the usual callSiteInline stuff, so it'll be dead in the+    next pass, so the main Ugh is the tiresome complication.)++Note [Rules for imported functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   f = /\a. B.g a+   RULE B.g Int = 1 + f Int+Note that+  * The RULE is for an imported function.+  * f is non-recursive+Now we+can get+   f Int --> B.g Int      Inlining f+         --> 1 + f Int    Firing RULE+and so the simplifier goes into an infinite loop. This+would not happen if the RULE was for a local function,+because we keep track of dependencies through rules.  But+that is pretty much impossible to do for imported Ids.  Suppose+f's definition had been+   f = /\a. C.h a+where (by some long and devious process), C.h eventually inlines to+B.g.  We could only spot such loops by exhaustively following+unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE)+f.++Note that RULES for imported functions are important in practice; they+occur a lot in the libraries.++We regard this potential infinite loop as a *programmer* error.+It's up the programmer not to write silly rules like+     RULE f x = f x+and the example above is just a more complicated version.++Note [Preventing loops due to imported functions rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+  import GHC.Base (foldr)++  {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-}+  filter p xs = build (\c n -> foldr (filterFB c p) n xs)+  filterFB c p = ...++  f = filter p xs++Note that filter is not a loop-breaker, so what happens is:+  f =          filter p xs+    = {inline} build (\c n -> foldr (filterFB c p) n xs)+    = {inline} foldr (filterFB (:) p) [] xs+    = {RULE}   filter p xs++We are in an infinite loop.++A more elaborate example (that I actually saw in practice when I went to+mark GHC.List.filter as INLINABLE) is as follows. Say I have this module:+  {-# LANGUAGE RankNTypes #-}+  module GHCList where++  import Prelude hiding (filter)+  import GHC.Base (build)++  {-# INLINABLE filter #-}+  filter :: (a -> Bool) -> [a] -> [a]+  filter p [] = []+  filter p (x:xs) = if p x then x : filter p xs else filter p xs++  {-# NOINLINE [0] filterFB #-}+  filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b+  filterFB c p x r | p x       = x `c` r+                   | otherwise = r++  {-# RULES+  "filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr+  (filterFB c p) n xs)+  "filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p+   #-}++Then (because RULES are applied inside INLINABLE unfoldings, but inlinings+are not), the unfolding given to "filter" in the interface file will be:+  filter p []     = []+  filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs)+                           else     build (\c n -> foldr (filterFB c p) n xs++Note that because this unfolding does not mention "filter", filter is not+marked as a strong loop breaker. Therefore at a use site in another module:+  filter p xs+    = {inline}+      case xs of []     -> []+                 (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs)+                                  else     build (\c n -> foldr (filterFB c p) n xs)++  build (\c n -> foldr (filterFB c p) n xs)+    = {inline} foldr (filterFB (:) p) [] xs+    = {RULE}   filter p xs++And we are in an infinite loop again, except that this time the loop is producing an+infinitely large *term* (an unrolling of filter) and so the simplifier finally+dies with "ticks exhausted"++Because of this problem, we make a small change in the occurrence analyser+designed to mark functions like "filter" as strong loop breakers on the basis that:+  1. The RHS of filter mentions the local function "filterFB"+  2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS++So for each RULE for an *imported* function we are going to add+dependency edges between the *local* FVS of the rule LHS and the+*local* FVS of the rule RHS. We don't do anything special for RULES on+local functions because the standard occurrence analysis stuff is+pretty good at getting loop-breakerness correct there.++It is important to note that even with this extra hack we aren't always going to get+things right. For example, it might be that the rule LHS mentions an imported Id,+and another module has a RULE that can rewrite that imported Id to one of our local+Ids.++Note [Specialising imported functions] (referred to from Specialise)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+BUT for *automatically-generated* rules, the programmer can't be+responsible for the "programmer error" in Note [Rules for imported+functions].  In particular, consider specialising a recursive function+defined in another module.  If we specialise a recursive function B.g,+we get+         g_spec = .....(B.g Int).....+         RULE B.g Int = g_spec+Here, g_spec doesn't look recursive, but when the rule fires, it+becomes so.  And if B.g was mutually recursive, the loop might+not be as obvious as it is here.++To avoid this,+ * When specialising a function that is a loop breaker,+   give a NOINLINE pragma to the specialised function++Note [Glomming]+~~~~~~~~~~~~~~~+RULES for imported Ids can make something at the top refer to something at the bottom:+        f = \x -> B.g (q x)+        h = \y -> 3++        RULE:  B.g (q x) = h x++Applying this rule makes f refer to h, although f doesn't appear to+depend on h.  (And, as in Note [Rules for imported functions], the+dependency might be more indirect. For example, f might mention C.t+rather than B.g, where C.t eventually inlines to B.g.)++NOTICE that this cannot happen for rules whose head is a+locally-defined function, because we accurately track dependencies+through RULES.  It only happens for rules whose head is an imported+function (B.g in the example above).++Solution:+  - When simplifying, bring all top level identifiers into+    scope at the start, ignoring the Rec/NonRec structure, so+    that when 'h' pops up in f's rhs, we find it in the in-scope set+    (as the simplifier generally expects). This happens in simplTopBinds.++  - In the occurrence analyser, if there are any out-of-scope+    occurrences that pop out of the top, which will happen after+    firing the rule:      f = \x -> h x+                          h = \y -> 3+    then just glom all the bindings into a single Rec, so that+    the *next* iteration of the occurrence analyser will sort+    them all out.   This part happens in occurAnalysePgm.++------------------------------------------------------------+Note [Inline rules]+~~~~~~~~~~~~~~~~~~~+None of the above stuff about RULES applies to Inline Rules,+stored in a CoreUnfolding.  The unfolding, if any, is simplified+at the same time as the regular RHS of the function (ie *not* like+Note [Rules are visible in their own rec group]), so it should be+treated *exactly* like an extra RHS.++Or, rather, when computing loop-breaker edges,+  * If f has an INLINE pragma, and it is active, we treat the+    INLINE rhs as f's rhs+  * If it's inactive, we treat f as having no rhs+  * If it has no INLINE pragma, we look at f's actual rhs+++There is a danger that we'll be sub-optimal if we see this+     f = ...f...+     [INLINE f = ..no f...]+where f is recursive, but the INLINE is not. This can just about+happen with a sufficiently odd set of rules; eg++        foo :: Int -> Int+        {-# INLINE [1] foo #-}+        foo x = x+1++        bar :: Int -> Int+        {-# INLINE [1] bar #-}+        bar x = foo x + 1++        {-# RULES "foo" [~1] forall x. foo x = bar x #-}++Here the RULE makes bar recursive; but it's INLINE pragma remains+non-recursive. It's tempting to then say that 'bar' should not be+a loop breaker, but an attempt to do so goes wrong in two ways:+   a) We may get+         $df = ...$cfoo...+         $cfoo = ...$df....+         [INLINE $cfoo = ...no-$df...]+      But we want $cfoo to depend on $df explicitly so that we+      put the bindings in the right order to inline $df in $cfoo+      and perhaps break the loop altogether.  (Maybe this+   b)+++Example [eftInt]+~~~~~~~~~~~~~~~+Example (from GHC.Enum):++  eftInt :: Int# -> Int# -> [Int]+  eftInt x y = ...(non-recursive)...++  {-# INLINE [0] eftIntFB #-}+  eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r+  eftIntFB c n x y = ...(non-recursive)...++  {-# RULES+  "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)+  "eftIntList"  [1] eftIntFB  (:) [] = eftInt+   #-}++Note [Specialisation rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this group, which is typical of what SpecConstr builds:++   fs a = ....f (C a)....+   f  x = ....f (C a)....+   {-# RULE f (C a) = fs a #-}++So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).++But watch out!  If 'fs' is not chosen as a loop breaker, we may get an infinite loop:+  - the RULE is applied in f's RHS (see Note [Self-recursive rules] in GHC.Core.Op.Simplify+  - fs is inlined (say it's small)+  - now there's another opportunity to apply the RULE++This showed up when compiling Control.Concurrent.Chan.getChanContents.++------------------------------------------------------------+Note [Finding join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~+It's the occurrence analyser's job to find bindings that we can turn into join+points, but it doesn't perform that transformation right away. Rather, it marks+the eligible bindings as part of their occurrence data, leaving it to the+simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'.+The simplifier then eta-expands the RHS if needed and then updates the+occurrence sites. Dividing the work this way means that the occurrence analyser+still only takes one pass, yet one can always tell the difference between a+function call and a jump by looking at the occurrence (because the same pass+changes the 'IdDetails' and propagates the binders to their occurrence sites).++To track potential join points, we use the 'occ_tail' field of OccInfo. A value+of `AlwaysTailCalled n` indicates that every occurrence of the variable is a+tail call with `n` arguments (counting both value and type arguments). Otherwise+'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the+rest of 'OccInfo' until it goes on the binder.++Note [Rules and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Things get fiddly with rules. Suppose we have:++  let j :: Int -> Int+      j y = 2 * y+      k :: Int -> Int -> Int+      {-# RULES "SPEC k 0" k 0 = j #-}+      k x y = x + 2 * y+  in ...++Now suppose that both j and k appear only as saturated tail calls in the body.+Thus we would like to make them both join points. The rule complicates matters,+though, as its RHS has an unapplied occurrence of j. *However*, if we were to+eta-expand the rule, all would be well:++  {-# RULES "SPEC k 0" forall a. k 0 a = j a #-}++So conceivably we could notice that a potential join point would have an+"undersaturated" rule and account for it. This would mean we could make+something that's been specialised a join point, for instance. But local bindings+are rarely specialised, and being overly cautious about rules only+costs us anything when, for some `j`:++  * Before specialisation, `j` has non-tail calls, so it can't be a join point.+  * During specialisation, `j` gets specialised and thus acquires rules.+  * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say),+    and so now `j` *could* become a join point.++This appears to be very rare in practice. TODO Perhaps we should gather+statistics to be sure.++------------------------------------------------------------+Note [Adjusting right-hand sides]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's a bit of a dance we need to do after analysing a lambda expression or+a right-hand side. In particular, we need to++  a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot+     lambda, or a non-recursive join point; and+  b) call 'markAllNonTailCalled' *unless* the binding is for a join point.++Some examples, with how the free occurrences in e (assumed not to be a value+lambda) get marked:++                             inside lam    non-tail-called+  ------------------------------------------------------------+  let x = e                  No            Yes+  let f = \x -> e            Yes           Yes+  let f = \x{OneShot} -> e   No            Yes+  \x -> e                    Yes           Yes+  join j x = e               No            No+  joinrec j x = e            Yes           No++There are a few other caveats; most importantly, if we're marking a binding as+'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so+that the effect cascades properly. Consequently, at the time the RHS is+analysed, we won't know what adjustments to make; thus 'occAnalLamOrRhs' must+return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once+join-point-hood has been decided.++Thus the overall sequence taking place in 'occAnalNonRecBind' and+'occAnalRecBind' is as follows:++  1. Call 'occAnalLamOrRhs' to find usage information for the RHS.+  2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make+     the binding a join point.+  3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when+     recursive.)++(In the recursive case, this logic is spread between 'makeNode' and+'occAnalRec'.)+-}++------------------------------------------------------------------+--                 occAnalBind+------------------------------------------------------------------++occAnalBind :: OccEnv           -- The incoming OccEnv+            -> TopLevelFlag+            -> ImpRuleEdges+            -> CoreBind+            -> UsageDetails             -- Usage details of scope+            -> (UsageDetails,           -- Of the whole let(rec)+                [CoreBind])++occAnalBind env lvl top_env (NonRec binder rhs) body_usage+  = occAnalNonRecBind env lvl top_env binder rhs body_usage+occAnalBind env lvl top_env (Rec pairs) body_usage+  = occAnalRecBind env lvl top_env pairs body_usage++-----------------+occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr+                  -> UsageDetails -> (UsageDetails, [CoreBind])+occAnalNonRecBind env lvl imp_rule_edges binder rhs body_usage+  | isTyVar binder      -- A type let; we don't gather usage info+  = (body_usage, [NonRec binder rhs])++  | not (binder `usedIn` body_usage)    -- It's not mentioned+  = (body_usage, [])++  | otherwise                   -- It's mentioned in the body+  = (body_usage' `andUDs` rhs_usage', [NonRec tagged_binder rhs'])+  where+    (body_usage', tagged_binder) = tagNonRecBinder lvl body_usage binder+    mb_join_arity = willBeJoinId_maybe tagged_binder++    (bndrs, body) = collectBinders rhs++    (rhs_usage1, bndrs', body') = occAnalNonRecRhs env tagged_binder bndrs body+    rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body'+           -- For a /non-recursive/ join point we can mark all+           -- its join-lambda as one-shot; and it's a good idea to do so++    -- Unfoldings+    -- See Note [Unfoldings and join points]+    rhs_usage2 = case occAnalUnfolding env NonRecursive binder of+                   Just unf_usage -> rhs_usage1 `andUDs` unf_usage+                   Nothing        -> rhs_usage1++    -- Rules+    -- See Note [Rules are extra RHSs] and Note [Rule dependency info]+    rules_w_uds = occAnalRules env mb_join_arity NonRecursive tagged_binder+    rule_uds    = map (\(_, l, r) -> l `andUDs` r) rules_w_uds+    rhs_usage3 = foldr andUDs rhs_usage2 rule_uds+    rhs_usage4 = case lookupVarEnv imp_rule_edges binder of+                   Nothing -> rhs_usage3+                   Just vs -> addManyOccsSet rhs_usage3 vs+       -- See Note [Preventing loops due to imported functions rules]++    -- Final adjustment+    rhs_usage' = adjustRhsUsage mb_join_arity NonRecursive bndrs' rhs_usage4++-----------------+occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]+               -> UsageDetails -> (UsageDetails, [CoreBind])+occAnalRecBind env lvl imp_rule_edges pairs body_usage+  = foldr (occAnalRec env lvl) (body_usage, []) sccs+        -- For a recursive group, we+        --      * occ-analyse all the RHSs+        --      * compute strongly-connected components+        --      * feed those components to occAnalRec+        -- See Note [Recursive bindings: the grand plan]+  where+    sccs :: [SCC Details]+    sccs = {-# SCC "occAnalBind.scc" #-}+           stronglyConnCompFromEdgedVerticesUniq nodes++    nodes :: [LetrecNode]+    nodes = {-# SCC "occAnalBind.assoc" #-}+            map (makeNode env imp_rule_edges bndr_set) pairs++    bndr_set = mkVarSet (map fst pairs)++{-+Note [Unfoldings and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We assume that anything in an unfolding occurs multiple times, since unfoldings+are often copied (that's the whole point!). But we still need to track tail+calls for the purpose of finding join points.+-}++-----------------------------+occAnalRec :: OccEnv -> TopLevelFlag+           -> SCC Details+           -> (UsageDetails, [CoreBind])+           -> (UsageDetails, [CoreBind])++        -- The NonRec case is just like a Let (NonRec ...) above+occAnalRec _ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs+                                 , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs }))+           (body_uds, binds)+  | not (bndr `usedIn` body_uds)+  = (body_uds, binds)           -- See Note [Dead code]++  | otherwise                   -- It's mentioned in the body+  = (body_uds' `andUDs` rhs_uds',+     NonRec tagged_bndr rhs : binds)+  where+    (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr+    rhs_uds' = adjustRhsUsage (willBeJoinId_maybe tagged_bndr) NonRecursive+                              rhs_bndrs rhs_uds++        -- The Rec case is the interesting one+        -- See Note [Recursive bindings: the grand plan]+        -- See Note [Loop breaking]+occAnalRec env lvl (CyclicSCC details_s) (body_uds, binds)+  | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds+  = (body_uds, binds)                   -- See Note [Dead code]++  | otherwise   -- At this point we always build a single Rec+  = -- pprTrace "occAnalRec" (vcat+    --  [ text "weak_fvs" <+> ppr weak_fvs+    --  , text "lb nodes" <+> ppr loop_breaker_nodes])+    (final_uds, Rec pairs : binds)++  where+    bndrs    = map nd_bndr details_s+    bndr_set = mkVarSet bndrs++    ------------------------------+        -- See Note [Choosing loop breakers] for loop_breaker_nodes+    final_uds :: UsageDetails+    loop_breaker_nodes :: [LetrecNode]+    (final_uds, loop_breaker_nodes)+      = mkLoopBreakerNodes env lvl bndr_set body_uds details_s++    ------------------------------+    weak_fvs :: VarSet+    weak_fvs = mapUnionVarSet nd_weak details_s++    ---------------------------+    -- Now reconstruct the cycle+    pairs :: [(Id,CoreExpr)]+    pairs | isEmptyVarSet weak_fvs = reOrderNodes   0 bndr_set weak_fvs loop_breaker_nodes []+          | otherwise              = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_nodes []+          -- If weak_fvs is empty, the loop_breaker_nodes will include+          -- all the edges in the original scope edges [remember,+          -- weak_fvs is the difference between scope edges and+          -- lb-edges], so a fresh SCC computation would yield a+          -- single CyclicSCC result; and reOrderNodes deals with+          -- exactly that case+++------------------------------------------------------------------+--                 Loop breaking+------------------------------------------------------------------++type Binding = (Id,CoreExpr)++loopBreakNodes :: Int+               -> VarSet        -- All binders+               -> VarSet        -- Binders whose dependencies may be "missing"+                                -- See Note [Weak loop breakers]+               -> [LetrecNode]+               -> [Binding]             -- Append these to the end+               -> [Binding]+{-+loopBreakNodes is applied to the list of nodes for a cyclic strongly+connected component (there's guaranteed to be a cycle).  It returns+the same nodes, but+        a) in a better order,+        b) with some of the Ids having a IAmALoopBreaker pragma++The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means+that the simplifier can guarantee not to loop provided it never records an inlining+for these no-inline guys.++Furthermore, the order of the binds is such that if we neglect dependencies+on the no-inline Ids then the binds are topologically sorted.  This means+that the simplifier will generally do a good job if it works from top bottom,+recording inlinings for any Ids which aren't marked as "no-inline" as it goes.+-}++-- Return the bindings sorted into a plausible order, and marked with loop breakers.+loopBreakNodes depth bndr_set weak_fvs nodes binds+  = -- pprTrace "loopBreakNodes" (ppr nodes) $+    go (stronglyConnCompFromEdgedVerticesUniqR nodes) binds+  where+    go []         binds = binds+    go (scc:sccs) binds = loop_break_scc scc (go sccs binds)++    loop_break_scc scc binds+      = case scc of+          AcyclicSCC node  -> mk_non_loop_breaker weak_fvs node : binds+          CyclicSCC nodes  -> reOrderNodes depth bndr_set weak_fvs nodes binds++----------------------------------+reOrderNodes :: Int -> VarSet -> VarSet -> [LetrecNode] -> [Binding] -> [Binding]+    -- Choose a loop breaker, mark it no-inline,+    -- and call loopBreakNodes on the rest+reOrderNodes _ _ _ []     _     = panic "reOrderNodes"+reOrderNodes _ _ _ [node] binds = mk_loop_breaker node : binds+reOrderNodes depth bndr_set weak_fvs (node : nodes) binds+  = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen+    --                              , text "chosen" <+> ppr chosen_nodes ]) $+    loopBreakNodes new_depth bndr_set weak_fvs unchosen $+    (map mk_loop_breaker chosen_nodes ++ binds)+  where+    (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb+                                                 (nd_score (node_payload node))+                                                 [node] [] nodes++    approximate_lb = depth >= 2+    new_depth | approximate_lb = 0+              | otherwise      = depth+1+        -- After two iterations (d=0, d=1) give up+        -- and approximate, returning to d=0++mk_loop_breaker :: LetrecNode -> Binding+mk_loop_breaker (node_payload -> ND { nd_bndr = bndr, nd_rhs = rhs})+  = (bndr `setIdOccInfo` strongLoopBreaker { occ_tail = tail_info }, rhs)+  where+    tail_info = tailCallInfo (idOccInfo bndr)++mk_non_loop_breaker :: VarSet -> LetrecNode -> Binding+-- See Note [Weak loop breakers]+mk_non_loop_breaker weak_fvs (node_payload -> ND { nd_bndr = bndr+                                                 , nd_rhs = rhs})+  | bndr `elemVarSet` weak_fvs = (setIdOccInfo bndr occ', rhs)+  | otherwise                  = (bndr, rhs)+  where+    occ' = weakLoopBreaker { occ_tail = tail_info }+    tail_info = tailCallInfo (idOccInfo bndr)++----------------------------------+chooseLoopBreaker :: Bool             -- True <=> Too many iterations,+                                      --          so approximate+                  -> NodeScore            -- Best score so far+                  -> [LetrecNode]       -- Nodes with this score+                  -> [LetrecNode]       -- Nodes with higher scores+                  -> [LetrecNode]       -- Unprocessed nodes+                  -> ([LetrecNode], [LetrecNode])+    -- This loop looks for the bind with the lowest score+    -- to pick as the loop  breaker.  The rest accumulate in+chooseLoopBreaker _ _ loop_nodes acc []+  = (loop_nodes, acc)        -- Done++    -- If approximate_loop_breaker is True, we pick *all*+    -- nodes with lowest score, else just one+    -- See Note [Complexity of loop breaking]+chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes)+  | approx_lb+  , rank sc == rank loop_sc+  = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes++  | sc `betterLB` loop_sc  -- Better score so pick this new one+  = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes++  | otherwise              -- Worse score so don't pick it+  = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes+  where+    sc = nd_score (node_payload node)++{-+Note [Complexity of loop breaking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The loop-breaking algorithm knocks out one binder at a time, and+performs a new SCC analysis on the remaining binders.  That can+behave very badly in tightly-coupled groups of bindings; in the+worst case it can be (N**2)*log N, because it does a full SCC+on N, then N-1, then N-2 and so on.++To avoid this, we switch plans after 2 (or whatever) attempts:+  Plan A: pick one binder with the lowest score, make it+          a loop breaker, and try again+  Plan B: pick *all* binders with the lowest score, make them+          all loop breakers, and try again+Since there are only a small finite number of scores, this will+terminate in a constant number of iterations, rather than O(N)+iterations.++You might thing that it's very unlikely, but RULES make it much+more likely.  Here's a real example from #1969:+  Rec { $dm = \d.\x. op d+        {-# RULES forall d. $dm Int d  = $s$dm1+                  forall d. $dm Bool d = $s$dm2 #-}++        dInt = MkD .... opInt ...+        dInt = MkD .... opBool ...+        opInt  = $dm dInt+        opBool = $dm dBool++        $s$dm1 = \x. op dInt+        $s$dm2 = \x. op dBool }+The RULES stuff means that we can't choose $dm as a loop breaker+(Note [Choosing loop breakers]), so we must choose at least (say)+opInt *and* opBool, and so on.  The number of loop breakders is+linear in the number of instance declarations.++Note [Loop breakers and INLINE/INLINABLE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Avoid choosing a function with an INLINE pramga as the loop breaker!+If such a function is mutually-recursive with a non-INLINE thing,+then the latter should be the loop-breaker.++It's vital to distinguish between INLINE and INLINABLE (the+Bool returned by hasStableCoreUnfolding_maybe).  If we start with+   Rec { {-# INLINABLE f #-}+         f x = ...f... }+and then worker/wrapper it through strictness analysis, we'll get+   Rec { {-# INLINABLE $wf #-}+         $wf p q = let x = (p,q) in ...f...++         {-# INLINE f #-}+         f x = case x of (p,q) -> $wf p q }++Now it is vital that we choose $wf as the loop breaker, so we can+inline 'f' in '$wf'.++Note [DFuns should not be loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's particularly bad to make a DFun into a loop breaker.  See+Note [How instance declarations are translated] in TcInstDcls++We give DFuns a higher score than ordinary CONLIKE things because+if there's a choice we want the DFun to be the non-loop breaker. Eg++rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)++      $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)+      {-# DFUN #-}+      $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)+    }++Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it+if we can't unravel the DFun first.++Note [Constructor applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's really really important to inline dictionaries.  Real+example (the Enum Ordering instance from GHC.Base):++     rec     f = \ x -> case d of (p,q,r) -> p x+             g = \ x -> case d of (p,q,r) -> q x+             d = (v, f, g)++Here, f and g occur just once; but we can't inline them into d.+On the other hand we *could* simplify those case expressions if+we didn't stupidly choose d as the loop breaker.+But we won't because constructor args are marked "Many".+Inlining dictionaries is really essential to unravelling+the loops in static numeric dictionaries, see GHC.Float.++Note [Closure conversion]+~~~~~~~~~~~~~~~~~~~~~~~~~+We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.+The immediate motivation came from the result of a closure-conversion transformation+which generated code like this:++    data Clo a b = forall c. Clo (c -> a -> b) c++    ($:) :: Clo a b -> a -> b+    Clo f env $: x = f env x++    rec { plus = Clo plus1 ()++        ; plus1 _ n = Clo plus2 n++        ; plus2 Zero     n = n+        ; plus2 (Succ m) n = Succ (plus $: m $: n) }++If we inline 'plus' and 'plus1', everything unravels nicely.  But if+we choose 'plus1' as the loop breaker (which is entirely possible+otherwise), the loop does not unravel nicely.+++@occAnalUnfolding@ deals with the question of bindings where the Id is marked+by an INLINE pragma.  For these we record that anything which occurs+in its RHS occurs many times.  This pessimistically assumes that this+inlined binder also occurs many times in its scope, but if it doesn't+we'll catch it next time round.  At worst this costs an extra simplifier pass.+ToDo: try using the occurrence info for the inline'd binder.++[March 97] We do the same for atomic RHSs.  Reason: see notes with loopBreakSCC.+[June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with loopBreakSCC.+++************************************************************************+*                                                                      *+                   Making nodes+*                                                                      *+************************************************************************+-}++type ImpRuleEdges = IdEnv IdSet     -- Mapping from FVs of imported RULE LHSs to RHS FVs++noImpRuleEdges :: ImpRuleEdges+noImpRuleEdges = emptyVarEnv++type LetrecNode = Node Unique Details  -- Node comes from Digraph+                                       -- The Unique key is gotten from the Id+data Details+  = ND { nd_bndr :: Id          -- Binder+       , nd_rhs  :: CoreExpr    -- RHS, already occ-analysed+       , nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS+                                    -- INVARIANT: (nd_rhs_bndrs nd, _) ==+                                    --              collectBinders (nd_rhs nd)++       , nd_uds  :: UsageDetails  -- Usage from RHS, and RULES, and stable unfoldings+                                  -- ignoring phase (ie assuming all are active)+                                  -- See Note [Forming Rec groups]++       , nd_inl  :: IdSet       -- Free variables of+                                --   the stable unfolding (if present and active)+                                --   or the RHS (if not)+                                -- but excluding any RULES+                                -- This is the IdSet that may be used if the Id is inlined++       , nd_weak :: IdSet       -- Binders of this Rec that are mentioned in nd_uds+                                -- but are *not* in nd_inl.  These are the ones whose+                                -- dependencies might not be respected by loop_breaker_nodes+                                -- See Note [Weak loop breakers]++       , nd_active_rule_fvs :: IdSet   -- Free variables of the RHS of active RULES++       , nd_score :: NodeScore+  }++instance Outputable Details where+   ppr nd = text "ND" <> braces+             (sep [ text "bndr =" <+> ppr (nd_bndr nd)+                  , text "uds =" <+> ppr (nd_uds nd)+                  , text "inl =" <+> ppr (nd_inl nd)+                  , text "weak =" <+> ppr (nd_weak nd)+                  , text "rule =" <+> ppr (nd_active_rule_fvs nd)+                  , text "score =" <+> ppr (nd_score nd)+             ])++-- The NodeScore is compared lexicographically;+--      e.g. lower rank wins regardless of size+type NodeScore = ( Int     -- Rank: lower => more likely to be picked as loop breaker+                 , Int     -- Size of rhs: higher => more likely to be picked as LB+                           -- Maxes out at maxExprSize; we just use it to prioritise+                           -- small functions+                 , Bool )  -- Was it a loop breaker before?+                           -- True => more likely to be picked+                           -- Note [Loop breakers, node scoring, and stability]++rank :: NodeScore -> Int+rank (r, _, _) = r++makeNode :: OccEnv -> ImpRuleEdges -> VarSet+         -> (Var, CoreExpr) -> LetrecNode+-- See Note [Recursive bindings: the grand plan]+makeNode env imp_rule_edges bndr_set (bndr, rhs)+  = DigraphNode details (varUnique bndr) (nonDetKeysUniqSet node_fvs)+    -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR+    -- is still deterministic with edges in nondeterministic order as+    -- explained in Note [Deterministic SCC] in Digraph.+  where+    details = ND { nd_bndr            = bndr+                 , nd_rhs             = rhs'+                 , nd_rhs_bndrs       = bndrs'+                 , nd_uds             = rhs_usage3+                 , nd_inl             = inl_fvs+                 , nd_weak            = node_fvs `minusVarSet` inl_fvs+                 , nd_active_rule_fvs = active_rule_fvs+                 , nd_score           = pprPanic "makeNodeDetails" (ppr bndr) }++    -- Constructing the edges for the main Rec computation+    -- See Note [Forming Rec groups]+    (bndrs, body) = collectBinders rhs+    (rhs_usage1, bndrs', body') = occAnalRecRhs env bndrs body+    rhs' = mkLams bndrs' body'+    rhs_usage2 = foldr andUDs rhs_usage1 rule_uds+                   -- Note [Rules are extra RHSs]+                   -- Note [Rule dependency info]+    rhs_usage3 = case mb_unf_uds of+                   Just unf_uds -> rhs_usage2 `andUDs` unf_uds+                   Nothing      -> rhs_usage2+    node_fvs = udFreeVars bndr_set rhs_usage3++    -- Finding the free variables of the rules+    is_active = occ_rule_act env :: Activation -> Bool++    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]+    rules_w_uds = occAnalRules env (Just (length bndrs)) Recursive bndr++    rules_w_rhs_fvs :: [(Activation, VarSet)]    -- Find the RHS fvs+    rules_w_rhs_fvs = maybe id (\ids -> ((AlwaysActive, ids):))+                               (lookupVarEnv imp_rule_edges bndr)+      -- See Note [Preventing loops due to imported functions rules]+                      [ (ru_act rule, udFreeVars bndr_set rhs_uds)+                      | (rule, _, rhs_uds) <- rules_w_uds ]+    rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds+    active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_rhs_fvs+                                        , is_active a]++    -- Finding the usage details of the INLINE pragma (if any)+    mb_unf_uds = occAnalUnfolding env Recursive bndr++    -- Find the "nd_inl" free vars; for the loop-breaker phase+    inl_fvs = case mb_unf_uds of+                Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS+                Just unf_uds -> udFreeVars bndr_set unf_uds+                      -- We could check for an *active* INLINE (returning+                      -- emptyVarSet for an inactive one), but is_active+                      -- isn't the right thing (it tells about+                      -- RULE activation), so we'd need more plumbing++mkLoopBreakerNodes :: OccEnv -> TopLevelFlag+                   -> VarSet+                   -> UsageDetails   -- for BODY of let+                   -> [Details]+                   -> (UsageDetails, -- adjusted+                       [LetrecNode])+-- Does four things+--   a) tag each binder with its occurrence info+--   b) add a NodeScore to each node+--   c) make a Node with the right dependency edges for+--      the loop-breaker SCC analysis+--   d) adjust each RHS's usage details according to+--      the binder's (new) shotness and join-point-hood+mkLoopBreakerNodes env lvl bndr_set body_uds details_s+  = (final_uds, zipWith mk_lb_node details_s bndrs')+  where+    (final_uds, bndrs') = tagRecBinders lvl body_uds+                            [ ((nd_bndr nd)+                               ,(nd_uds nd)+                               ,(nd_rhs_bndrs nd))+                            | nd <- details_s ]+    mk_lb_node nd@(ND { nd_bndr = bndr, nd_rhs = rhs, nd_inl = inl_fvs }) bndr'+      = DigraphNode nd' (varUnique bndr) (nonDetKeysUniqSet lb_deps)+              -- It's OK to use nonDetKeysUniqSet here as+              -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges+              -- in nondeterministic order as explained in+              -- Note [Deterministic SCC] in Digraph.+      where+        nd'     = nd { nd_bndr = bndr', nd_score = score }+        score   = nodeScore env bndr bndr' rhs lb_deps+        lb_deps = extendFvs_ rule_fv_env inl_fvs++    rule_fv_env :: IdEnv IdSet+        -- Maps a variable f to the variables from this group+        --      mentioned in RHS of active rules for f+        -- Domain is *subset* of bound vars (others have no rule fvs)+    rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs)+    init_rule_fvs   -- See Note [Finding rule RHS free vars]+      = [ (b, trimmed_rule_fvs)+        | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s+        , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set+        , not (isEmptyVarSet trimmed_rule_fvs) ]+++------------------------------------------+nodeScore :: OccEnv+          -> Id        -- Binder has old occ-info (just for loop-breaker-ness)+          -> Id        -- Binder with new occ-info+          -> CoreExpr  -- RHS+          -> VarSet    -- Loop-breaker dependencies+          -> NodeScore+nodeScore env old_bndr new_bndr bind_rhs lb_deps+  | not (isId old_bndr)     -- A type or coercion variable is never a loop breaker+  = (100, 0, False)++  | old_bndr `elemVarSet` lb_deps  -- Self-recursive things are great loop breakers+  = (0, 0, True)                   -- See Note [Self-recursion and loop breakers]++  | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has+  = (0, 0, True)                   -- a NOINLINE pragma) makes a great loop breaker++  | exprIsTrivial rhs+  = mk_score 10  -- Practically certain to be inlined+    -- Used to have also: && not (isExportedId bndr)+    -- But I found this sometimes cost an extra iteration when we have+    --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }+    -- where df is the exported dictionary. Then df makes a really+    -- bad choice for loop breaker++  | DFunUnfolding { df_args = args } <- id_unfolding+    -- Never choose a DFun as a loop breaker+    -- Note [DFuns should not be loop breakers]+  = (9, length args, is_lb)++    -- Data structures are more important than INLINE pragmas+    -- so that dictionary/method recursion unravels++  | CoreUnfolding { uf_guidance = UnfWhen {} } <- id_unfolding+  = mk_score 6++  | is_con_app rhs   -- Data types help with cases:+  = mk_score 5       -- Note [Constructor applications]++  | isStableUnfolding id_unfolding+  , can_unfold+  = mk_score 3++  | isOneOcc (idOccInfo new_bndr)+  = mk_score 2  -- Likely to be inlined++  | can_unfold  -- The Id has some kind of unfolding+  = mk_score 1++  | otherwise+  = (0, 0, is_lb)++  where+    mk_score :: Int -> NodeScore+    mk_score rank = (rank, rhs_size, is_lb)++    is_lb    = isStrongLoopBreaker (idOccInfo old_bndr)+    rhs      = case id_unfolding of+                 CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs }+                    | isStableSource src+                    -> unf_rhs+                 _  -> bind_rhs+       -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding+    rhs_size = case id_unfolding of+                 CoreUnfolding { uf_guidance = guidance }+                    | UnfIfGoodArgs { ug_size = size } <- guidance+                    -> size+                 _  -> cheapExprSize rhs++    can_unfold   = canUnfold id_unfolding+    id_unfolding = realIdUnfolding old_bndr+       -- realIdUnfolding: Ignore loop-breaker-ness here because+       -- that is what we are setting!++        -- Checking for a constructor application+        -- Cheap and cheerful; the simplifier moves casts out of the way+        -- The lambda case is important to spot x = /\a. C (f a)+        -- which comes up when C is a dictionary constructor and+        -- f is a default method.+        -- Example: the instance for Show (ST s a) in GHC.ST+        --+        -- However we *also* treat (\x. C p q) as a con-app-like thing,+        --      Note [Closure conversion]+    is_con_app (Var v)    = isConLikeId v+    is_con_app (App f _)  = is_con_app f+    is_con_app (Lam _ e)  = is_con_app e+    is_con_app (Tick _ e) = is_con_app e+    is_con_app _          = False++maxExprSize :: Int+maxExprSize = 20  -- Rather arbitrary++cheapExprSize :: CoreExpr -> Int+-- Maxes out at maxExprSize+cheapExprSize e+  = go 0 e+  where+    go n e | n >= maxExprSize = n+           | otherwise        = go1 n e++    go1 n (Var {})        = n+1+    go1 n (Lit {})        = n+1+    go1 n (Type {})       = n+    go1 n (Coercion {})   = n+    go1 n (Tick _ e)      = go1 n e+    go1 n (Cast e _)      = go1 n e+    go1 n (App f a)       = go (go1 n f) a+    go1 n (Lam b e)+      | isTyVar b         = go1 n e+      | otherwise         = go (n+1) e+    go1 n (Let b e)       = gos (go1 n e) (rhssOfBind b)+    go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as)++    gos n [] = n+    gos n (e:es) | n >= maxExprSize = n+                 | otherwise        = gos (go1 n e) es++betterLB :: NodeScore -> NodeScore -> Bool+-- If  n1 `betterLB` n2  then choose n1 as the loop breaker+betterLB (rank1, size1, lb1) (rank2, size2, _)+  | rank1 < rank2 = True+  | rank1 > rank2 = False+  | size1 < size2 = False   -- Make the bigger n2 into the loop breaker+  | size1 > size2 = True+  | lb1           = True    -- Tie-break: if n1 was a loop breaker before, choose it+  | otherwise     = False   -- See Note [Loop breakers, node scoring, and stability]++{- Note [Self-recursion and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+   rec { f = ...f...g...+       ; g = .....f...   }+then 'f' has to be a loop breaker anyway, so we may as well choose it+right away, so that g can inline freely.++This is really just a cheap hack. Consider+   rec { f = ...g...+       ; g = ..f..h...+      ;  h = ...f....}+Here f or g are better loop breakers than h; but we might accidentally+choose h.  Finding the minimal set of loop breakers is hard.++Note [Loop breakers, node scoring, and stability]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To choose a loop breaker, we give a NodeScore to each node in the SCC,+and pick the one with the best score (according to 'betterLB').++We need to be jolly careful (#12425, #12234) about the stability+of this choice. Suppose we have++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...f..+      False -> ..f...++In each iteration of the simplifier the occurrence analyser OccAnal+chooses a loop breaker. Suppose in iteration 1 it choose g as the loop+breaker. That means it is free to inline f.++Suppose that GHC decides to inline f in the branches of the case, but+(for some reason; eg it is not saturated) in the rhs of g. So we get++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...g...g.....+      False -> ..g..g....++Now suppose that, for some reason, in the next iteration the occurrence+analyser chooses f as the loop breaker, so it can freely inline g. And+again for some reason the simplifier inlines g at its calls in the case+branches, but not in the RHS of f. Then we get++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...(...f...f...)...(...f..f..).....+      False -> ..(...f...f...)...(..f..f...)....++You can see where this is going! Each iteration of the simplifier+doubles the number of calls to f or g. No wonder GHC is slow!++(In the particular example in comment:3 of #12425, f and g are the two+mutually recursive fmap instances for CondT and Result. They are both+marked INLINE which, oddly, is why they don't inline in each other's+RHS, because the call there is not saturated.)++The root cause is that we flip-flop on our choice of loop breaker. I+always thought it didn't matter, and indeed for any single iteration+to terminate, it doesn't matter. But when we iterate, it matters a+lot!!++So The Plan is this:+   If there is a tie, choose the node that+   was a loop breaker last time round++Hence the is_lb field of NodeScore++************************************************************************+*                                                                      *+                   Right hand sides+*                                                                      *+************************************************************************+-}++occAnalRhs :: OccEnv -> RecFlag -> Id -> [CoreBndr] -> CoreExpr+           -> (UsageDetails, [CoreBndr], CoreExpr)+              -- Returned usage details covers only the RHS,+              -- and *not* the RULE or INLINE template for the Id+occAnalRhs env Recursive _ bndrs body+  = occAnalRecRhs env bndrs body+occAnalRhs env NonRecursive id bndrs body+  = occAnalNonRecRhs env id bndrs body++occAnalRecRhs :: OccEnv -> [CoreBndr] -> CoreExpr    -- Rhs lambdas, body+           -> (UsageDetails, [CoreBndr], CoreExpr)+              -- Returned usage details covers only the RHS,+              -- and *not* the RULE or INLINE template for the Id+occAnalRecRhs env bndrs body = occAnalLamOrRhs (rhsCtxt env) bndrs body++occAnalNonRecRhs :: OccEnv+                 -> Id -> [CoreBndr] -> CoreExpr    -- Binder; rhs lams, body+                     -- Binder is already tagged with occurrence info+                 -> (UsageDetails, [CoreBndr], CoreExpr)+              -- Returned usage details covers only the RHS,+              -- and *not* the RULE or INLINE template for the Id+occAnalNonRecRhs env bndr bndrs body+  = occAnalLamOrRhs rhs_env bndrs body+  where+    env1 | is_join_point    = env  -- See Note [Join point RHSs]+         | certainly_inline = env  -- See Note [Cascading inlines]+         | otherwise        = rhsCtxt env++    -- See Note [Sources of one-shot information]+    rhs_env = env1 { occ_one_shots = argOneShots dmd }++    certainly_inline -- See Note [Cascading inlines]+      = case occ of+          OneOcc { occ_in_lam = NotInsideLam, occ_one_br = InOneBranch }+            -> active && not_stable+          _ -> False++    is_join_point = isAlwaysTailCalled occ+    -- Like (isJoinId bndr) but happens one step earlier+    --  c.f. willBeJoinId_maybe++    occ        = idOccInfo bndr+    dmd        = idDemandInfo bndr+    active     = isAlwaysActive (idInlineActivation bndr)+    not_stable = not (isStableUnfolding (idUnfolding bndr))++occAnalUnfolding :: OccEnv+                 -> RecFlag+                 -> Id+                 -> Maybe UsageDetails+                      -- Just the analysis, not a new unfolding. The unfolding+                      -- got analysed when it was created and we don't need to+                      -- update it.+occAnalUnfolding env rec_flag id+  = case realIdUnfolding id of -- ignore previous loop-breaker flag+      CoreUnfolding { uf_tmpl = rhs, uf_src = src }+        | not (isStableSource src)+        -> Nothing+        | otherwise+        -> Just $ markAllMany usage+        where+          (bndrs, body) = collectBinders rhs+          (usage, _, _) = occAnalRhs env rec_flag id bndrs body++      DFunUnfolding { df_bndrs = bndrs, df_args = args }+        -> Just $ zapDetails (delDetailsList usage bndrs)+        where+          usage = andUDsList (map (fst . occAnal env) args)++      _ -> Nothing++occAnalRules :: OccEnv+             -> Maybe JoinArity -- If the binder is (or MAY become) a join+                                -- point, what its join arity is (or WOULD+                                -- become). See Note [Rules and join points].+             -> RecFlag+             -> Id+             -> [(CoreRule,      -- Each (non-built-in) rule+                  UsageDetails,  -- Usage details for LHS+                  UsageDetails)] -- Usage details for RHS+occAnalRules env mb_expected_join_arity rec_flag id+  = [ (rule, lhs_uds, rhs_uds) | rule@Rule {} <- idCoreRules id+                               , let (lhs_uds, rhs_uds) = occ_anal_rule rule ]+  where+    occ_anal_rule (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })+      = (lhs_uds, final_rhs_uds)+      where+        lhs_uds = addManyOccsSet emptyDetails $+                    (exprsFreeVars args `delVarSetList` bndrs)+        (rhs_bndrs, rhs_body) = collectBinders rhs+        (rhs_uds, _, _) = occAnalRhs env rec_flag id rhs_bndrs rhs_body+                            -- Note [Rules are extra RHSs]+                            -- Note [Rule dependency info]+        final_rhs_uds = adjust_tail_info args $ markAllMany $+                          (rhs_uds `delDetailsList` bndrs)+    occ_anal_rule _+      = (emptyDetails, emptyDetails)++    adjust_tail_info args uds -- see Note [Rules and join points]+      = case mb_expected_join_arity of+          Just ar | args `lengthIs` ar -> uds+          _                            -> markAllNonTailCalled uds+{- Note [Join point RHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   x = e+   join j = Just x++We want to inline x into j right away, so we don't want to give+the join point a RhsCtxt (#14137).  It's not a huge deal, because+the FloatIn pass knows to float into join point RHSs; and the simplifier+does not float things out of join point RHSs.  But it's a simple, cheap+thing to do.  See #14137.++Note [Cascading inlines]+~~~~~~~~~~~~~~~~~~~~~~~~+By default we use an rhsCtxt for the RHS of a binding.  This tells the+occ anal n that it's looking at an RHS, which has an effect in+occAnalApp.  In particular, for constructor applications, it makes+the arguments appear to have NoOccInfo, so that we don't inline into+them. Thus    x = f y+              k = Just x+we do not want to inline x.++But there's a problem.  Consider+     x1 = a0 : []+     x2 = a1 : x1+     x3 = a2 : x2+     g  = f x3+First time round, it looks as if x1 and x2 occur as an arg of a+let-bound constructor ==> give them a many-occurrence.+But then x3 is inlined (unconditionally as it happens) and+next time round, x2 will be, and the next time round x1 will be+Result: multiple simplifier iterations.  Sigh.++So, when analysing the RHS of x3 we notice that x3 will itself+definitely inline the next time round, and so we analyse x3's rhs in+an ordinary context, not rhsCtxt.  Hence the "certainly_inline" stuff.++Annoyingly, we have to approximate GHC.Core.Op.Simplify.Utils.preInlineUnconditionally.+If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and+   (b) certainly_inline says "yes" when preInlineUnconditionally says "no"+then the simplifier iterates indefinitely:+        x = f y+        k = Just x   -- We decide that k is 'certainly_inline'+        v = ...k...  -- but preInlineUnconditionally doesn't inline it+inline ==>+        k = Just (f y)+        v = ...k...+float ==>+        x1 = f y+        k = Just x1+        v = ...k...++This is worse than the slow cascade, so we only want to say "certainly_inline"+if it really is certain.  Look at the note with preInlineUnconditionally+for the various clauses.+++************************************************************************+*                                                                      *+                Expressions+*                                                                      *+************************************************************************+-}++occAnal :: OccEnv+        -> CoreExpr+        -> (UsageDetails,       -- Gives info only about the "interesting" Ids+            CoreExpr)++occAnal _   expr@(Type _) = (emptyDetails,         expr)+occAnal _   expr@(Lit _)  = (emptyDetails,         expr)+occAnal env expr@(Var _)  = occAnalApp env (expr, [], [])+    -- At one stage, I gathered the idRuleVars for the variable here too,+    -- which in a way is the right thing to do.+    -- But that went wrong right after specialisation, when+    -- the *occurrences* of the overloaded function didn't have any+    -- rules in them, so the *specialised* versions looked as if they+    -- weren't used at all.++occAnal _ (Coercion co)+  = (addManyOccsSet emptyDetails (coVarsOfCo co), Coercion co)+        -- See Note [Gather occurrences of coercion variables]++{-+Note [Gather occurrences of coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to gather info about what coercion variables appear, so that+we can sort them into the right place when doing dependency analysis.+-}++occAnal env (Tick tickish body)+  | SourceNote{} <- tickish+  = (usage, Tick tickish body')+                  -- SourceNotes are best-effort; so we just proceed as usual.+                  -- If we drop a tick due to the issues described below it's+                  -- not the end of the world.++  | tickish `tickishScopesLike` SoftScope+  = (markAllNonTailCalled usage, Tick tickish body')++  | Breakpoint _ ids <- tickish+  = (usage_lam `andUDs` foldr addManyOccs emptyDetails ids, Tick tickish body')+    -- never substitute for any of the Ids in a Breakpoint++  | otherwise+  = (usage_lam, Tick tickish body')+  where+    !(usage,body') = occAnal env body+    -- for a non-soft tick scope, we can inline lambdas only+    usage_lam = markAllNonTailCalled (markAllInsideLam usage)+                  -- TODO There may be ways to make ticks and join points play+                  -- nicer together, but right now there are problems:+                  --   let j x = ... in tick<t> (j 1)+                  -- Making j a join point may cause the simplifier to drop t+                  -- (if the tick is put into the continuation). So we don't+                  -- count j 1 as a tail call.+                  -- See #14242.++occAnal env (Cast expr co)+  = case occAnal env expr of { (usage, expr') ->+    let usage1 = zapDetailsIf (isRhsEnv env) usage+          -- usage1: if we see let x = y `cast` co+          -- then mark y as 'Many' so that we don't+          -- immediately inline y again.+        usage2 = addManyOccsSet usage1 (coVarsOfCo co)+          -- usage2: see Note [Gather occurrences of coercion variables]+    in (markAllNonTailCalled usage2, Cast expr' co)+    }++occAnal env app@(App _ _)+  = occAnalApp env (collectArgsTicks tickishFloatable app)++-- Ignore type variables altogether+--   (a) occurrences inside type lambdas only not marked as InsideLam+--   (b) type variables not in environment++occAnal env (Lam x body)+  | isTyVar x+  = case occAnal env body of { (body_usage, body') ->+    (markAllNonTailCalled body_usage, Lam x body')+    }++-- For value lambdas we do a special hack.  Consider+--      (\x. \y. ...x...)+-- If we did nothing, x is used inside the \y, so would be marked+-- as dangerous to dup.  But in the common case where the abstraction+-- is applied to two arguments this is over-pessimistic.+-- So instead, we just mark each binder with its occurrence+-- info in the *body* of the multiple lambda.+-- Then, the simplifier is careful when partially applying lambdas.++occAnal env expr@(Lam _ _)+  = case occAnalLamOrRhs env binders body of { (usage, tagged_binders, body') ->+    let+        expr'       = mkLams tagged_binders body'+        usage1      = markAllNonTailCalled usage+        one_shot_gp = all isOneShotBndr tagged_binders+        final_usage | one_shot_gp = usage1+                    | otherwise   = markAllInsideLam usage1+    in+    (final_usage, expr') }+  where+    (binders, body) = collectBinders expr++occAnal env (Case scrut bndr ty alts)+  = case occ_anal_scrut scrut alts     of { (scrut_usage, scrut') ->+    case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts')   ->+    let+        alts_usage  = foldr orUDs emptyDetails alts_usage_s+        (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr+        total_usage = markAllNonTailCalled scrut_usage `andUDs` alts_usage1+                        -- Alts can have tail calls, but the scrutinee can't+    in+    total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}+  where+    alt_env = mkAltEnv env scrut bndr+    occ_anal_alt = occAnalAlt alt_env++    occ_anal_scrut (Var v) (alt1 : other_alts)+        | not (null other_alts) || not (isDefaultAlt alt1)+        = (mkOneOcc env v IsInteresting 0, Var v)+            -- The 'True' says that the variable occurs in an interesting+            -- context; the case has at least one non-default alternative+    occ_anal_scrut (Tick t e) alts+        | t `tickishScopesLike` SoftScope+          -- No reason to not look through all ticks here, but only+          -- for soft-scoped ticks we can do so without having to+          -- update returned occurrence info (see occAnal)+        = second (Tick t) $ occ_anal_scrut e alts++    occ_anal_scrut scrut _alts+        = occAnal (vanillaCtxt env) scrut    -- No need for rhsCtxt++occAnal env (Let bind body)+  = case occAnal env body                of { (body_usage, body') ->+    case occAnalBind env NotTopLevel+                     noImpRuleEdges bind+                     body_usage          of { (final_usage, new_binds) ->+       (final_usage, mkLets new_binds body') }}++occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])+occAnalArgs _ [] _+  = (emptyDetails, [])++occAnalArgs env (arg:args) one_shots+  | isTypeArg arg+  = case occAnalArgs env args one_shots of { (uds, args') ->+    (uds, arg:args') }++  | otherwise+  = case argCtxt env one_shots           of { (arg_env, one_shots') ->+    case occAnal arg_env arg             of { (uds1, arg') ->+    case occAnalArgs env args one_shots' of { (uds2, args') ->+    (uds1 `andUDs` uds2, arg':args') }}}++{-+Applications are dealt with specially because we want+the "build hack" to work.++Note [Arguments of let-bound constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    f x = let y = expensive x in+          let z = (True,y) in+          (case z of {(p,q)->q}, case z of {(p,q)->q})+We feel free to duplicate the WHNF (True,y), but that means+that y may be duplicated thereby.++If we aren't careful we duplicate the (expensive x) call!+Constructors are rather like lambdas in this way.+-}++occAnalApp :: OccEnv+           -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id])+           -> (UsageDetails, Expr CoreBndr)+occAnalApp env (Var fun, args, ticks)+  | null ticks = (uds, mkApps (Var fun) args')+  | otherwise  = (uds, mkTicks ticks $ mkApps (Var fun) args')+  where+    uds = fun_uds `andUDs` final_args_uds++    !(args_uds, args') = occAnalArgs env args one_shots+    !final_args_uds+       | isRhsEnv env && is_exp = markAllNonTailCalled $+                                  markAllInsideLam args_uds+       | otherwise              = markAllNonTailCalled args_uds+       -- We mark the free vars of the argument of a constructor or PAP+       -- as "inside-lambda", if it is the RHS of a let(rec).+       -- This means that nothing gets inlined into a constructor or PAP+       -- argument position, which is what we want.  Typically those+       -- constructor arguments are just variables, or trivial expressions.+       -- We use inside-lam because it's like eta-expanding the PAP.+       --+       -- This is the *whole point* of the isRhsEnv predicate+       -- See Note [Arguments of let-bound constructors]++    n_val_args = valArgCount args+    n_args     = length args+    fun_uds    = mkOneOcc env fun (if n_val_args > 0 then IsInteresting else NotInteresting) n_args+    is_exp     = isExpandableApp fun n_val_args+        -- See Note [CONLIKE pragma] in GHC.Types.Basic+        -- The definition of is_exp should match that in GHC.Core.Op.Simplify.prepareRhs++    one_shots  = argsOneShots (idStrictness fun) guaranteed_val_args+    guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo+                                                         (occ_one_shots env))+        -- See Note [Sources of one-shot information], bullet point A']++occAnalApp env (fun, args, ticks)+  = (markAllNonTailCalled (fun_uds `andUDs` args_uds),+     mkTicks ticks $ mkApps fun' args')+  where+    !(fun_uds, fun') = occAnal (addAppCtxt env args) fun+        -- The addAppCtxt is a bit cunning.  One iteration of the simplifier+        -- often leaves behind beta redexs like+        --      (\x y -> e) a1 a2+        -- Here we would like to mark x,y as one-shot, and treat the whole+        -- thing much like a let.  We do this by pushing some True items+        -- onto the context stack.+    !(args_uds, args') = occAnalArgs env args []++zapDetailsIf :: Bool              -- If this is true+             -> UsageDetails      -- Then do zapDetails on this+             -> UsageDetails+zapDetailsIf True  uds = zapDetails uds+zapDetailsIf False uds = uds++{-+Note [Sources of one-shot information]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The occurrence analyser obtains one-shot-lambda information from two sources:++A:  Saturated applications:  eg   f e1 .. en++    In general, given a call (f e1 .. en) we can propagate one-shot info from+    f's strictness signature into e1 .. en, but /only/ if n is enough to+    saturate the strictness signature. A strictness signature like++          f :: C1(C1(L))LS++    means that *if f is applied to three arguments* then it will guarantee to+    call its first argument at most once, and to call the result of that at+    most once. But if f has fewer than three arguments, all bets are off; e.g.++          map (f (\x y. expensive) e2) xs++    Here the \x y abstraction may be called many times (once for each element of+    xs) so we should not mark x and y as one-shot. But if it was++          map (f (\x y. expensive) 3 2) xs++    then the first argument of f will be called at most once.++    The one-shot info, derived from f's strictness signature, is+    computed by 'argsOneShots', called in occAnalApp.++A': Non-obviously saturated applications: eg    build (f (\x y -> expensive))+    where f is as above.++    In this case, f is only manifestly applied to one argument, so it does not+    look saturated. So by the previous point, we should not use its strictness+    signature to learn about the one-shotness of \x y. But in this case we can:+    build is fully applied, so we may use its strictness signature; and from+    that we learn that build calls its argument with two arguments *at most once*.++    So there is really only one call to f, and it will have three arguments. In+    that sense, f is saturated, and we may proceed as described above.++    Hence the computation of 'guaranteed_val_args' in occAnalApp, using+    '(occ_one_shots env)'.  See also #13227, comment:9++B:  Let-bindings:  eg   let f = \c. let ... in \n -> blah+                        in (build f, build f)++    Propagate one-shot info from the demanand-info on 'f' to the+    lambdas in its RHS (which may not be syntactically at the top)++    This information must have come from a previous run of the demanand+    analyser.++Previously, the demand analyser would *also* set the one-shot information, but+that code was buggy (see #11770), so doing it only in on place, namely here, is+saner.++Note [OneShots]+~~~~~~~~~~~~~~~+When analysing an expression, the occ_one_shots argument contains information+about how the function is being used. The length of the list indicates+how many arguments will eventually be passed to the analysed expression,+and the OneShotInfo indicates whether this application is once or multiple times.++Example:++ Context of f                occ_one_shots when analysing f++ f 1 2                       [OneShot, OneShot]+ map (f 1)                   [OneShot, NoOneShotInfo]+ build f                     [OneShot, OneShot]+ f 1 2 `seq` f 2 1           [NoOneShotInfo, OneShot]++Note [Binders in case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    case x of y { (a,b) -> f y }+We treat 'a', 'b' as dead, because they don't physically occur in the+case alternative.  (Indeed, a variable is dead iff it doesn't occur in+its scope in the output of OccAnal.)  It really helps to know when+binders are unused.  See esp the call to isDeadBinder in+Simplify.mkDupableAlt++In this example, though, the Simplifier will bring 'a' and 'b' back to+life, because it binds 'y' to (a,b) (imagine got inlined and+scrutinised y).+-}++occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr+                -> (UsageDetails, [CoreBndr], CoreExpr)+occAnalLamOrRhs env [] body+  = case occAnal env body of (body_usage, body') -> (body_usage, [], body')+      -- RHS of thunk or nullary join point+occAnalLamOrRhs env (bndr:bndrs) body+  | isTyVar bndr+  = -- Important: Keep the environment so that we don't inline into an RHS like+    --   \(@ x) -> C @x (f @x)+    -- (see the beginning of Note [Cascading inlines]).+    case occAnalLamOrRhs env bndrs body of+      (body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body')+occAnalLamOrRhs env binders body+  = case occAnal env_body body of { (body_usage, body') ->+    let+        (final_usage, tagged_binders) = tagLamBinders body_usage binders'+                      -- Use binders' to put one-shot info on the lambdas+    in+    (final_usage, tagged_binders, body') }+  where+    (env_body, binders') = oneShotGroup env binders++occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr))+           -> CoreAlt+           -> (UsageDetails, Alt IdWithOccInfo)+occAnalAlt (env, scrut_bind) (con, bndrs, rhs)+  = case occAnal env rhs of { (rhs_usage1, rhs1) ->+    let+      (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs+                                -- See Note [Binders in case alternatives]+      (alt_usg', rhs2) = wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1+    in+    (alt_usg', (con, tagged_bndrs, rhs2)) }++wrapAltRHS :: OccEnv+           -> Maybe (Id, CoreExpr)      -- proxy mapping generated by mkAltEnv+           -> UsageDetails              -- usage for entire alt (p -> rhs)+           -> [Var]                     -- alt binders+           -> CoreExpr                  -- alt RHS+           -> (UsageDetails, CoreExpr)+wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs+  | occ_binder_swap env+  , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this+                               -- handles condition (a) in Note [Binder swap]+  , not captured               -- See condition (b) in Note [Binder swap]+  = ( alt_usg' `andUDs` let_rhs_usg+    , Let (NonRec tagged_scrut_var let_rhs') alt_rhs )+  where+    captured = any (`usedIn` let_rhs_usg) bndrs  -- Check condition (b)++    -- The rhs of the let may include coercion variables+    -- if the scrutinee was a cast, so we must gather their+    -- usage. See Note [Gather occurrences of coercion variables]+    -- Moreover, the rhs of the let may mention the case-binder, and+    -- we want to gather its occ-info as well+    (let_rhs_usg, let_rhs') = occAnal env let_rhs++    (alt_usg', tagged_scrut_var) = tagLamBinder alt_usg scrut_var++wrapAltRHS _ _ alt_usg _ alt_rhs+  = (alt_usg, alt_rhs)++{-+************************************************************************+*                                                                      *+                    OccEnv+*                                                                      *+************************************************************************+-}++data OccEnv+  = OccEnv { occ_encl       :: !OccEncl      -- Enclosing context information+           , occ_one_shots  :: !OneShots     -- See Note [OneShots]+           , occ_gbl_scrut  :: GlobalScruts++           , occ_unf_act   :: Id -> Bool   -- Which Id unfoldings are active++           , occ_rule_act   :: Activation -> Bool   -- Which rules are active+             -- See Note [Finding rule RHS free vars]++           , occ_binder_swap :: !Bool -- enable the binder_swap+             -- See CorePrep Note [Dead code in CorePrep]+    }++type GlobalScruts = IdSet   -- See Note [Binder swap on GlobalId scrutinees]++-----------------------------+-- OccEncl is used to control whether to inline into constructor arguments+-- For example:+--      x = (p,q)               -- Don't inline p or q+--      y = /\a -> (p a, q a)   -- Still don't inline p or q+--      z = f (p,q)             -- Do inline p,q; it may make a rule fire+-- So OccEncl tells enough about the context to know what to do when+-- we encounter a constructor application or PAP.++data OccEncl+  = OccRhs              -- RHS of let(rec), albeit perhaps inside a type lambda+                        -- Don't inline into constructor args here+  | OccVanilla          -- Argument of function, body of lambda, scruintee of case etc.+                        -- Do inline into constructor args here++instance Outputable OccEncl where+  ppr OccRhs     = text "occRhs"+  ppr OccVanilla = text "occVanilla"++-- See note [OneShots]+type OneShots = [OneShotInfo]++initOccEnv :: OccEnv+initOccEnv+  = OccEnv { occ_encl      = OccVanilla+           , occ_one_shots = []+           , occ_gbl_scrut = emptyVarSet+                 -- To be conservative, we say that all+                 -- inlines and rules are active+           , occ_unf_act   = \_ -> True+           , occ_rule_act  = \_ -> True+           , occ_binder_swap = True }++vanillaCtxt :: OccEnv -> OccEnv+vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] }++rhsCtxt :: OccEnv -> OccEnv+rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] }++argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])+argCtxt env []+  = (env { occ_encl = OccVanilla, occ_one_shots = [] }, [])+argCtxt env (one_shots:one_shots_s)+  = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s)++isRhsEnv :: OccEnv -> Bool+isRhsEnv (OccEnv { occ_encl = OccRhs })     = True+isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False++oneShotGroup :: OccEnv -> [CoreBndr]+             -> ( OccEnv+                , [CoreBndr] )+        -- The result binders have one-shot-ness set that they might not have had originally.+        -- This happens in (build (\c n -> e)).  Here the occurrence analyser+        -- linearity context knows that c,n are one-shot, and it records that fact in+        -- the binder. This is useful to guide subsequent float-in/float-out transformations++oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs+  = go ctxt bndrs []+  where+    go ctxt [] rev_bndrs+      = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla }+        , reverse rev_bndrs )++    go [] bndrs rev_bndrs+      = ( env { occ_one_shots = [], occ_encl = OccVanilla }+        , reverse rev_bndrs ++ bndrs )++    go ctxt@(one_shot : ctxt') (bndr : bndrs) rev_bndrs+      | isId bndr = go ctxt' bndrs (bndr': rev_bndrs)+      | otherwise = go ctxt  bndrs (bndr : rev_bndrs)+      where+        bndr' = updOneShotInfo bndr one_shot+               -- Use updOneShotInfo, not setOneShotInfo, as pre-existing+               -- one-shot info might be better than what we can infer, e.g.+               -- due to explicit use of the magic 'oneShot' function.+               -- See Note [The oneShot function]+++markJoinOneShots :: Maybe JoinArity -> [Var] -> [Var]+-- Mark the lambdas of a non-recursive join point as one-shot.+-- This is good to prevent gratuitous float-out etc+markJoinOneShots mb_join_arity bndrs+  = case mb_join_arity of+      Nothing -> bndrs+      Just n  -> go n bndrs+ where+   go 0 bndrs  = bndrs+   go _ []     = [] -- This can legitimately happen.+                    -- e.g.    let j = case ... in j True+                    -- This will become an arity-1 join point after the+                    -- simplifier has eta-expanded it; but it may not have+                    -- enough lambdas /yet/. (Lint checks that JoinIds do+                    -- have enough lambdas.)+   go n (b:bs) = b' : go (n-1) bs+     where+       b' | isId b    = setOneShotLambda b+          | otherwise = b++addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv+addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args+  = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt }++transClosureFV :: UniqFM VarSet -> UniqFM VarSet+-- If (f,g), (g,h) are in the input, then (f,h) is in the output+--                                   as well as (f,g), (g,h)+transClosureFV env+  | no_change = env+  | otherwise = transClosureFV (listToUFM new_fv_list)+  where+    (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env)+      -- It's OK to use nonDetUFMToList here because we'll forget the+      -- ordering by creating a new set with listToUFM+    bump no_change (b,fvs)+      | no_change_here = (no_change, (b,fvs))+      | otherwise      = (False,     (b,new_fvs))+      where+        (new_fvs, no_change_here) = extendFvs env fvs++-------------+extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet+extendFvs_ env s = fst (extendFvs env s)   -- Discard the Bool flag++extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool)+-- (extendFVs env s) returns+--     (s `union` env(s), env(s) `subset` s)+extendFvs env s+  | isNullUFM env+  = (s, True)+  | otherwise+  = (s `unionVarSet` extras, extras `subVarSet` s)+  where+    extras :: VarSet    -- env(s)+    extras = nonDetFoldUFM unionVarSet emptyVarSet $+      -- It's OK to use nonDetFoldUFM here because unionVarSet commutes+             intersectUFM_C (\x _ -> x) env (getUniqSet s)++{-+************************************************************************+*                                                                      *+                    Binder swap+*                                                                      *+************************************************************************++Note [Binder swap]+~~~~~~~~~~~~~~~~~~+The "binder swap" transformation swaps occurrence of the+scrutinee of a case for occurrences of the case-binder:++ (1)  case x of b { pi -> ri }+         ==>+      case x of b { pi -> let x=b in ri }++ (2)  case (x |> co) of b { pi -> ri }+        ==>+      case (x |> co) of b { pi -> let x = b |> sym co in ri }++In both cases, the trivial 'let' can be eliminated by the+immediately following simplifier pass.++There are two reasons for making this swap:++(A) It reduces the number of occurrences of the scrutinee, x.+    That in turn might reduce its occurrences to one, so we+    can inline it and save an allocation.  E.g.+      let x = factorial y in case x of b { I# v -> ...x... }+    If we replace 'x' by 'b' in the alternative we get+      let x = factorial y in case x of b { I# v -> ...b... }+    and now we can inline 'x', thus+      case (factorial y) of b { I# v -> ...b... }++(B) The case-binder b has unfolding information; in the+    example above we know that b = I# v. That in turn allows+    nested cases to simplify.  Consider+       case x of b { I# v ->+       ...(case x of b2 { I# v2 -> rhs })...+    If we replace 'x' by 'b' in the alternative we get+       case x of b { I# v ->+       ...(case b of b2 { I# v2 -> rhs })...+    and now it is trivial to simplify the inner case:+       case x of b { I# v ->+       ...(let b2 = b in rhs)...++    The same can happen even if the scrutinee is a variable+    with a cast: see Note [Case of cast]++In both cases, in a particular alternative (pi -> ri), we only+add the binding if+  (a) x occurs free in (pi -> ri)+        (ie it occurs in ri, but is not bound in pi)+  (b) the pi does not bind b (or the free vars of co)+We need (a) and (b) for the inserted binding to be correct.++For the alternatives where we inject the binding, we can transfer+all x's OccInfo to b.  And that is the point.++Notice that+  * The deliberate shadowing of 'x'.+  * That (a) rapidly becomes false, so no bindings are injected.++The reason for doing these transformations /here in the occurrence+analyser/ is because it allows us to adjust the OccInfo for 'x' and+'b' as we go.++  * Suppose the only occurrences of 'x' are the scrutinee and in the+    ri; then this transformation makes it occur just once, and hence+    get inlined right away.++  * If instead we do this in the Simplifier, we don't know whether 'x'+    is used in ri, so we are forced to pessimistically zap b's OccInfo+    even though it is typically dead (ie neither it nor x appear in+    the ri).  There's nothing actually wrong with zapping it, except+    that it's kind of nice to know which variables are dead.  My nose+    tells me to keep this information as robustly as possible.++The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding+{x=b}; it's Nothing if the binder-swap doesn't happen.++There is a danger though.  Consider+      let v = x +# y+      in case (f v) of w -> ...v...v...+And suppose that (f v) expands to just v.  Then we'd like to+use 'w' instead of 'v' in the alternative.  But it may be too+late; we may have substituted the (cheap) x+#y for v in the+same simplifier pass that reduced (f v) to v.++I think this is just too bad.  CSE will recover some of it.++Note [Case of cast]+~~~~~~~~~~~~~~~~~~~+Consider        case (x `cast` co) of b { I# ->+                ... (case (x `cast` co) of {...}) ...+We'd like to eliminate the inner case.  That is the motivation for+equation (2) in Note [Binder swap].  When we get to the inner case, we+inline x, cancel the casts, and away we go.++Note [Binder swap on GlobalId scrutinees]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the scrutinee is a GlobalId we must take care in two ways++ i) In order to *know* whether 'x' occurs free in the RHS, we need its+    occurrence info. BUT, we don't gather occurrence info for+    GlobalIds.  That's the reason for the (small) occ_gbl_scrut env in+    OccEnv is for: it says "gather occurrence info for these".++ ii) We must call localiseId on 'x' first, in case it's a GlobalId, or+     has an External Name. See, for example, SimplEnv Note [Global Ids in+     the substitution].++Note [Zap case binders in proxy bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+From the original+     case x of cb(dead) { p -> ...x... }+we will get+     case x of cb(live) { p -> let x = cb in ...x... }++Core Lint never expects to find an *occurrence* of an Id marked+as Dead, so we must zap the OccInfo on cb before making the+binding x = cb.  See #5028.++NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier+doesn't use it. So this is only to satisfy the perhaps-over-picky Lint.++Historical note [no-case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We *used* to suppress the binder-swap in case expressions when+-fno-case-of-case is on.  Old remarks:+    "This happens in the first simplifier pass,+    and enhances full laziness.  Here's the bad case:+            f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )+    If we eliminate the inner case, we trap it inside the I# v -> arm,+    which might prevent some full laziness happening.  I've seen this+    in action in spectral/cichelli/Prog.hs:+             [(m,n) | m <- [1..max], n <- [1..max]]+    Hence the check for NoCaseOfCase."+However, now the full-laziness pass itself reverses the binder-swap, so this+check is no longer necessary.++Historical note [Suppressing the case binder-swap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This old note describes a problem that is also fixed by doing the+binder-swap in OccAnal:++    There is another situation when it might make sense to suppress the+    case-expression binde-swap. If we have++        case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }+                       ...other cases .... }++    We'll perform the binder-swap for the outer case, giving++        case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }+                       ...other cases .... }++    But there is no point in doing it for the inner case, because w1 can't+    be inlined anyway.  Furthermore, doing the case-swapping involves+    zapping w2's occurrence info (see paragraphs that follow), and that+    forces us to bind w2 when doing case merging.  So we get++        case x of w1 { A -> let w2 = w1 in e1+                       B -> let w2 = w1 in e2+                       ...other cases .... }++    This is plain silly in the common case where w2 is dead.++    Even so, I can't see a good way to implement this idea.  I tried+    not doing the binder-swap if the scrutinee was already evaluated+    but that failed big-time:++            data T = MkT !Int++            case v of w  { MkT x ->+            case x of x1 { I# y1 ->+            case x of x2 { I# y2 -> ...++    Notice that because MkT is strict, x is marked "evaluated".  But to+    eliminate the last case, we must either make sure that x (as well as+    x1) has unfolding MkT y1.  The straightforward thing to do is to do+    the binder-swap.  So this whole note is a no-op.++It's fixed by doing the binder-swap in OccAnal because we can do the+binder-swap unconditionally and still get occurrence analysis+information right.+-}++mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr))+-- Does three things: a) makes the occ_one_shots = OccVanilla+--                    b) extends the GlobalScruts if possible+--                    c) returns a proxy mapping, binding the scrutinee+--                       to the case binder, if possible+mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr+  = case stripTicksTopE (const True) scrut of+      Var v           -> add_scrut v case_bndr'+      Cast (Var v) co -> add_scrut v (Cast case_bndr' (mkSymCo co))+                          -- See Note [Case of cast]+      _               -> (env { occ_encl = OccVanilla }, Nothing)++  where+    add_scrut v rhs+      | isGlobalId v = (env { occ_encl = OccVanilla }, Nothing)+      | otherwise    = ( env { occ_encl = OccVanilla+                             , occ_gbl_scrut = pe `extendVarSet` v }+                       , Just (localise v, rhs) )+      -- ToDO: this isGlobalId stuff is a TEMPORARY FIX+      --       to avoid the binder-swap for GlobalIds+      --       See #16346++    case_bndr' = Var (zapIdOccInfo case_bndr)+                   -- See Note [Zap case binders in proxy bindings]++    -- Localise the scrut_var before shadowing it; we're making a+    -- new binding for it, and it might have an External Name, or+    -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]+    -- Also we don't want any INLINE or NOINLINE pragmas!+    localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var))+                                          (idType scrut_var)++{-+************************************************************************+*                                                                      *+\subsection[OccurAnal-types]{OccEnv}+*                                                                      *+************************************************************************++Note [UsageDetails and zapping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++On many occasions, we must modify all gathered occurrence data at once. For+instance, all occurrences underneath a (non-one-shot) lambda set the+'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but+that takes O(n) time and we will do this often---in particular, there are many+places where tail calls are not allowed, and each of these causes all variables+to get marked with 'NoTailCallInfo'.++Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along+with the 'OccInfoEnv'. Each of these extra environments is a "zapped set"+recording which variables have been zapped in some way. Zapping all occurrence+info then simply means setting the corresponding zapped set to the whole+'OccInfoEnv', a fast O(1) operation.+-}++type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage+                -- INVARIANT: never IAmDead+                -- (Deadness is signalled by not being in the map at all)++type ZappedSet = OccInfoEnv -- Values are ignored++data UsageDetails+  = UD { ud_env       :: !OccInfoEnv+       , ud_z_many    :: ZappedSet   -- apply 'markMany' to these+       , ud_z_in_lam  :: ZappedSet   -- apply 'markInsideLam' to these+       , ud_z_no_tail :: ZappedSet } -- apply 'markNonTailCalled' to these+  -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv++instance Outputable UsageDetails where+  ppr ud = ppr (ud_env (flattenUsageDetails ud))++-------------------+-- UsageDetails API++andUDs, orUDs+        :: UsageDetails -> UsageDetails -> UsageDetails+andUDs = combineUsageDetailsWith addOccInfo+orUDs  = combineUsageDetailsWith orOccInfo++andUDsList :: [UsageDetails] -> UsageDetails+andUDsList = foldl' andUDs emptyDetails++mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails+mkOneOcc env id int_cxt arity+  | isLocalId id+  = singleton $ OneOcc { occ_in_lam  = NotInsideLam+                       , occ_one_br  = InOneBranch+                       , occ_int_cxt = int_cxt+                       , occ_tail    = AlwaysTailCalled arity }+  | id `elemVarSet` occ_gbl_scrut env+  = singleton noOccInfo++  | otherwise+  = emptyDetails+  where+    singleton info = emptyDetails { ud_env = unitVarEnv id info }++addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails+addOneOcc ud id info+  = ud { ud_env = extendVarEnv_C plus_zapped (ud_env ud) id info }+      `alterZappedSets` (`delVarEnv` id)+  where+    plus_zapped old new = doZapping ud id old `addOccInfo` new++addManyOccsSet :: UsageDetails -> VarSet -> UsageDetails+addManyOccsSet usage id_set = nonDetFoldUniqSet addManyOccs usage id_set+  -- It's OK to use nonDetFoldUFM here because addManyOccs commutes++-- Add several occurrences, assumed not to be tail calls+addManyOccs :: Var -> UsageDetails -> UsageDetails+addManyOccs v u | isId v    = addOneOcc u v noOccInfo+                | otherwise = u+        -- Give a non-committal binder info (i.e noOccInfo) because+        --   a) Many copies of the specialised thing can appear+        --   b) We don't want to substitute a BIG expression inside a RULE+        --      even if that's the only occurrence of the thing+        --      (Same goes for INLINE.)++delDetails :: UsageDetails -> Id -> UsageDetails+delDetails ud bndr+  = ud `alterUsageDetails` (`delVarEnv` bndr)++delDetailsList :: UsageDetails -> [Id] -> UsageDetails+delDetailsList ud bndrs+  = ud `alterUsageDetails` (`delVarEnvList` bndrs)++emptyDetails :: UsageDetails+emptyDetails = UD { ud_env       = emptyVarEnv+                  , ud_z_many    = emptyVarEnv+                  , ud_z_in_lam  = emptyVarEnv+                  , ud_z_no_tail = emptyVarEnv }++isEmptyDetails :: UsageDetails -> Bool+isEmptyDetails = isEmptyVarEnv . ud_env++markAllMany, markAllInsideLam, markAllNonTailCalled, zapDetails+  :: UsageDetails -> UsageDetails+markAllMany          ud = ud { ud_z_many    = ud_env ud }+markAllInsideLam     ud = ud { ud_z_in_lam  = ud_env ud }+markAllNonTailCalled ud = ud { ud_z_no_tail = ud_env ud }++zapDetails = markAllMany . markAllNonTailCalled -- effectively sets to noOccInfo++lookupDetails :: UsageDetails -> Id -> OccInfo+lookupDetails ud id+  | isCoVar id  -- We do not currently gather occurrence info (from types)+  = noOccInfo   -- for CoVars, so we must conservatively mark them as used+                -- See Note [DoO not mark CoVars as dead]+  | otherwise+  = case lookupVarEnv (ud_env ud) id of+      Just occ -> doZapping ud id occ+      Nothing  -> IAmDead++usedIn :: Id -> UsageDetails -> Bool+v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud++udFreeVars :: VarSet -> UsageDetails -> VarSet+-- Find the subset of bndrs that are mentioned in uds+udFreeVars bndrs ud = restrictUniqSetToUFM bndrs (ud_env ud)++{- Note [Do not mark CoVars as dead]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's obviously wrong to mark CoVars as dead if they are used.+Currently we don't traverse types to gather usase info for CoVars,+so we had better treat them as having noOccInfo.++This showed up in #15696 we had something like+  case eq_sel d of co -> ...(typeError @(...co...) "urk")...++Then 'd' was substituted by a dictionary, so the expression+simpified to+  case (Coercion <blah>) of co -> ...(typeError @(...co...) "urk")...++But then the "drop the case altogether" equation of rebuildCase+thought that 'co' was dead, and discarded the entire case. Urk!++I have no idea how we managed to avoid this pitfall for so long!+-}++-------------------+-- Auxiliary functions for UsageDetails implementation++combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo)+                        -> UsageDetails -> UsageDetails -> UsageDetails+combineUsageDetailsWith plus_occ_info ud1 ud2+  | isEmptyDetails ud1 = ud2+  | isEmptyDetails ud2 = ud1+  | otherwise+  = UD { ud_env       = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2)+       , ud_z_many    = plusVarEnv (ud_z_many    ud1) (ud_z_many    ud2)+       , ud_z_in_lam  = plusVarEnv (ud_z_in_lam  ud1) (ud_z_in_lam  ud2)+       , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) }++doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo+doZapping ud var occ+  = doZappingByUnique ud (varUnique var) occ++doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo+doZappingByUnique ud uniq+  = (if | in_subset ud_z_many    -> markMany+        | in_subset ud_z_in_lam  -> markInsideLam+        | otherwise              -> id) .+    (if | in_subset ud_z_no_tail -> markNonTailCalled+        | otherwise              -> id)+  where+    in_subset field = uniq `elemVarEnvByKey` field ud++alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails+alterZappedSets ud f+  = ud { ud_z_many    = f (ud_z_many    ud)+       , ud_z_in_lam  = f (ud_z_in_lam  ud)+       , ud_z_no_tail = f (ud_z_no_tail ud) }++alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails+alterUsageDetails ud f+  = ud { ud_env = f (ud_env ud) }+      `alterZappedSets` f++flattenUsageDetails :: UsageDetails -> UsageDetails+flattenUsageDetails ud+  = ud { ud_env = mapUFM_Directly (doZappingByUnique ud) (ud_env ud) }+      `alterZappedSets` const emptyVarEnv++-------------------+-- See Note [Adjusting right-hand sides]+adjustRhsUsage :: Maybe JoinArity -> RecFlag+               -> [CoreBndr] -- Outer lambdas, AFTER occ anal+               -> UsageDetails -> UsageDetails+adjustRhsUsage mb_join_arity rec_flag bndrs usage+  = maybe_mark_lam (maybe_drop_tails usage)+  where+    maybe_mark_lam ud   | one_shot   = ud+                        | otherwise  = markAllInsideLam ud+    maybe_drop_tails ud | exact_join = ud+                        | otherwise  = markAllNonTailCalled ud++    one_shot = case mb_join_arity of+                 Just join_arity+                   | isRec rec_flag -> False+                   | otherwise      -> all isOneShotBndr (drop join_arity bndrs)+                 Nothing            -> all isOneShotBndr bndrs++    exact_join = case mb_join_arity of+                   Just join_arity -> bndrs `lengthIs` join_arity+                   _               -> False++type IdWithOccInfo = Id++tagLamBinders :: UsageDetails          -- Of scope+              -> [Id]                  -- Binders+              -> (UsageDetails,        -- Details with binders removed+                 [IdWithOccInfo])    -- Tagged binders+tagLamBinders usage binders+  = usage' `seq` (usage', bndrs')+  where+    (usage', bndrs') = mapAccumR tagLamBinder usage binders++tagLamBinder :: UsageDetails       -- Of scope+             -> Id                 -- Binder+             -> (UsageDetails,     -- Details with binder removed+                 IdWithOccInfo)    -- Tagged binders+-- Used for lambda and case binders+-- It copes with the fact that lambda bindings can have a+-- stable unfolding, used for join points+tagLamBinder usage bndr+  = (usage2, bndr')+  where+        occ    = lookupDetails usage bndr+        bndr'  = setBinderOcc (markNonTailCalled occ) bndr+                   -- Don't try to make an argument into a join point+        usage1 = usage `delDetails` bndr+        usage2 | isId bndr = addManyOccsSet usage1 (idUnfoldingVars bndr)+                               -- This is effectively the RHS of a+                               -- non-join-point binding, so it's okay to use+                               -- addManyOccsSet, which assumes no tail calls+               | otherwise = usage1++tagNonRecBinder :: TopLevelFlag           -- At top level?+                -> UsageDetails           -- Of scope+                -> CoreBndr               -- Binder+                -> (UsageDetails,         -- Details with binder removed+                    IdWithOccInfo)        -- Tagged binder++tagNonRecBinder lvl usage binder+ = let+     occ     = lookupDetails usage binder+     will_be_join = decideJoinPointHood lvl usage [binder]+     occ'    | will_be_join = -- must already be marked AlwaysTailCalled+                              ASSERT(isAlwaysTailCalled occ) occ+             | otherwise    = markNonTailCalled occ+     binder' = setBinderOcc occ' binder+     usage'  = usage `delDetails` binder+   in+   usage' `seq` (usage', binder')++tagRecBinders :: TopLevelFlag           -- At top level?+              -> UsageDetails           -- Of body of let ONLY+              -> [(CoreBndr,            -- Binder+                   UsageDetails,        -- RHS usage details+                   [CoreBndr])]         -- Lambdas in new RHS+              -> (UsageDetails,         -- Adjusted details for whole scope,+                                        -- with binders removed+                  [IdWithOccInfo])      -- Tagged binders+-- Substantially more complicated than non-recursive case. Need to adjust RHS+-- details *before* tagging binders (because the tags depend on the RHSes).+tagRecBinders lvl body_uds triples+ = let+     (bndrs, rhs_udss, _) = unzip3 triples++     -- 1. Determine join-point-hood of whole group, as determined by+     --    the *unadjusted* usage details+     unadj_uds     = foldr andUDs body_uds rhs_udss+     will_be_joins = decideJoinPointHood lvl unadj_uds bndrs++     -- 2. Adjust usage details of each RHS, taking into account the+     --    join-point-hood decision+     rhs_udss' = map adjust triples+     adjust (bndr, rhs_uds, rhs_bndrs)+       = adjustRhsUsage mb_join_arity Recursive rhs_bndrs rhs_uds+       where+         -- Can't use willBeJoinId_maybe here because we haven't tagged the+         -- binder yet (the tag depends on these adjustments!)+         mb_join_arity+           | will_be_joins+           , let occ = lookupDetails unadj_uds bndr+           , AlwaysTailCalled arity <- tailCallInfo occ+           = Just arity+           | otherwise+           = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if+             Nothing                   -- we are making join points!++     -- 3. Compute final usage details from adjusted RHS details+     adj_uds   = foldr andUDs body_uds rhs_udss'++     -- 4. Tag each binder with its adjusted details+     bndrs'    = [ setBinderOcc (lookupDetails adj_uds bndr) bndr+                 | bndr <- bndrs ]++     -- 5. Drop the binders from the adjusted details and return+     usage'    = adj_uds `delDetailsList` bndrs+   in+   (usage', bndrs')++setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr+setBinderOcc occ_info bndr+  | isTyVar bndr      = bndr+  | isExportedId bndr = if isManyOccs (idOccInfo bndr)+                          then bndr+                          else setIdOccInfo bndr noOccInfo+            -- Don't use local usage info for visible-elsewhere things+            -- BUT *do* erase any IAmALoopBreaker annotation, because we're+            -- about to re-generate it and it shouldn't be "sticky"++  | otherwise = setIdOccInfo bndr occ_info++-- | Decide whether some bindings should be made into join points or not.+-- Returns `False` if they can't be join points. Note that it's an+-- all-or-nothing decision, as if multiple binders are given, they're+-- assumed to be mutually recursive.+--+-- It must, however, be a final decision. If we say "True" for 'f',+-- and then subsequently decide /not/ make 'f' into a join point, then+-- the decision about another binding 'g' might be invalidated if (say)+-- 'f' tail-calls 'g'.+--+-- See Note [Invariants on join points] in GHC.Core.+decideJoinPointHood :: TopLevelFlag -> UsageDetails+                    -> [CoreBndr]+                    -> Bool+decideJoinPointHood TopLevel _ _+  = False+decideJoinPointHood NotTopLevel usage bndrs+  | isJoinId (head bndrs)+  = WARN(not all_ok, text "OccurAnal failed to rediscover join point(s):" <+>+                       ppr bndrs)+    all_ok+  | otherwise+  = all_ok+  where+    -- See Note [Invariants on join points]; invariants cited by number below.+    -- Invariant 2 is always satisfiable by the simplifier by eta expansion.+    all_ok = -- Invariant 3: Either all are join points or none are+             all ok bndrs++    ok bndr+      | -- Invariant 1: Only tail calls, all same join arity+        AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr)++      , -- Invariant 1 as applied to LHSes of rules+        all (ok_rule arity) (idCoreRules bndr)++        -- Invariant 2a: stable unfoldings+        -- See Note [Join points and INLINE pragmas]+      , ok_unfolding arity (realIdUnfolding bndr)++        -- Invariant 4: Satisfies polymorphism rule+      , isValidJoinPointType arity (idType bndr)+      = True++      | otherwise+      = False++    ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans+    ok_rule join_arity (Rule { ru_args = args })+      = args `lengthIs` join_arity+        -- Invariant 1 as applied to LHSes of rules++    -- ok_unfolding returns False if we should /not/ convert a non-join-id+    -- into a join-id, even though it is AlwaysTailCalled+    ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs })+      = not (isStableSource src && join_arity > joinRhsArity rhs)+    ok_unfolding _ (DFunUnfolding {})+      = False+    ok_unfolding _ _+      = True++willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity+willBeJoinId_maybe bndr+  = case tailCallInfo (idOccInfo bndr) of+      AlwaysTailCalled arity -> Just arity+      _                      -> isJoinId_maybe bndr+++{- Note [Join points and INLINE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = let g = \x. not  -- Arity 1+             {-# INLINE g #-}+         in case x of+              A -> g True True+              B -> g True False+              C -> blah2++Here 'g' is always tail-called applied to 2 args, but the stable+unfolding captured by the INLINE pragma has arity 1.  If we try to+convert g to be a join point, its unfolding will still have arity 1+(since it is stable, and we don't meddle with stable unfoldings), and+Lint will complain (see Note [Invariants on join points], (2a), in+GHC.Core.  #13413.++Moreover, since g is going to be inlined anyway, there is no benefit+from making it a join point.++If it is recursive, and uselessly marked INLINE, this will stop us+making it a join point, which is annoying.  But occasionally+(notably in class methods; see Note [Instances and loop breakers] in+TcInstDcls) we mark recursive things as INLINE but the recursion+unravels; so ignoring INLINE pragmas on recursive things isn't good+either.++See Invariant 2a of Note [Invariants on join points] in GHC.Core+++************************************************************************+*                                                                      *+\subsection{Operations over OccInfo}+*                                                                      *+************************************************************************+-}++markMany, markInsideLam, markNonTailCalled :: OccInfo -> OccInfo++markMany IAmDead = IAmDead+markMany occ     = ManyOccs { occ_tail = occ_tail occ }++markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam }+markInsideLam occ             = occ++markNonTailCalled IAmDead = IAmDead+markNonTailCalled occ     = occ { occ_tail = NoTailCallInfo }++addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo++addOccInfo a1 a2  = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )+                    ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`+                                          tailCallInfo a2 }+                                -- Both branches are at least One+                                -- (Argument is never IAmDead)++-- (orOccInfo orig new) is used+-- when combining occurrence info from branches of a case++orOccInfo (OneOcc { occ_in_lam = in_lam1, occ_int_cxt = int_cxt1+                  , occ_tail   = tail1 })+          (OneOcc { occ_in_lam = in_lam2, occ_int_cxt = int_cxt2+                  , occ_tail   = tail2 })+  = OneOcc { occ_one_br  = MultipleBranches -- because it occurs in both branches+           , occ_in_lam  = in_lam1 `mappend` in_lam2+           , occ_int_cxt = int_cxt1 `mappend` int_cxt2+           , occ_tail    = tail1 `andTailCallInfo` tail2 }++orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )+                  ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`+                                        tailCallInfo a2 }++andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo+andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2)+  | arity1 == arity2 = info+andTailCallInfo _ _  = NoTailCallInfo
compiler/GHC/Core/Op/Tidy.hs view
@@ -19,16 +19,16 @@  import GHC.Core import GHC.Core.Seq ( seqUnfolding )-import Id-import IdInfo-import Demand ( zapUsageEnvSig )-import Type( tidyType, tidyVarBndr )-import Coercion( tidyCo )-import Var-import VarEnv-import UniqFM-import Name hiding (tidyNameOcc)-import SrcLoc+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Demand ( zapUsageEnvSig )+import GHC.Core.Type     ( tidyType, tidyVarBndr )+import GHC.Core.Coercion ( tidyCo )+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Unique.FM+import GHC.Types.Name hiding (tidyNameOcc)+import GHC.Types.SrcLoc import Maybes import Data.List @@ -191,7 +191,7 @@         -- Similarly for the demand info - on a let binder, this tells         -- CorePrep to turn the let into a case.         -- But: Remove the usage demand here-        --      (See Note [Zapping DmdEnv after Demand Analyzer] in WorkWrap)+        --      (See Note [Zapping DmdEnv after Demand Analyzer] in GHC.Core.Op.WorkWrap)         --         -- Similarly arity info for eta expansion in CorePrep         -- Don't attempt to recompute arity here; this is just tidying!@@ -277,7 +277,7 @@ Not all OneShotInfo is determined by a compiler analysis; some is added by a call of GHC.Exts.oneShot, which is then discarded before the end of the optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we-must preserve this info in inlinings. See Note [The oneShot function] in MkId.+must preserve this info in inlinings. See Note [The oneShot function] in GHC.Types.Id.Make.  This applies to lambda binders only, hence it is stored in IfaceLamBndr. -}
+ compiler/GHC/Core/PatSyn.hs view
@@ -0,0 +1,484 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998++\section[PatSyn]{@PatSyn@: Pattern synonyms}+-}++{-# LANGUAGE CPP #-}++module GHC.Core.PatSyn (+        -- * Main data types+        PatSyn, mkPatSyn,++        -- ** Type deconstruction+        patSynName, patSynArity, patSynIsInfix,+        patSynArgs,+        patSynMatcher, patSynBuilder,+        patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig,+        patSynInstArgTys, patSynInstResTy, patSynFieldLabels,+        patSynFieldType,++        updatePatSynIds, pprPatSynType+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Core.Type+import GHC.Core.TyCo.Ppr+import GHC.Types.Name+import Outputable+import GHC.Types.Unique+import Util+import GHC.Types.Basic+import GHC.Types.Var+import GHC.Types.FieldLabel++import qualified Data.Data as Data+import Data.Function+import Data.List (find)++{-+************************************************************************+*                                                                      *+\subsection{Pattern synonyms}+*                                                                      *+************************************************************************+-}++-- | Pattern Synonym+--+-- See Note [Pattern synonym representation]+-- See Note [Pattern synonym signature contexts]+data PatSyn+  = MkPatSyn {+        psName        :: Name,+        psUnique      :: Unique,       -- Cached from Name++        psArgs        :: [Type],+        psArity       :: Arity,        -- == length psArgs+        psInfix       :: Bool,         -- True <=> declared infix+        psFieldLabels :: [FieldLabel], -- List of fields for a+                                       -- record pattern synonym+                                       -- INVARIANT: either empty if no+                                       -- record pat syn or same length as+                                       -- psArgs++        -- Universally-quantified type variables+        psUnivTyVars  :: [TyVarBinder],++        -- Required dictionaries (may mention psUnivTyVars)+        psReqTheta    :: ThetaType,++        -- Existentially-quantified type vars+        psExTyVars    :: [TyVarBinder],++        -- Provided dictionaries (may mention psUnivTyVars or psExTyVars)+        psProvTheta   :: ThetaType,++        -- Result type+        psResultTy   :: Type,  -- Mentions only psUnivTyVars+                               -- See Note [Pattern synonym result type]++        -- See Note [Matchers and builders for pattern synonyms]+        psMatcher     :: (Id, Bool),+             -- Matcher function.+             -- If Bool is True then prov_theta and arg_tys are empty+             -- and type is+             --   forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs.+             --                          req_theta+             --                       => res_ty+             --                       -> (forall ex_tvs. Void# -> r)+             --                       -> (Void# -> r)+             --                       -> r+             --+             -- Otherwise type is+             --   forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs.+             --                          req_theta+             --                       => res_ty+             --                       -> (forall ex_tvs. prov_theta => arg_tys -> r)+             --                       -> (Void# -> r)+             --                       -> r++        psBuilder     :: Maybe (Id, Bool)+             -- Nothing  => uni-directional pattern synonym+             -- Just (builder, is_unlifted) => bi-directional+             -- Builder function, of type+             --  forall univ_tvs, ex_tvs. (req_theta, prov_theta)+             --                       =>  arg_tys -> res_ty+             -- See Note [Builder for pattern synonyms with unboxed type]+  }++{- Note [Pattern synonym signature contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a pattern synonym signature we write+   pattern P :: req => prov => t1 -> ... tn -> res_ty++Note that the "required" context comes first, then the "provided"+context.  Moreover, the "required" context must not mention+existentially-bound type variables; that is, ones not mentioned in+res_ty.  See lots of discussion in #10928.++If there is no "provided" context, you can omit it; but you+can't omit the "required" part (unless you omit both).++Example 1:+      pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b)+      pattern P1 x = Just (3,x)++  We require (Num a, Eq a) to match the 3; there is no provided+  context.++Example 2:+      data T2 where+        MkT2 :: (Num a, Eq a) => a -> a -> T2++      pattern P2 :: () => (Num a, Eq a) => a -> T2+      pattern P2 x = MkT2 3 x++  When we match against P2 we get a Num dictionary provided.+  We can use that to check the match against 3.++Example 3:+      pattern P3 :: Eq a => a -> b -> T3 b++   This signature is illegal because the (Eq a) is a required+   constraint, but it mentions the existentially-bound variable 'a'.+   You can see it's existential because it doesn't appear in the+   result type (T3 b).++Note [Pattern synonym result type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   data T a b = MkT b a++   pattern P :: a -> T [a] Bool+   pattern P x = MkT True [x]++P's psResultTy is (T a Bool), and it really only matches values of+type (T [a] Bool).  For example, this is ill-typed++   f :: T p q -> String+   f (P x) = "urk"++This is different to the situation with GADTs:++   data S a where+     MkS :: Int -> S Bool++Now MkS (and pattern synonyms coming from MkS) can match a+value of type (S a), not just (S Bool); we get type refinement.++That in turn means that if you have a pattern++   P x :: T [ty] Bool++it's not entirely straightforward to work out the instantiation of+P's universal tyvars. You have to /match/+  the type of the pattern, (T [ty] Bool)+against+  the psResultTy for the pattern synonym, T [a] Bool+to get the instantiation a := ty.++This is very unlike DataCons, where univ tyvars match 1-1 the+arguments of the TyCon.++Side note: I (SG) get the impression that instantiated return types should+generate a *required* constraint for pattern synonyms, rather than a *provided*+constraint like it's the case for GADTs. For example, I'd expect these+declarations to have identical semantics:++    pattern Just42 :: Maybe Int+    pattern Just42 = Just 42++    pattern Just'42 :: (a ~ Int) => Maybe a+    pattern Just'42 = Just 42++The latter generates the proper required constraint, the former does not.+Also rather different to GADTs is the fact that Just42 doesn't have any+universally quantified type variables, whereas Just'42 or MkS above has.++Note [Pattern synonym representation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following pattern synonym declaration++        pattern P x = MkT [x] (Just 42)++where+        data T a where+              MkT :: (Show a, Ord b) => [b] -> a -> T a++so pattern P has type++        b -> T (Maybe t)++with the following typeclass constraints:++        requires: (Eq t, Num t)+        provides: (Show (Maybe t), Ord b)++In this case, the fields of MkPatSyn will be set as follows:++  psArgs       = [b]+  psArity      = 1+  psInfix      = False++  psUnivTyVars = [t]+  psExTyVars   = [b]+  psProvTheta  = (Show (Maybe t), Ord b)+  psReqTheta   = (Eq t, Num t)+  psResultTy  = T (Maybe t)++Note [Matchers and builders for pattern synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For each pattern synonym P, we generate++  * a "matcher" function, used to desugar uses of P in patterns,+    which implements pattern matching++  * A "builder" function (for bidirectional pattern synonyms only),+    used to desugar uses of P in expressions, which constructs P-values.++For the above example, the matcher function has type:++        $mP :: forall (r :: ?) t. (Eq t, Num t)+            => T (Maybe t)+            -> (forall b. (Show (Maybe t), Ord b) => b -> r)+            -> (Void# -> r)+            -> r++with the following implementation:++        $mP @r @t $dEq $dNum scrut cont fail+          = case scrut of+              MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x+              _                                 -> fail Void#++Notice that the return type 'r' has an open kind, so that it can+be instantiated by an unboxed type; for example where we see+     f (P x) = 3#++The extra Void# argument for the failure continuation is needed so that+it is lazy even when the result type is unboxed.++For the same reason, if the pattern has no arguments, an extra Void#+argument is added to the success continuation as well.++For *bidirectional* pattern synonyms, we also generate a "builder"+function which implements the pattern synonym in an expression+context. For our running example, it will be:++        $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b)+            => b -> T (Maybe t)+        $bP x = MkT [x] (Just 42)++NB: the existential/universal and required/provided split does not+apply to the builder since you are only putting stuff in, not getting+stuff out.++Injectivity of bidirectional pattern synonyms is checked in+tcPatToExpr which walks the pattern and returns its corresponding+expression when available.++Note [Builder for pattern synonyms with unboxed type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For bidirectional pattern synonyms that have no arguments and have an+unboxed type, we add an extra Void# argument to the builder, else it+would be a top-level declaration with an unboxed type.++        pattern P = 0#++        $bP :: Void# -> Int#+        $bP _ = 0#++This means that when typechecking an occurrence of P in an expression,+we must remember that the builder has this void argument. This is+done by TcPatSyn.patSynBuilderOcc.++Note [Pattern synonyms and the data type Type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The type of a pattern synonym is of the form (See Note+[Pattern synonym signatures] in TcSigs):++    forall univ_tvs. req => forall ex_tvs. prov => ...++We cannot in general represent this by a value of type Type:++ - if ex_tvs is empty, then req and prov cannot be distinguished from+   each other+ - if req is empty, then univ_tvs and ex_tvs cannot be distinguished+   from each other, and moreover, prov is seen as the "required" context+   (as it is the only context)+++************************************************************************+*                                                                      *+\subsection{Instances}+*                                                                      *+************************************************************************+-}++instance Eq PatSyn where+    (==) = (==) `on` getUnique+    (/=) = (/=) `on` getUnique++instance Uniquable PatSyn where+    getUnique = psUnique++instance NamedThing PatSyn where+    getName = patSynName++instance Outputable PatSyn where+    ppr = ppr . getName++instance OutputableBndr PatSyn where+    pprInfixOcc = pprInfixName . getName+    pprPrefixOcc = pprPrefixName . getName++instance Data.Data PatSyn where+    -- don't traverse?+    toConstr _   = abstractConstr "PatSyn"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "PatSyn"++{-+************************************************************************+*                                                                      *+\subsection{Construction}+*                                                                      *+************************************************************************+-}++-- | Build a new pattern synonym+mkPatSyn :: Name+         -> Bool                 -- ^ Is the pattern synonym declared infix?+         -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type+                                       -- variables and required dicts+         -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type+                                       -- variables and provided dicts+         -> [Type]               -- ^ Original arguments+         -> Type                 -- ^ Original result type+         -> (Id, Bool)           -- ^ Name of matcher+         -> Maybe (Id, Bool)     -- ^ Name of builder+         -> [FieldLabel]         -- ^ Names of fields for+                                 --   a record pattern synonym+         -> PatSyn+ -- NB: The univ and ex vars are both in TyBinder form and TyVar form for+ -- convenience. All the TyBinders should be Named!+mkPatSyn name declared_infix+         (univ_tvs, req_theta)+         (ex_tvs, prov_theta)+         orig_args+         orig_res_ty+         matcher builder field_labels+    = MkPatSyn {psName = name, psUnique = getUnique name,+                psUnivTyVars = univ_tvs,+                psExTyVars = ex_tvs,+                psProvTheta = prov_theta, psReqTheta = req_theta,+                psInfix = declared_infix,+                psArgs = orig_args,+                psArity = length orig_args,+                psResultTy = orig_res_ty,+                psMatcher = matcher,+                psBuilder = builder,+                psFieldLabels = field_labels+                }++-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification+patSynName :: PatSyn -> Name+patSynName = psName++-- | Should the 'PatSyn' be presented infix?+patSynIsInfix :: PatSyn -> Bool+patSynIsInfix = psInfix++-- | Arity of the pattern synonym+patSynArity :: PatSyn -> Arity+patSynArity = psArity++patSynArgs :: PatSyn -> [Type]+patSynArgs = psArgs++patSynFieldLabels :: PatSyn -> [FieldLabel]+patSynFieldLabels = psFieldLabels++-- | Extract the type for any given labelled field of the 'DataCon'+patSynFieldType :: PatSyn -> FieldLabelString -> Type+patSynFieldType ps label+  = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of+      Just (_, ty) -> ty+      Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label)++patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder]+patSynUnivTyVarBinders = psUnivTyVars++patSynExTyVars :: PatSyn -> [TyVar]+patSynExTyVars ps = binderVars (psExTyVars ps)++patSynExTyVarBinders :: PatSyn -> [TyVarBinder]+patSynExTyVarBinders = psExTyVars++patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)+patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs+                    , psProvTheta = prov, psReqTheta = req+                    , psArgs = arg_tys, psResultTy = res_ty })+  = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty)++patSynMatcher :: PatSyn -> (Id,Bool)+patSynMatcher = psMatcher++patSynBuilder :: PatSyn -> Maybe (Id, Bool)+patSynBuilder = psBuilder++updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn+updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })+  = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }+  where+    tidy_pr (id, dummy) = (tidy_fn id, dummy)++patSynInstArgTys :: PatSyn -> [Type] -> [Type]+-- Return the types of the argument patterns+-- e.g.  data D a = forall b. MkD a b (b->a)+--       pattern P f x y = MkD (x,True) y f+--          D :: forall a. forall b. a -> b -> (b->a) -> D a+--          P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c+--   patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]+-- NB: the inst_tys should be both universal and existential+patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs+                           , psExTyVars = ex_tvs, psArgs = arg_tys })+                 inst_tys+  = ASSERT2( tyvars `equalLength` inst_tys+          , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys )+    map (substTyWith tyvars inst_tys) arg_tys+  where+    tyvars = binderVars (univ_tvs ++ ex_tvs)++patSynInstResTy :: PatSyn -> [Type] -> Type+-- Return the type of whole pattern+-- E.g.  pattern P x y = Just (x,x,y)+--         P :: a -> b -> Just (a,a,b)+--         (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)+-- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars+patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs+                          , psResultTy = res_ty })+                inst_tys+  = ASSERT2( univ_tvs `equalLength` inst_tys+           , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )+    substTyWith (binderVars univ_tvs) inst_tys res_ty++-- | Print the type of a pattern synonym. The foralls are printed explicitly+pprPatSynType :: PatSyn -> SDoc+pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs,  psReqTheta  = req_theta+                        , psExTyVars   = ex_tvs,    psProvTheta = prov_theta+                        , psArgs       = orig_args, psResultTy = orig_res_ty })+  = sep [ pprForAll univ_tvs+        , pprThetaArrowTy req_theta+        , ppWhen insert_empty_ctxt $ parens empty <+> darrow+        , pprType sigma_ty ]+  where+    sigma_ty = mkForAllTys ex_tvs  $+               mkInvisFunTys prov_theta $+               mkVisFunTys orig_args orig_res_ty+    insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs)
+ compiler/GHC/Core/PatSyn.hs-boot view
@@ -0,0 +1,13 @@+module GHC.Core.PatSyn where++import GHC.Types.Basic (Arity)+import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type)+import GHC.Types.Var (TyVar)+import GHC.Types.Name (Name)++data PatSyn++patSynArity :: PatSyn -> Arity+patSynInstArgTys :: PatSyn -> [Type] -> [Type]+patSynExTyVars :: PatSyn -> [TyVar]+patSynName :: PatSyn -> Name
compiler/GHC/Core/Ppr.hs view
@@ -21,23 +21,23 @@  import GHC.Core import GHC.Core.Stats (exprStats)-import Literal( pprLiteral )-import Name( pprInfixName, pprPrefixName )-import Var-import Id-import IdInfo-import Demand-import Cpr-import DataCon-import TyCon-import TyCoPpr-import Coercion-import BasicTypes+import GHC.Types.Literal( pprLiteral )+import GHC.Types.Name( pprInfixName, pprPrefixName )+import GHC.Types.Var+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Core.DataCon+import GHC.Core.TyCon+import GHC.Core.TyCo.Ppr+import GHC.Core.Coercion+import GHC.Types.Basic import Maybes import Util import Outputable import FastString-import SrcLoc      ( pprUserRealSpan )+import GHC.Types.SrcLoc ( pprUserRealSpan )  {- ************************************************************************
+ compiler/GHC/Core/Predicate.hs view
@@ -0,0 +1,228 @@+{-++Describes predicates as they are considered by the solver.++-}++module GHC.Core.Predicate (+  Pred(..), classifyPredType,+  isPredTy, isEvVarType,++  -- Equality predicates+  EqRel(..), eqRelRole,+  isEqPrimPred, isEqPred,+  getEqPredTys, getEqPredTys_maybe, getEqPredRole,+  predTypeEqRel,+  mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,+  mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,++  -- Class predicates+  mkClassPred, isDictTy,+  isClassPred, isEqPredClass, isCTupleClass,+  getClassPredTys, getClassPredTys_maybe,++  -- Implicit parameters+  isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, hasIPPred,++  -- Evidence variables+  DictId, isEvVar, isDictId+  ) where++import GhcPrelude++import GHC.Core.Type+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Types.Var+import GHC.Core.Coercion++import PrelNames++import FastString+import Outputable+import Util++import Control.Monad ( guard )++-- | A predicate in the solver. The solver tries to prove Wanted predicates+-- from Given ones.+data Pred+  = ClassPred Class [Type]+  | EqPred EqRel Type Type+  | IrredPred PredType+  | ForAllPred [TyVar] [PredType] PredType+     -- ForAllPred: see Note [Quantified constraints] in TcCanonical+  -- NB: There is no TuplePred case+  --     Tuple predicates like (Eq a, Ord b) are just treated+  --     as ClassPred, as if we had a tuple class with two superclasses+  --        class (c1, c2) => (%,%) c1 c2++classifyPredType :: PredType -> Pred+classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of+    Just (tc, [_, _, ty1, ty2])+      | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2+      | tc `hasKey` eqPrimTyConKey     -> EqPred NomEq ty1 ty2++    Just (tc, tys)+      | Just clas <- tyConClass_maybe tc+      -> ClassPred clas tys++    _ | (tvs, rho) <- splitForAllTys ev_ty+      , (theta, pred) <- splitFunTys rho+      , not (null tvs && null theta)+      -> ForAllPred tvs theta pred++      | otherwise+      -> IrredPred ev_ty++-- --------------------- Dictionary types ---------------------------------++mkClassPred :: Class -> [Type] -> PredType+mkClassPred clas tys = mkTyConApp (classTyCon clas) tys++isDictTy :: Type -> Bool+isDictTy = isClassPred++getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type])+getClassPredTys ty = case getClassPredTys_maybe ty of+        Just (clas, tys) -> (clas, tys)+        Nothing          -> pprPanic "getClassPredTys" (ppr ty)++getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])+getClassPredTys_maybe ty = case splitTyConApp_maybe ty of+        Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys)+        _ -> Nothing++-- --------------------- Equality predicates ---------------------------------++-- | A choice of equality relation. This is separate from the type 'Role'+-- because 'Phantom' does not define a (non-trivial) equality relation.+data EqRel = NomEq | ReprEq+  deriving (Eq, Ord)++instance Outputable EqRel where+  ppr NomEq  = text "nominal equality"+  ppr ReprEq = text "representational equality"++eqRelRole :: EqRel -> Role+eqRelRole NomEq  = Nominal+eqRelRole ReprEq = Representational++getEqPredTys :: PredType -> (Type, Type)+getEqPredTys ty+  = case splitTyConApp_maybe ty of+      Just (tc, [_, _, ty1, ty2])+        |  tc `hasKey` eqPrimTyConKey+        || tc `hasKey` eqReprPrimTyConKey+        -> (ty1, ty2)+      _ -> pprPanic "getEqPredTys" (ppr ty)++getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type)+getEqPredTys_maybe ty+  = case splitTyConApp_maybe ty of+      Just (tc, [_, _, ty1, ty2])+        | tc `hasKey` eqPrimTyConKey     -> Just (Nominal, ty1, ty2)+        | tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2)+      _ -> Nothing++getEqPredRole :: PredType -> Role+getEqPredRole ty = eqRelRole (predTypeEqRel ty)++-- | Get the equality relation relevant for a pred type.+predTypeEqRel :: PredType -> EqRel+predTypeEqRel ty+  | Just (tc, _) <- splitTyConApp_maybe ty+  , tc `hasKey` eqReprPrimTyConKey+  = ReprEq+  | otherwise+  = NomEq++{-------------------------------------------+Predicates on PredType+--------------------------------------------}++{-+Note [Evidence for quantified constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The superclass mechanism in TcCanonical.makeSuperClasses risks+taking a quantified constraint like+   (forall a. C a => a ~ b)+and generate superclass evidence+   (forall a. C a => a ~# b)++This is a funny thing: neither isPredTy nor isCoVarType are true+of it.  So we are careful not to generate it in the first place:+see Note [Equality superclasses in quantified constraints]+in TcCanonical.+-}++isEvVarType :: Type -> Bool+-- True of (a) predicates, of kind Constraint, such as (Eq a), and (a ~ b)+--         (b) coercion types, such as (t1 ~# t2) or (t1 ~R# t2)+-- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep+-- See Note [Evidence for quantified constraints]+isEvVarType ty = isCoVarType ty || isPredTy ty++isEqPredClass :: Class -> Bool+-- True of (~) and (~~)+isEqPredClass cls =  cls `hasKey` eqTyConKey+                  || cls `hasKey` heqTyConKey++isClassPred, isEqPred, isEqPrimPred, isIPPred :: PredType -> Bool+isClassPred ty = case tyConAppTyCon_maybe ty of+    Just tyCon | isClassTyCon tyCon -> True+    _                               -> False++isEqPred ty  -- True of (a ~ b) and (a ~~ b)+             -- ToDo: should we check saturation?+  | Just tc <- tyConAppTyCon_maybe ty+  , Just cls <- tyConClass_maybe tc+  = isEqPredClass cls+  | otherwise+  = False++isEqPrimPred ty = isCoVarType ty+  -- True of (a ~# b) (a ~R# b)++isIPPred ty = case tyConAppTyCon_maybe ty of+    Just tc -> isIPTyCon tc+    _       -> False++isIPTyCon :: TyCon -> Bool+isIPTyCon tc = tc `hasKey` ipClassKey+  -- Class and its corresponding TyCon have the same Unique++isIPClass :: Class -> Bool+isIPClass cls = cls `hasKey` ipClassKey++isCTupleClass :: Class -> Bool+isCTupleClass cls = isTupleTyCon (classTyCon cls)++isIPPred_maybe :: Type -> Maybe (FastString, Type)+isIPPred_maybe ty =+  do (tc,[t1,t2]) <- splitTyConApp_maybe ty+     guard (isIPTyCon tc)+     x <- isStrLitTy t1+     return (x,t2)++hasIPPred :: PredType -> Bool+hasIPPred pred+  = case classifyPredType pred of+      ClassPred cls tys+        | isIPClass     cls -> True+        | isCTupleClass cls -> any hasIPPred tys+      _other -> False++{-+************************************************************************+*                                                                      *+              Evidence variables+*                                                                      *+************************************************************************+-}++isEvVar :: Var -> Bool+isEvVar var = isEvVarType (varType var)++isDictId :: Id -> Bool+isDictId id = isDictTy (varType id)
compiler/GHC/Core/Rules.hs view
@@ -31,7 +31,7 @@ import GhcPrelude  import GHC.Core         -- All of it-import Module           ( Module, ModuleSet, elemModuleSet )+import GHC.Types.Module   ( Module, ModuleSet, elemModuleSet ) import GHC.Core.Subst import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) import GHC.Core.FVs     ( exprFreeVars, exprsFreeVars, bindFreeVars@@ -40,24 +40,26 @@                         , stripTicksTopT, stripTicksTopE                         , isJoinBind ) import GHC.Core.Ppr     ( pprRules )-import Type             ( Type, TCvSubst, extendTvSubst, extendCvSubst-                        , mkEmptyTCvSubst, substTy )+import GHC.Core.Type as Type+   ( Type, TCvSubst, extendTvSubst, extendCvSubst+   , mkEmptyTCvSubst, substTy ) import TcType           ( tcSplitTyConApp_maybe ) import TysWiredIn       ( anyTypeOfKind )-import Coercion+import GHC.Core.Coercion as Coercion import GHC.Core.Op.Tidy ( tidyRules )-import Id-import IdInfo           ( RuleInfo( RuleInfo ) )-import Var-import VarEnv-import VarSet-import Name             ( Name, NamedThing(..), nameIsLocalOrFrom )-import NameSet-import NameEnv-import UniqFM-import Unify            ( ruleMatchTyKiX )-import BasicTypes-import GHC.Driver.Session         ( DynFlags )+import GHC.Types.Id+import GHC.Types.Id.Info ( RuleInfo( RuleInfo ) )+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name    ( Name, NamedThing(..), nameIsLocalOrFrom )+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Types.Unique.FM+import GHC.Core.Unify as Unify ( ruleMatchTyKiX )+import GHC.Types.Basic+import GHC.Driver.Session      ( DynFlags, gopt, targetPlatform )+import GHC.Driver.Flags import Outputable import FastString import Maybes@@ -113,7 +115,7 @@     (d) Rules in the ExternalPackageTable. These can grow in response         to lazy demand-loading of interfaces. -* At the moment (c) is carried in a reader-monad way by the CoreMonad.+* At the moment (c) is carried in a reader-monad way by the GHC.Core.Op.Monad.   The HomePackageTable doesn't have a single RuleBase because technically   we should only be able to "see" rules "below" this module; so we   generate a RuleBase for (c) by combing rules from all the modules@@ -126,7 +128,7 @@ * So in the outer simplifier loop, we combine (b-d) into a single   RuleBase, reading      (b) from the ModGuts,-     (c) from the CoreMonad, and+     (c) from the GHC.Core.Op.Monad, and      (d) from its mutable variable   [Of course this means that we won't see new EPS rules that come in   during a single simplifier iteration, but that probably does not@@ -181,7 +183,7 @@            ru_orphan = orph,            ru_auto = is_auto, ru_local = is_local }   where-        -- Compute orphanhood.  See Note [Orphans] in InstEnv+        -- Compute orphanhood.  See Note [Orphans] in GHC.Core.InstEnv         -- A rule is an orphan only if none of the variables         -- mentioned on its left-hand side are locally defined     lhs_names = extendNameSet (exprsOrphNames args) fn@@ -329,7 +331,7 @@      - PrimOps and ClassOps are born with a bunch of rules inside the Id,        even when they are imported -     - The rules in PrelRules.builtinRules should be active even+     - The rules in GHC.Core.Op.ConstantFold.builtinRules should be active even        in the module defining the Id (when it's a LocalId), but        the rules are kept in the global RuleBase @@ -509,7 +511,12 @@ matchRule dflags rule_env _is_active fn args _rough_args           (BuiltinRule { ru_try = match_fn }) -- Built-in rules can't be switched off, it seems-  = case match_fn dflags rule_env fn args of+  = let env = RuleOpts+               { roPlatform = targetPlatform dflags+               , roNumConstantFolding = gopt Opt_NumConstantFolding dflags+               , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags+               }+    in case match_fn env rule_env fn args of         Nothing   -> Nothing         Just expr -> Just expr @@ -734,7 +741,7 @@ -- might substitute [a/b] in the template, and then erroneously -- succeed in matching what looks like the template variable 'a' against 3. --- The Var case follows closely what happens in Unify.match+-- The Var case follows closely what happens in GHC.Core.Unify.match match renv subst (Var v1) e2   = match_var renv subst v1 e2 @@ -1022,7 +1029,7 @@ On the other hand, where we are allowed to insert new cost into the tick scope, we can float them upwards to the rule application site. -cf Note [Notes in call patterns] in SpecConstr+cf Note [Notes in call patterns] in GHC.Core.Op.SpecConstr  Note [Matching lets] ~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Seq.hs view
@@ -13,15 +13,15 @@ import GhcPrelude  import GHC.Core-import IdInfo-import Demand( seqDemand, seqStrictSig )-import Cpr( seqCprSig )-import BasicTypes( seqOccInfo )-import VarSet( seqDVarSet )-import Var( varType, tyVarKind )-import Type( seqType, isTyVar )-import Coercion( seqCo )-import Id( Id, idInfo )+import GHC.Types.Id.Info+import GHC.Types.Demand( seqDemand, seqStrictSig )+import GHC.Types.Cpr( seqCprSig )+import GHC.Types.Basic( seqOccInfo )+import GHC.Types.Var.Set( seqDVarSet )+import GHC.Types.Var( varType, tyVarKind )+import GHC.Core.Type( seqType, isTyVar )+import GHC.Core.Coercion( seqCo )+import GHC.Types.Id( Id, idInfo )  -- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the -- compiler
compiler/GHC/Core/SimpleOpt.hs view
@@ -31,24 +31,24 @@ import {-# SOURCE #-} GHC.Core.Unfold( mkUnfolding ) import GHC.Core.Make ( FloatBind(..) ) import GHC.Core.Ppr  ( pprCoreBindings, pprRules )-import OccurAnal( occurAnalyseExpr, occurAnalysePgm )-import Literal  ( Literal(LitString) )-import Id-import IdInfo   ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) )-import Var      ( isNonCoVarId )-import VarSet-import VarEnv-import DataCon-import Demand( etaExpandStrictSig )-import OptCoercion ( optCoercion )-import Type     hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList-                       , isInScope, substTyVarBndr, cloneTyVarBndr )-import Coercion hiding ( substCo, substCoVarBndr )-import TyCon        ( tyConArity )+import GHC.Core.Op.OccurAnal( occurAnalyseExpr, occurAnalysePgm )+import GHC.Types.Literal  ( Literal(LitString) )+import GHC.Types.Id+import GHC.Types.Id.Info  ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) )+import GHC.Types.Var      ( isNonCoVarId )+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Core.DataCon+import GHC.Types.Demand( etaExpandStrictSig )+import GHC.Core.Coercion.Opt ( optCoercion )+import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList+                            , isInScope, substTyVarBndr, cloneTyVarBndr )+import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )+import GHC.Core.TyCon ( tyConArity ) import TysWiredIn import PrelNames-import BasicTypes-import Module       ( Module )+import GHC.Types.Basic+import GHC.Types.Module ( Module ) import ErrUtils import GHC.Driver.Session import Outputable@@ -469,7 +469,7 @@     post_inline_unconditionally        | isExportedId in_bndr  = False -- Note [Exported Ids and trivial RHSs]        | stable_unf            = False -- Note [Stable unfoldings and postInlineUnconditionally]-       | not active            = False --     in SimplUtils+       | not active            = False --     in GHC.Core.Op.Simplify.Utils        | is_loop_breaker       = False -- If it's a loop-breaker of any kind, don't inline                                        -- because it might be referred to "earlier"        | exprIsTrivial out_rhs = True@@ -489,7 +489,7 @@ {- Note [Exported Ids and trivial RHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We obviously do not want to unconditionally inline an Id that is exported.-In SimplUtils, Note [Top level and postInlineUnconditionally], we+In GHC.Core.Op.Simplify.Utils, Note [Top level and postInlineUnconditionally], we explain why we don't inline /any/ top-level things unconditionally, even trivial ones.  But we do here!  Why?  In the simple optimiser @@ -673,7 +673,7 @@  However, we don't want to inline 'seq', which happens to also have a compulsory unfolding, so we only do this unfolding only for things-that are always-active.  See Note [User-defined RULES for seq] in MkId.+that are always-active.  See Note [User-defined RULES for seq] in GHC.Types.Id.Make.  Note [Getting the map/coerce RULE to work] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -965,7 +965,7 @@ -- [exprIsConApp_maybe on data constructors with wrappers]. Data constructor wrappers -- are unfolded late, but we really want to trigger case-of-known-constructor as -- early as possible. See also Note [Activation for data constructor wrappers]--- in MkId.+-- in GHC.Types.Id.Make. -- -- We also return the incoming InScopeSet, augmented with -- the binders from any [FloatBind] that we return@@ -1247,7 +1247,7 @@ -- We have (fun |> co) arg, and we want to transform it to --         (fun arg) |> co -- This may fail, e.g. if (fun :: N) where N is a newtype--- C.f. simplCast in Simplify.hs+-- C.f. simplCast in GHC.Core.Op.Simplify -- 'co' is always Representational -- If the returned coercion is Nothing, then it would have been reflexive pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty
compiler/GHC/Core/Stats.hs view
@@ -13,13 +13,13 @@  import GhcPrelude -import BasicTypes+import GHC.Types.Basic import GHC.Core import Outputable-import Coercion-import Var-import Type (Type, typeSize)-import Id (isJoinId)+import GHC.Core.Coercion+import GHC.Types.Var+import GHC.Core.Type(Type, typeSize)+import GHC.Types.Id (isJoinId)  data CoreStats = CS { cs_tm :: !Int    -- Terms                     , cs_ty :: !Int    -- Types
compiler/GHC/Core/Subst.hs view
@@ -43,22 +43,23 @@ import GHC.Core.FVs import GHC.Core.Seq import GHC.Core.Utils-import qualified Type-import qualified Coercion+import qualified GHC.Core.Type as Type+import qualified GHC.Core.Coercion as Coercion          -- We are defining local versions-import Type     hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList-                       , isInScope, substTyVarBndr, cloneTyVarBndr )-import Coercion hiding ( substCo, substCoVarBndr )+import GHC.Core.Type hiding+   ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList+   , isInScope, substTyVarBndr, cloneTyVarBndr )+import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )  import PrelNames-import VarSet-import VarEnv-import Id-import Name     ( Name )-import Var-import IdInfo-import UniqSupply+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Id+import GHC.Types.Name     ( Name )+import GHC.Types.Var+import GHC.Types.Id.Info+import GHC.Types.Unique.Supply import Maybes import Util import Outputable@@ -79,9 +80,9 @@ -- -- Some invariants apply to how you use the substitution: ----- 1. Note [The substitution invariant] in TyCoSubst+-- 1. Note [The substitution invariant] in GHC.Core.TyCo.Subst ----- 2. Note [Substitutions apply only once] in TyCoSubst+-- 2. Note [Substitutions apply only once] in GHC.Core.TyCo.Subst data Subst   = Subst InScopeSet  -- Variables in in scope (both Ids and TyVars) /after/                       -- applying the substitution@@ -104,7 +105,7 @@ For a core Subst, which binds Ids as well, we make a different choice for Ids than we do for TyVars. -For TyVars, see Note [Extending the TCvSubst] in TyCoSubst.+For TyVars, see Note [Extending the TCvSubst] in GHC.Core.TyCo.Subst.  For Ids, we have a different invariant         The IdSubstEnv is extended *only* when the Unique on an Id changes@@ -339,7 +340,7 @@  -- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only -- apply the substitution /once/:--- See Note [Substitutions apply only once] in TyCoSubst+-- See Note [Substitutions apply only once] in GHC.Core.TyCo.Subst -- -- Do *not* attempt to short-cut in the case of an empty substitution! -- See Note [Extending the Subst]
+ compiler/GHC/Core/TyCo/FVs.hs view
@@ -0,0 +1,984 @@+{-# LANGUAGE CPP #-}++module GHC.Core.TyCo.FVs+  (     shallowTyCoVarsOfType, shallowTyCoVarsOfTypes,+        tyCoVarsOfType,        tyCoVarsOfTypes,+        tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet,++        tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs,+        tyCoFVsOfType, tyCoVarsOfTypeList,+        tyCoFVsOfTypes, tyCoVarsOfTypesList,+        deepTcvFolder,++        shallowTyCoVarsOfTyVarEnv, shallowTyCoVarsOfCoVarEnv,++        shallowTyCoVarsOfCo, shallowTyCoVarsOfCos,+        tyCoVarsOfCo,        tyCoVarsOfCos,+        coVarsOfType, coVarsOfTypes,+        coVarsOfCo, coVarsOfCos,+        tyCoVarsOfCoDSet,+        tyCoFVsOfCo, tyCoFVsOfCos,+        tyCoVarsOfCoList,++        almostDevoidCoVarOfCo,++        -- Injective free vars+        injectiveVarsOfType, injectiveVarsOfTypes,+        invisibleVarsOfType, invisibleVarsOfTypes,++        -- No Free vars+        noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo,++        -- * Well-scoped free variables+        scopedSort, tyCoVarsOfTypeWellScoped,+        tyCoVarsOfTypesWellScoped,++        -- * Closing over kinds+        closeOverKindsDSet, closeOverKindsList,+        closeOverKinds,++        -- * Raw materials+        Endo(..), runTyCoVars+  ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes)++import Data.Monoid as DM ( Endo(..), All(..) )+import GHC.Core.TyCo.Rep+import GHC.Core.TyCon+import GHC.Types.Var+import FV++import GHC.Types.Unique.FM+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import Util+import Panic++{-+%************************************************************************+%*                                                                      *+                 Free variables of types and coercions+%*                                                                      *+%************************************************************************+-}++{- Note [Shallow and deep free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Definitions++* Shallow free variables of a type: the variables+  affected by substitution. Specifically, the (TyVarTy tv)+  and (CoVar cv) that appear+    - In the type and coercions appearing in the type+    - In shallow free variables of the kind of a Forall binder+  but NOT in the kind of the /occurrences/ of a type variable.++* Deep free variables of a type: shallow free variables, plus+  the deep free variables of the kinds of those variables.+  That is,  deepFVs( t ) = closeOverKinds( shallowFVs( t ) )++Examples:++  Type                     Shallow     Deep+  ---------------------------------+  (a : (k:Type))           {a}        {a,k}+  forall (a:(k:Type)). a   {k}        {k}+  (a:k->Type) (b:k)        {a,b}      {a,b,k}+-}+++{- Note [Free variables of types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns+a VarSet that is closed over the types of its variables.  More precisely,+  if    S = tyCoVarsOfType( t )+  and   (a:k) is in S+  then  tyCoVarsOftype( k ) is a subset of S++Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}.++We could /not/ close over the kinds of the variable occurrences, and+instead do so at call sites, but it seems that we always want to do+so, so it's easiest to do it here.++It turns out that getting the free variables of types is performance critical,+so we profiled several versions, exploring different implementation strategies.++1. Baseline version: uses FV naively. Essentially:++   tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty++   This is not nice, because FV introduces some overhead to implement+   determinism, and through its "interesting var" function, neither of which+   we need here, so they are a complete waste.++2. UnionVarSet version: instead of reusing the FV-based code, we simply used+   VarSets directly, trying to avoid the overhead of FV. E.g.:++   -- FV version:+   tyCoFVsOfType (AppTy fun arg)    a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c++   -- UnionVarSet version:+   tyCoVarsOfType (AppTy fun arg)    = (tyCoVarsOfType fun `unionVarSet` tyCoVarsOfType arg)++   This looks deceptively similar, but while FV internally builds a list- and+   set-generating function, the VarSet functions manipulate sets directly, and+   the latter performs a lot worse than the naive FV version.++3. Accumulator-style VarSet version: this is what we use now. We do use VarSet+   as our data structure, but delegate the actual work to a new+   ty_co_vars_of_...  family of functions, which use accumulator style and the+   "in-scope set" filter found in the internals of FV, but without the+   determinism overhead.++See #14880.++Note [Closing over free variable kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tyCoVarsOfType and tyCoFVsOfType, while traversing a type, will also close over+free variable kinds. In previous GHC versions, this happened naively: whenever+we would encounter an occurrence of a free type variable, we would close over+its kind. This, however is wrong for two reasons (see #14880):++1. Efficiency. If we have Proxy (a::k) -> Proxy (a::k) -> Proxy (a::k), then+   we don't want to have to traverse k more than once.++2. Correctness. Imagine we have forall k. b -> k, where b has+   kind k, for some k bound in an outer scope. If we look at b's kind inside+   the forall, we'll collect that k is free and then remove k from the set of+   free variables. This is plain wrong. We must instead compute that b is free+   and then conclude that b's kind is free.++An obvious first approach is to move the closing-over-kinds from the+occurrences of a type variable to after finding the free vars - however, this+turns out to introduce performance regressions, and isn't even entirely+correct.++In fact, it isn't even important *when* we close over kinds; what matters is+that we handle each type var exactly once, and that we do it in the right+context.++So the next approach we tried was to use the "in-scope set" part of FV or the+equivalent argument in the accumulator-style `ty_co_vars_of_type` function, to+say "don't bother with variables we have already closed over". This should work+fine in theory, but the code is complicated and doesn't perform well.++But there is a simpler way, which is implemented here. Consider the two points+above:++1. Efficiency: we now have an accumulator, so the second time we encounter 'a',+   we'll ignore it, certainly not looking at its kind - this is why+   pre-checking set membership before inserting ends up not only being faster,+   but also being correct.++2. Correctness: we have an "in-scope set" (I think we should call it it a+  "bound-var set"), specifying variables that are bound by a forall in the type+  we are traversing; we simply ignore these variables, certainly not looking at+  their kind.++So now consider:++    forall k. b -> k++where b :: k->Type is free; but of course, it's a different k! When looking at+b -> k we'll have k in the bound-var set. So we'll ignore the k. But suppose+this is our first encounter with b; we want the free vars of its kind. But we+want to behave as if we took the free vars of its kind at the end; that is,+with no bound vars in scope.++So the solution is easy. The old code was this:++  ty_co_vars_of_type (TyVarTy v) is acc+    | v `elemVarSet` is  = acc+    | v `elemVarSet` acc = acc+    | otherwise          = ty_co_vars_of_type (tyVarKind v) is (extendVarSet acc v)++Now all we need to do is take the free vars of tyVarKind v *with an empty+bound-var set*, thus:++ty_co_vars_of_type (TyVarTy v) is acc+  | v `elemVarSet` is  = acc+  | v `elemVarSet` acc = acc+  | otherwise          = ty_co_vars_of_type (tyVarKind v) emptyVarSet (extendVarSet acc v)+                                                          ^^^^^^^^^^^++And that's it. This works because a variable is either bound or free. If it is bound,+then we won't look at it at all. If it is free, then all the variables free in its+kind are free -- regardless of whether some local variable has the same Unique.+So if we're looking at a variable occurrence at all, then all variables in its+kind are free.+-}++{- *********************************************************************+*                                                                      *+          Endo for free variables+*                                                                      *+********************************************************************* -}++{- Note [Acumulating parameter free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can use foldType to build an accumulating-parameter version of a+free-var finder, thus:++    fvs :: Type -> TyCoVarSet+    fvs ty = appEndo (foldType folder ty) emptyVarSet++Recall that+    foldType :: TyCoFolder env a -> env -> Type -> a++    newtype Endo a = Endo (a -> a)   -- In Data.Monoid+    instance Monoid a => Monoid (Endo a) where+       (Endo f) `mappend` (Endo g) = Endo (f.g)++    appEndo :: Endo a -> a -> a+    appEndo (Endo f) x = f x++So `mappend` for Endos is just function composition.++It's very important that, after optimisation, we end up with+* an arity-three function+* that is strict in the accumulator++   fvs env (TyVarTy v) acc+      | v `elemVarSet` env = acc+      | v `elemVarSet` acc = acc+      | otherwise          = acc `extendVarSet` v+   fvs env (AppTy t1 t2)   = fvs env t1 (fvs env t2 acc)+   ...++The "strict in the accumulator" part is to ensure that in the+AppTy equation we don't build a thunk for (fvs env t2 acc).++The optimiser does do all this, but not very robustly. It depends+critially on the basic arity-2 function not being exported, so that+all its calls are visibly to three arguments. This analysis is+done by the Call Arity pass.++TL;DR: check this regularly!+-}++runTyCoVars :: Endo TyCoVarSet -> TyCoVarSet+{-# INLINE runTyCoVars #-}+runTyCoVars f = appEndo f emptyVarSet++noView :: Type -> Maybe Type+noView _ = Nothing++{- *********************************************************************+*                                                                      *+          Deep free variables+          See Note [Shallow and deep free variables]+*                                                                      *+********************************************************************* -}++tyCoVarsOfType :: Type -> TyCoVarSet+tyCoVarsOfType ty = runTyCoVars (deep_ty ty)+-- Alternative:+--   tyCoVarsOfType ty = closeOverKinds (shallowTyCoVarsOfType ty)++tyCoVarsOfTypes :: [Type] -> TyCoVarSet+tyCoVarsOfTypes tys = runTyCoVars (deep_tys tys)+-- Alternative:+--   tyCoVarsOfTypes tys = closeOverKinds (shallowTyCoVarsOfTypes tys)++tyCoVarsOfCo :: Coercion -> TyCoVarSet+-- See Note [Free variables of Coercions]+tyCoVarsOfCo co = runTyCoVars (deep_co co)++tyCoVarsOfCos :: [Coercion] -> TyCoVarSet+tyCoVarsOfCos cos = runTyCoVars (deep_cos cos)++deep_ty  :: Type       -> Endo TyCoVarSet+deep_tys :: [Type]     -> Endo TyCoVarSet+deep_co  :: Coercion   -> Endo TyCoVarSet+deep_cos :: [Coercion] -> Endo TyCoVarSet+(deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet++deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)+deepTcvFolder = TyCoFolder { tcf_view = noView+                           , tcf_tyvar = do_tcv, tcf_covar = do_tcv+                           , tcf_hole  = do_hole, tcf_tycobinder = do_bndr }+  where+    do_tcv is v = Endo do_it+      where+        do_it acc | v `elemVarSet` is  = acc+                  | v `elemVarSet` acc = acc+                  | otherwise          = appEndo (deep_ty (varType v)) $+                                         acc `extendVarSet` v++    do_bndr is tcv _ = extendVarSet is tcv+    do_hole is hole  = do_tcv is (coHoleCoVar hole)+                       -- See Note [CoercionHoles and coercion free variables]+                       -- in GHC.Core.TyCo.Rep++{- *********************************************************************+*                                                                      *+          Shallow free variables+          See Note [Shallow and deep free variables]+*                                                                      *+********************************************************************* -}+++shallowTyCoVarsOfType :: Type -> TyCoVarSet+-- See Note [Free variables of types]+shallowTyCoVarsOfType ty = runTyCoVars (shallow_ty ty)++shallowTyCoVarsOfTypes :: [Type] -> TyCoVarSet+shallowTyCoVarsOfTypes tys = runTyCoVars (shallow_tys tys)++shallowTyCoVarsOfCo :: Coercion -> TyCoVarSet+shallowTyCoVarsOfCo co = runTyCoVars (shallow_co co)++shallowTyCoVarsOfCos :: [Coercion] -> TyCoVarSet+shallowTyCoVarsOfCos cos = runTyCoVars (shallow_cos cos)++-- | Returns free variables of types, including kind variables as+-- a non-deterministic set. For type synonyms it does /not/ expand the+-- synonym.+shallowTyCoVarsOfTyVarEnv :: TyVarEnv Type -> TyCoVarSet+-- See Note [Free variables of types]+shallowTyCoVarsOfTyVarEnv tys = shallowTyCoVarsOfTypes (nonDetEltsUFM tys)+  -- It's OK to use nonDetEltsUFM here because we immediately+  -- forget the ordering by returning a set++shallowTyCoVarsOfCoVarEnv :: CoVarEnv Coercion -> TyCoVarSet+shallowTyCoVarsOfCoVarEnv cos = shallowTyCoVarsOfCos (nonDetEltsUFM cos)+  -- It's OK to use nonDetEltsUFM here because we immediately+  -- forget the ordering by returning a set++shallow_ty  :: Type       -> Endo TyCoVarSet+shallow_tys :: [Type]     -> Endo TyCoVarSet+shallow_co  :: Coercion   -> Endo TyCoVarSet+shallow_cos :: [Coercion] -> Endo TyCoVarSet+(shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet++shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)+shallowTcvFolder = TyCoFolder { tcf_view = noView+                              , tcf_tyvar = do_tcv, tcf_covar = do_tcv+                              , tcf_hole  = do_hole, tcf_tycobinder = do_bndr }+  where+    do_tcv is v = Endo do_it+      where+        do_it acc | v `elemVarSet` is  = acc+                  | v `elemVarSet` acc = acc+                  | otherwise          = acc `extendVarSet` v++    do_bndr is tcv _ = extendVarSet is tcv+    do_hole _ _  = mempty   -- Ignore coercion holes+++{- *********************************************************************+*                                                                      *+          Free coercion variables+*                                                                      *+********************************************************************* -}+++{- Note [Finding free coercion varibles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here we are only interested in the free /coercion/ variables.+We can achieve this through a slightly differnet TyCo folder.++Notice that we look deeply, into kinds.++See #14880.+-}++coVarsOfType  :: Type       -> CoVarSet+coVarsOfTypes :: [Type]     -> CoVarSet+coVarsOfCo    :: Coercion   -> CoVarSet+coVarsOfCos   :: [Coercion] -> CoVarSet++coVarsOfType  ty  = runTyCoVars (deep_cv_ty ty)+coVarsOfTypes tys = runTyCoVars (deep_cv_tys tys)+coVarsOfCo    co  = runTyCoVars (deep_cv_co co)+coVarsOfCos   cos = runTyCoVars (deep_cv_cos cos)++deep_cv_ty  :: Type       -> Endo CoVarSet+deep_cv_tys :: [Type]     -> Endo CoVarSet+deep_cv_co  :: Coercion   -> Endo CoVarSet+deep_cv_cos :: [Coercion] -> Endo CoVarSet+(deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos) = foldTyCo deepCoVarFolder emptyVarSet++deepCoVarFolder :: TyCoFolder TyCoVarSet (Endo CoVarSet)+deepCoVarFolder = TyCoFolder { tcf_view = noView+                             , tcf_tyvar = do_tyvar, tcf_covar = do_covar+                             , tcf_hole  = do_hole, tcf_tycobinder = do_bndr }+  where+    do_tyvar _ _  = mempty+      -- This do_tyvar means we won't see any CoVars in this+      -- TyVar's kind.   This may be wrong; but it's the way it's+      -- always been.  And its awkward to change, because+      -- the tyvar won't end up in the accumulator, so+      -- we'd look repeatedly.  Blargh.++    do_covar is v = Endo do_it+      where+        do_it acc | v `elemVarSet` is  = acc+                  | v `elemVarSet` acc = acc+                  | otherwise          = appEndo (deep_cv_ty (varType v)) $+                                         acc `extendVarSet` v++    do_bndr is tcv _ = extendVarSet is tcv+    do_hole is hole  = do_covar is (coHoleCoVar hole)+                       -- See Note [CoercionHoles and coercion free variables]+                       -- in GHC.Core.TyCo.Rep+++{- *********************************************************************+*                                                                      *+          Closing over kinds+*                                                                      *+********************************************************************* -}++------------- Closing over kinds -----------------++closeOverKinds :: TyCoVarSet -> TyCoVarSet+-- For each element of the input set,+-- add the deep free variables of its kind+closeOverKinds vs = nonDetFoldVarSet do_one vs vs+  where+    do_one v acc = appEndo (deep_ty (varType v)) acc++{- --------------- Alternative version 1 (using FV) ------------+closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet+-}++{- ---------------- Alternative version 2 -------------++-- | Add the kind variables free in the kinds of the tyvars in the given set.+-- Returns a non-deterministic set.+closeOverKinds :: TyCoVarSet -> TyCoVarSet+closeOverKinds vs+   = go vs vs+  where+    go :: VarSet   -- Work list+       -> VarSet   -- Accumulator, always a superset of wl+       -> VarSet+    go wl acc+      | isEmptyVarSet wl = acc+      | otherwise        = go wl_kvs (acc `unionVarSet` wl_kvs)+      where+        k v inner_acc = ty_co_vars_of_type (varType v) acc inner_acc+        wl_kvs = nonDetFoldVarSet k emptyVarSet wl+        -- wl_kvs = union of shallow free vars of the kinds of wl+        --          but don't bother to collect vars in acc++-}++{- ---------------- Alternative version 3 -------------+-- | Add the kind variables free in the kinds of the tyvars in the given set.+-- Returns a non-deterministic set.+closeOverKinds :: TyVarSet -> TyVarSet+closeOverKinds vs = close_over_kinds vs emptyVarSet+++close_over_kinds :: TyVarSet  -- Work list+                 -> TyVarSet  -- Accumulator+                 -> TyVarSet+-- Precondition: in any call (close_over_kinds wl acc)+--  for every tv in acc, the shallow kind-vars of tv+--  are either in the work list wl, or in acc+-- Postcondition: result is the deep free vars of (wl `union` acc)+close_over_kinds wl acc+  = nonDetFoldVarSet do_one acc wl+  where+    do_one :: Var -> TyVarSet -> TyVarSet+    -- (do_one v acc) adds v and its deep free-vars to acc+    do_one v acc | v `elemVarSet` acc+                 = acc+                 | otherwise+                 = close_over_kinds (shallowTyCoVarsOfType (varType v)) $+                   acc `extendVarSet` v+-}+++{- *********************************************************************+*                                                                      *+          The FV versions return deterministic results+*                                                                      *+********************************************************************* -}++-- | Given a list of tyvars returns a deterministic FV computation that+-- returns the given tyvars with the kind variables free in the kinds of the+-- given tyvars.+closeOverKindsFV :: [TyVar] -> FV+closeOverKindsFV tvs =+  mapUnionFV (tyCoFVsOfType . tyVarKind) tvs `unionFV` mkFVs tvs++-- | Add the kind variables free in the kinds of the tyvars in the given set.+-- Returns a deterministically ordered list.+closeOverKindsList :: [TyVar] -> [TyVar]+closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs++-- | Add the kind variables free in the kinds of the tyvars in the given set.+-- Returns a deterministic set.+closeOverKindsDSet :: DTyVarSet -> DTyVarSet+closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems++-- | `tyCoFVsOfType` that returns free variables of a type in a deterministic+-- set. For explanation of why using `VarSet` is not deterministic see+-- Note [Deterministic FV] in FV.+tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet+-- See Note [Free variables of types]+tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty++-- | `tyCoFVsOfType` that returns free variables of a type in deterministic+-- order. For explanation of why using `VarSet` is not deterministic see+-- Note [Deterministic FV] in FV.+tyCoVarsOfTypeList :: Type -> [TyCoVar]+-- See Note [Free variables of types]+tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty++-- | Returns free variables of types, including kind variables as+-- a deterministic set. For type synonyms it does /not/ expand the+-- synonym.+tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet+-- See Note [Free variables of types]+tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys++-- | Returns free variables of types, including kind variables as+-- a deterministically ordered list. For type synonyms it does /not/ expand the+-- synonym.+tyCoVarsOfTypesList :: [Type] -> [TyCoVar]+-- See Note [Free variables of types]+tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys++-- | The worker for `tyCoFVsOfType` and `tyCoFVsOfTypeList`.+-- The previous implementation used `unionVarSet` which is O(n+m) and can+-- make the function quadratic.+-- It's exported, so that it can be composed with+-- other functions that compute free variables.+-- See Note [FV naming conventions] in FV.+--+-- Eta-expanded because that makes it run faster (apparently)+-- See Note [FV eta expansion] in FV for explanation.+tyCoFVsOfType :: Type -> FV+-- See Note [Free variables of types]+tyCoFVsOfType (TyVarTy v)        f bound_vars (acc_list, acc_set)+  | not (f v) = (acc_list, acc_set)+  | v `elemVarSet` bound_vars = (acc_list, acc_set)+  | v `elemVarSet` acc_set = (acc_list, acc_set)+  | otherwise = tyCoFVsOfType (tyVarKind v) f+                               emptyVarSet   -- See Note [Closing over free variable kinds]+                               (v:acc_list, extendVarSet acc_set v)+tyCoFVsOfType (TyConApp _ tys)   f bound_vars acc = tyCoFVsOfTypes tys f bound_vars acc+tyCoFVsOfType (LitTy {})         f bound_vars acc = emptyFV f bound_vars acc+tyCoFVsOfType (AppTy fun arg)    f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc+tyCoFVsOfType (FunTy _ arg res)  f bound_vars acc = (tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc+tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty)  f bound_vars acc+tyCoFVsOfType (CastTy ty co)     f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc+tyCoFVsOfType (CoercionTy co)    f bound_vars acc = tyCoFVsOfCo co f bound_vars acc++tyCoFVsBndr :: TyCoVarBinder -> FV -> FV+-- Free vars of (forall b. <thing with fvs>)+tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs++tyCoFVsVarBndrs :: [Var] -> FV -> FV+tyCoFVsVarBndrs vars fvs = foldr tyCoFVsVarBndr fvs vars++tyCoFVsVarBndr :: Var -> FV -> FV+tyCoFVsVarBndr var fvs+  = tyCoFVsOfType (varType var)   -- Free vars of its type/kind+    `unionFV` delFV var fvs       -- Delete it from the thing-inside++tyCoFVsOfTypes :: [Type] -> FV+-- See Note [Free variables of types]+tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc+tyCoFVsOfTypes []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc++-- | Get a deterministic set of the vars free in a coercion+tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet+-- See Note [Free variables of types]+tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co++tyCoVarsOfCoList :: Coercion -> [TyCoVar]+-- See Note [Free variables of types]+tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co++tyCoFVsOfMCo :: MCoercion -> FV+tyCoFVsOfMCo MRefl    = emptyFV+tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co++tyCoFVsOfCo :: Coercion -> FV+-- Extracts type and coercion variables from a coercion+-- See Note [Free variables of types]+tyCoFVsOfCo (Refl ty) fv_cand in_scope acc+  = tyCoFVsOfType ty fv_cand in_scope acc+tyCoFVsOfCo (GRefl _ ty mco) fv_cand in_scope acc+  = (tyCoFVsOfType ty `unionFV` tyCoFVsOfMCo mco) fv_cand in_scope acc+tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc+tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc+  = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc+tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc+  = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc+tyCoFVsOfCo (FunCo _ co1 co2)    fv_cand in_scope acc+  = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc+tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc+  = tyCoFVsOfCoVar v fv_cand in_scope acc+tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc+  = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc+    -- See Note [CoercionHoles and coercion free variables]+tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc+tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc+  = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1+                     `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc+tyCoFVsOfCo (SymCo co)          fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfCo (TransCo co1 co2)   fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc+tyCoFVsOfCo (NthCo _ _ co)      fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfCo (LRCo _ co)         fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfCo (InstCo co arg)     fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc+tyCoFVsOfCo (KindCo co)         fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfCo (SubCo co)          fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfCo (AxiomRuleCo _ cs)  fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc++tyCoFVsOfCoVar :: CoVar -> FV+tyCoFVsOfCoVar v fv_cand in_scope acc+  = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc++tyCoFVsOfProv :: UnivCoProvenance -> FV+tyCoFVsOfProv (PhantomProv co)    fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfProv (PluginProv _)      fv_cand in_scope acc = emptyFV fv_cand in_scope acc++tyCoFVsOfCos :: [Coercion] -> FV+tyCoFVsOfCos []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc+tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc+++----- Whether a covar is /Almost Devoid/ in a type or coercion ----++-- | Given a covar and a coercion, returns True if covar is almost devoid in+-- the coercion. That is, covar can only appear in Refl and GRefl.+-- See last wrinkle in Note [Unused coercion variable in ForAllCo] in GHC.Core.Coercion+almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool+almostDevoidCoVarOfCo cv co =+  almost_devoid_co_var_of_co co cv++almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool+almost_devoid_co_var_of_co (Refl {}) _ = True   -- covar is allowed in Refl and+almost_devoid_co_var_of_co (GRefl {}) _ = True  -- GRefl, so we don't look into+                                                -- the coercions+almost_devoid_co_var_of_co (TyConAppCo _ _ cos) cv+  = almost_devoid_co_var_of_cos cos cv+almost_devoid_co_var_of_co (AppCo co arg) cv+  = almost_devoid_co_var_of_co co cv+  && almost_devoid_co_var_of_co arg cv+almost_devoid_co_var_of_co (ForAllCo v kind_co co) cv+  = almost_devoid_co_var_of_co kind_co cv+  && (v == cv || almost_devoid_co_var_of_co co cv)+almost_devoid_co_var_of_co (FunCo _ co1 co2) cv+  = almost_devoid_co_var_of_co co1 cv+  && almost_devoid_co_var_of_co co2 cv+almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv+almost_devoid_co_var_of_co (HoleCo h)  cv = (coHoleCoVar h) /= cv+almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv+  = almost_devoid_co_var_of_cos cos cv+almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv+  = almost_devoid_co_var_of_prov p cv+  && almost_devoid_co_var_of_type t1 cv+  && almost_devoid_co_var_of_type t2 cv+almost_devoid_co_var_of_co (SymCo co) cv+  = almost_devoid_co_var_of_co co cv+almost_devoid_co_var_of_co (TransCo co1 co2) cv+  = almost_devoid_co_var_of_co co1 cv+  && almost_devoid_co_var_of_co co2 cv+almost_devoid_co_var_of_co (NthCo _ _ co) cv+  = almost_devoid_co_var_of_co co cv+almost_devoid_co_var_of_co (LRCo _ co) cv+  = almost_devoid_co_var_of_co co cv+almost_devoid_co_var_of_co (InstCo co arg) cv+  = almost_devoid_co_var_of_co co cv+  && almost_devoid_co_var_of_co arg cv+almost_devoid_co_var_of_co (KindCo co) cv+  = almost_devoid_co_var_of_co co cv+almost_devoid_co_var_of_co (SubCo co) cv+  = almost_devoid_co_var_of_co co cv+almost_devoid_co_var_of_co (AxiomRuleCo _ cs) cv+  = almost_devoid_co_var_of_cos cs cv++almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool+almost_devoid_co_var_of_cos [] _ = True+almost_devoid_co_var_of_cos (co:cos) cv+  = almost_devoid_co_var_of_co co cv+  && almost_devoid_co_var_of_cos cos cv++almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool+almost_devoid_co_var_of_prov (PhantomProv co) cv+  = almost_devoid_co_var_of_co co cv+almost_devoid_co_var_of_prov (ProofIrrelProv co) cv+  = almost_devoid_co_var_of_co co cv+almost_devoid_co_var_of_prov (PluginProv _) _ = True++almost_devoid_co_var_of_type :: Type -> CoVar -> Bool+almost_devoid_co_var_of_type (TyVarTy _) _ = True+almost_devoid_co_var_of_type (TyConApp _ tys) cv+  = almost_devoid_co_var_of_types tys cv+almost_devoid_co_var_of_type (LitTy {}) _ = True+almost_devoid_co_var_of_type (AppTy fun arg) cv+  = almost_devoid_co_var_of_type fun cv+  && almost_devoid_co_var_of_type arg cv+almost_devoid_co_var_of_type (FunTy _ arg res) cv+  = almost_devoid_co_var_of_type arg cv+  && almost_devoid_co_var_of_type res cv+almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv+  = almost_devoid_co_var_of_type (varType v) cv+  && (v == cv || almost_devoid_co_var_of_type ty cv)+almost_devoid_co_var_of_type (CastTy ty co) cv+  = almost_devoid_co_var_of_type ty cv+  && almost_devoid_co_var_of_co co cv+almost_devoid_co_var_of_type (CoercionTy co) cv+  = almost_devoid_co_var_of_co co cv++almost_devoid_co_var_of_types :: [Type] -> CoVar -> Bool+almost_devoid_co_var_of_types [] _ = True+almost_devoid_co_var_of_types (ty:tys) cv+  = almost_devoid_co_var_of_type ty cv+  && almost_devoid_co_var_of_types tys cv++++{- *********************************************************************+*                                                                      *+                 Injective free vars+*                                                                      *+********************************************************************* -}++-- | Returns the free variables of a 'Type' that are in injective positions.+-- Specifically, it finds the free variables while:+--+-- * Expanding type synonyms+--+-- * Ignoring the coercion in @(ty |> co)@+--+-- * Ignoring the non-injective fields of a 'TyConApp'+--+--+-- For example, if @F@ is a non-injective type family, then:+--+-- @+-- injectiveTyVarsOf( Either c (Maybe (a, F b c)) ) = {a,c}+-- @+--+-- If @'injectiveVarsOfType' ty = itvs@, then knowing @ty@ fixes @itvs@.+-- More formally, if+-- @a@ is in @'injectiveVarsOfType' ty@+-- and  @S1(ty) ~ S2(ty)@,+-- then @S1(a)  ~ S2(a)@,+-- where @S1@ and @S2@ are arbitrary substitutions.+--+-- See @Note [When does a tycon application need an explicit kind signature?]@.+injectiveVarsOfType :: Bool   -- ^ Should we look under injective type families?+                              -- See Note [Coverage condition for injective type families]+                              -- in FamInst.+                    -> Type -> FV+injectiveVarsOfType look_under_tfs = go+  where+    go ty                 | Just ty' <- coreView ty+                          = go ty'+    go (TyVarTy v)        = unitFV v `unionFV` go (tyVarKind v)+    go (AppTy f a)        = go f `unionFV` go a+    go (FunTy _ ty1 ty2)  = go ty1 `unionFV` go ty2+    go (TyConApp tc tys)  =+      case tyConInjectivityInfo tc of+        Injective inj+          |  look_under_tfs || not (isTypeFamilyTyCon tc)+          -> mapUnionFV go $+             filterByList (inj ++ repeat True) tys+                         -- Oversaturated arguments to a tycon are+                         -- always injective, hence the repeat True+        _ -> emptyFV+    go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `unionFV` delFV tv (go ty)+    go LitTy{}                   = emptyFV+    go (CastTy ty _)             = go ty+    go CoercionTy{}              = emptyFV++-- | Returns the free variables of a 'Type' that are in injective positions.+-- Specifically, it finds the free variables while:+--+-- * Expanding type synonyms+--+-- * Ignoring the coercion in @(ty |> co)@+--+-- * Ignoring the non-injective fields of a 'TyConApp'+--+-- See @Note [When does a tycon application need an explicit kind signature?]@.+injectiveVarsOfTypes :: Bool -- ^ look under injective type families?+                             -- See Note [Coverage condition for injective type families]+                             -- in FamInst.+                     -> [Type] -> FV+injectiveVarsOfTypes look_under_tfs = mapUnionFV (injectiveVarsOfType look_under_tfs)+++{- *********************************************************************+*                                                                      *+                 Invisible vars+*                                                                      *+********************************************************************* -}+++-- | Returns the set of variables that are used invisibly anywhere within+-- the given type. A variable will be included even if it is used both visibly+-- and invisibly. An invisible use site includes:+--   * In the kind of a variable+--   * In the kind of a bound variable in a forall+--   * In a coercion+--   * In a Specified or Inferred argument to a function+-- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep+invisibleVarsOfType :: Type -> FV+invisibleVarsOfType = go+  where+    go ty                 | Just ty' <- coreView ty+                          = go ty'+    go (TyVarTy v)        = go (tyVarKind v)+    go (AppTy f a)        = go f `unionFV` go a+    go (FunTy _ ty1 ty2)  = go ty1 `unionFV` go ty2+    go (TyConApp tc tys)  = tyCoFVsOfTypes invisibles `unionFV`+                            invisibleVarsOfTypes visibles+      where (invisibles, visibles) = partitionInvisibleTypes tc tys+    go (ForAllTy tvb ty)  = tyCoFVsBndr tvb $ go ty+    go LitTy{}            = emptyFV+    go (CastTy ty co)     = tyCoFVsOfCo co `unionFV` go ty+    go (CoercionTy co)    = tyCoFVsOfCo co++-- | Like 'invisibleVarsOfType', but for many types.+invisibleVarsOfTypes :: [Type] -> FV+invisibleVarsOfTypes = mapUnionFV invisibleVarsOfType+++{- *********************************************************************+*                                                                      *+                 No free vars+*                                                                      *+********************************************************************* -}++nfvFolder :: TyCoFolder TyCoVarSet DM.All+nfvFolder = TyCoFolder { tcf_view = noView+                       , tcf_tyvar = do_tcv, tcf_covar = do_tcv+                       , tcf_hole = do_hole, tcf_tycobinder = do_bndr }+  where+    do_tcv is tv = All (tv `elemVarSet` is)+    do_hole _ _  = All True    -- I'm unsure; probably never happens+    do_bndr is tv _ = is `extendVarSet` tv++nfv_ty  :: Type       -> DM.All+nfv_tys :: [Type]     -> DM.All+nfv_co  :: Coercion   -> DM.All+(nfv_ty, nfv_tys, nfv_co, _) = foldTyCo nfvFolder emptyVarSet++noFreeVarsOfType :: Type -> Bool+noFreeVarsOfType ty = DM.getAll (nfv_ty ty)++noFreeVarsOfTypes :: [Type] -> Bool+noFreeVarsOfTypes tys = DM.getAll (nfv_tys tys)++noFreeVarsOfCo :: Coercion -> Bool+noFreeVarsOfCo co = getAll (nfv_co co)+++{- *********************************************************************+*                                                                      *+                 scopedSort+*                                                                      *+********************************************************************* -}++{- Note [ScopedSort]+~~~~~~~~~~~~~~~~~~~~+Consider++  foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> ()++This function type is implicitly generalised over [a, b, k, k2]. These+variables will be Specified; that is, they will be available for visible+type application. This is because they are written in the type signature+by the user.++However, we must ask: what order will they appear in? In cases without+dependency, this is easy: we just use the lexical left-to-right ordering+of first occurrence. With dependency, we cannot get off the hook so+easily.++We thus state:++ * These variables appear in the order as given by ScopedSort, where+   the input to ScopedSort is the left-to-right order of first occurrence.++Note that this applies only to *implicit* quantification, without a+`forall`. If the user writes a `forall`, then we just use the order given.++ScopedSort is defined thusly (as proposed in #15743):+  * Work left-to-right through the input list, with a cursor.+  * If variable v at the cursor is depended on by any earlier variable w,+    move v immediately before the leftmost such w.++INVARIANT: The prefix of variables before the cursor form a valid telescope.++Note that ScopedSort makes sense only after type inference is done and all+types/kinds are fully settled and zonked.++-}++-- | Do a topological sort on a list of tyvars,+--   so that binders occur before occurrences+-- E.g. given  [ a::k, k::*, b::k ]+-- it'll return a well-scoped list [ k::*, a::k, b::k ]+--+-- This is a deterministic sorting operation+-- (that is, doesn't depend on Uniques).+--+-- It is also meant to be stable: that is, variables should not+-- be reordered unnecessarily. This is specified in Note [ScopedSort]+-- See also Note [Ordering of implicit variables] in GHC.Rename.Types++scopedSort :: [TyCoVar] -> [TyCoVar]+scopedSort = go [] []+  where+    go :: [TyCoVar] -- already sorted, in reverse order+       -> [TyCoVarSet] -- each set contains all the variables which must be placed+                       -- before the tv corresponding to the set; they are accumulations+                       -- of the fvs in the sorted tvs' kinds++                       -- This list is in 1-to-1 correspondence with the sorted tyvars+                       -- INVARIANT:+                       --   all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list)+                       -- That is, each set in the list is a superset of all later sets.++       -> [TyCoVar] -- yet to be sorted+       -> [TyCoVar]+    go acc _fv_list [] = reverse acc+    go acc  fv_list (tv:tvs)+      = go acc' fv_list' tvs+      where+        (acc', fv_list') = insert tv acc fv_list++    insert :: TyCoVar       -- var to insert+           -> [TyCoVar]     -- sorted list, in reverse order+           -> [TyCoVarSet]  -- list of fvs, as above+           -> ([TyCoVar], [TyCoVarSet])   -- augmented lists+    insert tv []     []         = ([tv], [tyCoVarsOfType (tyVarKind tv)])+    insert tv (a:as) (fvs:fvss)+      | tv `elemVarSet` fvs+      , (as', fvss') <- insert tv as fvss+      = (a:as', fvs `unionVarSet` fv_tv : fvss')++      | otherwise+      = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss)+      where+        fv_tv = tyCoVarsOfType (tyVarKind tv)++       -- lists not in correspondence+    insert _ _ _ = panic "scopedSort"++-- | Get the free vars of a type in scoped order+tyCoVarsOfTypeWellScoped :: Type -> [TyVar]+tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList++-- | Get the free vars of types in scoped order+tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]+tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList+
+ compiler/GHC/Core/TyCo/Ppr.hs view
@@ -0,0 +1,341 @@+-- | Pretty-printing types and coercions.+module GHC.Core.TyCo.Ppr+  (+        -- * Precedence+        PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,++        -- * Pretty-printing types+        pprType, pprParendType, pprTidiedType, pprPrecType, pprPrecTypeX,+        pprTypeApp, pprTCvBndr, pprTCvBndrs,+        pprSigmaType,+        pprTheta, pprParendTheta, pprForAll, pprUserForAll,+        pprTyVar, pprTyVars,+        pprThetaArrowTy, pprClassPred,+        pprKind, pprParendKind, pprTyLit,+        pprDataCons, pprWithExplicitKindsWhen,+        pprWithTYPE, pprSourceTyCon,+++        -- * Pretty-printing coercions+        pprCo, pprParendCo,++        debugPprType,++        -- * Pretty-printing 'TyThing's+        pprTyThingCategory, pprShortTyThing,+  ) where++import GhcPrelude++import {-# SOURCE #-} GHC.CoreToIface+   ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr+   , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX )++import {-# SOURCE #-} GHC.Core.DataCon+   ( dataConFullSig , dataConUserTyVarBinders+   , DataCon )++import {-# SOURCE #-} GHC.Core.Type+   ( isLiftedTypeKind )++import GHC.Core.TyCon+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Tidy+import GHC.Core.TyCo.FVs+import GHC.Core.Class+import GHC.Types.Var++import GHC.Iface.Type++import GHC.Types.Var.Set+import GHC.Types.Var.Env++import Outputable+import GHC.Types.Basic ( PprPrec(..), topPrec, sigPrec, opPrec+                       , funPrec, appPrec, maybeParen )++{-+%************************************************************************+%*                                                                      *+                   Pretty-printing types++       Defined very early because of debug printing in assertions+%*                                                                      *+%************************************************************************++@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is+defined to use this.  @pprParendType@ is the same, except it puts+parens around the type, except for the atomic cases.  @pprParendType@+works just by setting the initial context precedence very high.++Note that any function which pretty-prints a @Type@ first converts the @Type@+to an @IfaceType@. See Note [IfaceType and pretty-printing] in GHC.Iface.Type.++See Note [Precedence in types] in GHC.Types.Basic.+-}++--------------------------------------------------------+-- When pretty-printing types, we convert to IfaceType,+--   and pretty-print that.+-- See Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing+--------------------------------------------------------++pprType, pprParendType, pprTidiedType :: Type -> SDoc+pprType       = pprPrecType topPrec+pprParendType = pprPrecType appPrec++-- already pre-tidied+pprTidiedType = pprIfaceType . toIfaceTypeX emptyVarSet++pprPrecType :: PprPrec -> Type -> SDoc+pprPrecType = pprPrecTypeX emptyTidyEnv++pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc+pprPrecTypeX env prec ty+  = getPprStyle $ \sty ->+    if debugStyle sty           -- Use debugPprType when in+    then debug_ppr_ty prec ty   -- when in debug-style+    else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty)+    -- NB: debug-style is used for -dppr-debug+    --     dump-style  is used for -ddump-tc-trace etc++pprTyLit :: TyLit -> SDoc+pprTyLit = pprIfaceTyLit . toIfaceTyLit++pprKind, pprParendKind :: Kind -> SDoc+pprKind       = pprType+pprParendKind = pprParendType++tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType+tidyToIfaceTypeStyX env ty sty+  | userStyle sty = tidyToIfaceTypeX env ty+  | otherwise     = toIfaceTypeX (tyCoVarsOfType ty) ty+     -- in latter case, don't tidy, as we'll be printing uniques.++tidyToIfaceType :: Type -> IfaceType+tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv++tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType+-- It's vital to tidy before converting to an IfaceType+-- or nested binders will become indistinguishable!+--+-- Also for the free type variables, tell toIfaceTypeX to+-- leave them as IfaceFreeTyVar.  This is super-important+-- for debug printing.+tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty)+  where+    env'      = tidyFreeTyCoVars env free_tcvs+    free_tcvs = tyCoVarsOfTypeWellScoped ty++------------+pprCo, pprParendCo :: Coercion -> SDoc+pprCo       co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty)+pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty)++tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion+tidyToIfaceCoSty co sty+  | userStyle sty = tidyToIfaceCo co+  | otherwise     = toIfaceCoercionX (tyCoVarsOfCo co) co+     -- in latter case, don't tidy, as we'll be printing uniques.++tidyToIfaceCo :: Coercion -> IfaceCoercion+-- It's vital to tidy before converting to an IfaceType+-- or nested binders will become indistinguishable!+--+-- Also for the free type variables, tell toIfaceCoercionX to+-- leave them as IfaceFreeCoVar.  This is super-important+-- for debug printing.+tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co)+  where+    env       = tidyFreeTyCoVars emptyTidyEnv free_tcvs+    free_tcvs = scopedSort $ tyCoVarsOfCoList co+------------+pprClassPred :: Class -> [Type] -> SDoc+pprClassPred clas tys = pprTypeApp (classTyCon clas) tys++------------+pprTheta :: ThetaType -> SDoc+pprTheta = pprIfaceContext topPrec . map tidyToIfaceType++pprParendTheta :: ThetaType -> SDoc+pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType++pprThetaArrowTy :: ThetaType -> SDoc+pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType++------------------+pprSigmaType :: Type -> SDoc+pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType++pprForAll :: [TyCoVarBinder] -> SDoc+pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs)++-- | Print a user-level forall; see Note [When to print foralls] in this module.+pprUserForAll :: [TyCoVarBinder] -> SDoc+pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr++pprTCvBndrs :: [TyCoVarBinder] -> SDoc+pprTCvBndrs tvs = sep (map pprTCvBndr tvs)++pprTCvBndr :: TyCoVarBinder -> SDoc+pprTCvBndr = pprTyVar . binderVar++pprTyVars :: [TyVar] -> SDoc+pprTyVars tvs = sep (map pprTyVar tvs)++pprTyVar :: TyVar -> SDoc+-- Print a type variable binder with its kind (but not if *)+-- Here we do not go via IfaceType, because the duplication with+-- pprIfaceTvBndr is minimal, and the loss of uniques etc in+-- debug printing is disastrous+pprTyVar tv+  | isLiftedTypeKind kind = ppr tv+  | otherwise             = parens (ppr tv <+> dcolon <+> ppr kind)+  where+    kind = tyVarKind tv++-----------------+debugPprType :: Type -> SDoc+-- ^ debugPprType is a simple pretty printer that prints a type+-- without going through IfaceType.  It does not format as prettily+-- as the normal route, but it's much more direct, and that can+-- be useful for debugging.  E.g. with -dppr-debug it prints the+-- kind on type-variable /occurrences/ which the normal route+-- fundamentally cannot do.+debugPprType ty = debug_ppr_ty topPrec ty++debug_ppr_ty :: PprPrec -> Type -> SDoc+debug_ppr_ty _ (LitTy l)+  = ppr l++debug_ppr_ty _ (TyVarTy tv)+  = ppr tv  -- With -dppr-debug we get (tv :: kind)++debug_ppr_ty prec (FunTy { ft_af = af, ft_arg = arg, ft_res = res })+  = maybeParen prec funPrec $+    sep [debug_ppr_ty funPrec arg, arrow <+> debug_ppr_ty prec res]+  where+    arrow = case af of+              VisArg   -> text "->"+              InvisArg -> text "=>"++debug_ppr_ty prec (TyConApp tc tys)+  | null tys  = ppr tc+  | otherwise = maybeParen prec appPrec $+                hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys))++debug_ppr_ty _ (AppTy t1 t2)+  = hang (debug_ppr_ty appPrec t1)  -- Print parens so we see ((a b) c)+       2 (debug_ppr_ty appPrec t2)  -- so that we can distinguish+                                    -- TyConApp from AppTy++debug_ppr_ty prec (CastTy ty co)+  = maybeParen prec topPrec $+    hang (debug_ppr_ty topPrec ty)+       2 (text "|>" <+> ppr co)++debug_ppr_ty _ (CoercionTy co)+  = parens (text "CO" <+> ppr co)++debug_ppr_ty prec ty@(ForAllTy {})+  | (tvs, body) <- split ty+  = maybeParen prec funPrec $+    hang (text "forall" <+> fsep (map ppr tvs) <> dot)+         -- The (map ppr tvs) will print kind-annotated+         -- tvs, because we are (usually) in debug-style+       2 (ppr body)+  where+    split ty | ForAllTy tv ty' <- ty+             , (tvs, body) <- split ty'+             = (tv:tvs, body)+             | otherwise+             = ([], ty)++{-+Note [When to print foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Mostly we want to print top-level foralls when (and only when) the user specifies+-fprint-explicit-foralls.  But when kind polymorphism is at work, that suppresses+too much information; see #9018.++So I'm trying out this rule: print explicit foralls if+  a) User specifies -fprint-explicit-foralls, or+  b) Any of the quantified type variables has a kind+     that mentions a kind variable++This catches common situations, such as a type siguature+     f :: m a+which means+      f :: forall k. forall (m :: k->*) (a :: k). m a+We really want to see both the "forall k" and the kind signatures+on m and a.  The latter comes from pprTCvBndr.++Note [Infix type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+With TypeOperators you can say++   f :: (a ~> b) -> b++and the (~>) is considered a type variable.  However, the type+pretty-printer in this module will just see (a ~> b) as++   App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b")++So it'll print the type in prefix form.  To avoid confusion we must+remember to parenthesise the operator, thus++   (~>) a b -> b++See #2766.+-}++pprDataCons :: TyCon -> SDoc+pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons+  where+    sepWithVBars [] = empty+    sepWithVBars docs = sep (punctuate (space <> vbar) docs)++pprDataConWithArgs :: DataCon -> SDoc+pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]+  where+    (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc+    user_bndrs = dataConUserTyVarBinders dc+    forAllDoc  = pprUserForAll user_bndrs+    thetaDoc   = pprThetaArrowTy theta+    argsDoc    = hsep (fmap pprParendType arg_tys)+++pprTypeApp :: TyCon -> [Type] -> SDoc+pprTypeApp tc tys+  = pprIfaceTypeApp topPrec (toIfaceTyCon tc)+                            (toIfaceTcArgs tc tys)+    -- TODO: toIfaceTcArgs seems rather wasteful here++------------------+-- | Display all kind information (with @-fprint-explicit-kinds@) when the+-- provided 'Bool' argument is 'True'.+-- See @Note [Kind arguments in error messages]@ in TcErrors.+pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc+pprWithExplicitKindsWhen b+  = updSDocContext $ \ctx ->+      if b then ctx { sdocPrintExplicitKinds = True }+           else ctx++-- | This variant preserves any use of TYPE in a type, effectively+-- locally setting -fprint-explicit-runtime-reps.+pprWithTYPE :: Type -> SDoc+pprWithTYPE ty = updSDocContext (\ctx -> ctx { sdocPrintExplicitRuntimeReps = True }) $+                 ppr ty++-- | Pretty prints a 'TyCon', using the family instance in case of a+-- representation tycon.  For example:+--+-- > data T [a] = ...+--+-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon'+pprSourceTyCon :: TyCon -> SDoc+pprSourceTyCon tycon+  | Just (fam_tc, tys) <- tyConFamInst_maybe tycon+  = ppr $ fam_tc `TyConApp` tys        -- can't be FunTyCon+  | otherwise+  = ppr tycon
+ compiler/GHC/Core/TyCo/Ppr.hs-boot view
@@ -0,0 +1,10 @@+module GHC.Core.TyCo.Ppr where++import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, Coercion, TyLit)+import Outputable++pprType :: Type -> SDoc+pprKind :: Kind -> SDoc+pprCo :: Coercion -> SDoc+pprTyLit :: TyLit -> SDoc+
+ compiler/GHC/Core/TyCo/Rep.hs view
@@ -0,0 +1,1910 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998+\section[GHC.Core.TyCo.Rep]{Type and Coercion - friends' interface}++Note [The Type-related module hierarchy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  GHC.Core.Class+  GHC.Core.Coercion.Axiom+  GHC.Core.TyCon      imports GHC.Core.{Class, Coercion.Axiom}+  GHC.Core.TyCo.Rep   imports GHC.Core.{Class, Coercion.Axiom, TyCon}+  GHC.Core.TyCo.Ppr   imports GHC.Core.TyCo.Rep+  GHC.Core.TyCo.FVs   imports GHC.Core.TyCo.Rep+  GHC.Core.TyCo.Subst imports GHC.Core.TyCo.{Rep, FVs, Ppr}+  GHC.Core.TyCo.Tidy  imports GHC.Core.TyCo.{Rep, FVs}+  TysPrim             imports GHC.Core.TyCo.Rep ( including mkTyConTy )+  GHC.Core.Coercion   imports GHC.Core.Type+-}++-- We expose the relevant stuff from this module via the Type module+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf, PatternSynonyms, BangPatterns #-}++module GHC.Core.TyCo.Rep (+        TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing,++        -- * Types+        Type( TyVarTy, AppTy, TyConApp, ForAllTy+            , LitTy, CastTy, CoercionTy+            , FunTy, ft_arg, ft_res, ft_af+            ),  -- Export the type synonym FunTy too++        TyLit(..),+        KindOrType, Kind,+        KnotTied,+        PredType, ThetaType,      -- Synonyms+        ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..),++        -- * Coercions+        Coercion(..),+        UnivCoProvenance(..),+        CoercionHole(..), BlockSubstFlag(..), coHoleCoVar, setCoHoleCoVar,+        CoercionN, CoercionR, CoercionP, KindCoercion,+        MCoercion(..), MCoercionR, MCoercionN,++        -- * Functions over types+        mkTyConTy, mkTyVarTy, mkTyVarTys,+        mkTyCoVarTy, mkTyCoVarTys,+        mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys,+        mkForAllTy, mkForAllTys,+        mkPiTy, mkPiTys,++        -- * Functions over binders+        TyCoBinder(..), TyCoVarBinder, TyBinder,+        binderVar, binderVars, binderType, binderArgFlag,+        delBinderVar,+        isInvisibleArgFlag, isVisibleArgFlag,+        isInvisibleBinder, isVisibleBinder,+        isTyBinder, isNamedBinder,++        -- * Functions over coercions+        pickLR,++        -- ** Analyzing types+        TyCoFolder(..), foldTyCo,++        -- * Sizes+        typeSize, coercionSize, provSize+    ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit )++   -- Transitively pulls in a LOT of stuff, better to break the loop++import {-# SOURCE #-} GHC.Core.ConLike ( ConLike(..), conLikeName )++-- friends:+import GHC.Iface.Type+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Name hiding ( varName )+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom++-- others+import GHC.Types.Basic ( LeftOrRight(..), pickLR )+import Outputable+import FastString+import Util++-- libraries+import qualified Data.Data as Data hiding ( TyCon )+import Data.IORef ( IORef )   -- for CoercionHole++{-+%************************************************************************+%*                                                                      *+                        TyThing+%*                                                                      *+%************************************************************************++Despite the fact that DataCon has to be imported via a hi-boot route,+this module seems the right place for TyThing, because it's needed for+funTyCon and all the types in TysPrim.++It is also SOURCE-imported into Name.hs+++Note [ATyCon for classes]+~~~~~~~~~~~~~~~~~~~~~~~~~+Both classes and type constructors are represented in the type environment+as ATyCon.  You can tell the difference, and get to the class, with+   isClassTyCon :: TyCon -> Bool+   tyConClass_maybe :: TyCon -> Maybe Class+The Class and its associated TyCon have the same Name.+-}++-- | A global typecheckable-thing, essentially anything that has a name.+-- Not to be confused with a 'TcTyThing', which is also a typecheckable+-- thing but in the *local* context.  See 'TcEnv' for how to retrieve+-- a 'TyThing' given a 'Name'.+data TyThing+  = AnId     Id+  | AConLike ConLike+  | ATyCon   TyCon       -- TyCons and classes; see Note [ATyCon for classes]+  | ACoAxiom (CoAxiom Branched)++instance Outputable TyThing where+  ppr = pprShortTyThing++instance NamedThing TyThing where       -- Can't put this with the type+  getName (AnId id)     = getName id    -- decl, because the DataCon instance+  getName (ATyCon tc)   = getName tc    -- isn't visible there+  getName (ACoAxiom cc) = getName cc+  getName (AConLike cl) = conLikeName cl++pprShortTyThing :: TyThing -> SDoc+-- c.f. GHC.Core.Ppr.TyThing.pprTyThing, which prints all the details+pprShortTyThing thing+  = pprTyThingCategory thing <+> quotes (ppr (getName thing))++pprTyThingCategory :: TyThing -> SDoc+pprTyThingCategory = text . capitalise . tyThingCategory++tyThingCategory :: TyThing -> String+tyThingCategory (ATyCon tc)+  | isClassTyCon tc = "class"+  | otherwise       = "type constructor"+tyThingCategory (ACoAxiom _) = "coercion axiom"+tyThingCategory (AnId   _)   = "identifier"+tyThingCategory (AConLike (RealDataCon _)) = "data constructor"+tyThingCategory (AConLike (PatSynCon _))  = "pattern synonym"+++{- **********************************************************************+*                                                                       *+                        Type+*                                                                       *+********************************************************************** -}++-- | The key representation of types within the compiler++type KindOrType = Type -- See Note [Arguments to type constructors]++-- | The key type representing kinds in the compiler.+type Kind = Type++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data Type+  -- See Note [Non-trivial definitional equality]+  = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable)++  | AppTy+        Type+        Type            -- ^ Type application to something other than a 'TyCon'. Parameters:+                        --+                        --  1) Function: must /not/ be a 'TyConApp' or 'CastTy',+                        --     must be another 'AppTy', or 'TyVarTy'+                        --     See Note [Respecting definitional equality] (EQ1) about the+                        --     no 'CastTy' requirement+                        --+                        --  2) Argument type++  | TyConApp+        TyCon+        [KindOrType]    -- ^ Application of a 'TyCon', including newtypes /and/ synonyms.+                        -- Invariant: saturated applications of 'FunTyCon' must+                        -- use 'FunTy' and saturated synonyms must use their own+                        -- constructors. However, /unsaturated/ 'FunTyCon's+                        -- do appear as 'TyConApp's.+                        -- Parameters:+                        --+                        -- 1) Type constructor being applied to.+                        --+                        -- 2) Type arguments. Might not have enough type arguments+                        --    here to saturate the constructor.+                        --    Even type synonyms are not necessarily saturated;+                        --    for example unsaturated type synonyms+                        --    can appear as the right hand side of a type synonym.++  | ForAllTy+        {-# UNPACK #-} !TyCoVarBinder+        Type            -- ^ A Π type.+             -- INVARIANT: If the binder is a coercion variable, it must+             -- be mentioned in the Type. See+             -- Note [Unused coercion variable in ForAllTy]++  | FunTy      -- ^ t1 -> t2   Very common, so an important special case+                -- See Note [Function types]+     { ft_af  :: AnonArgFlag  -- Is this (->) or (=>)?+     , ft_arg :: Type           -- Argument type+     , ft_res :: Type }         -- Result type++  | LitTy TyLit     -- ^ Type literals are similar to type constructors.++  | CastTy+        Type+        KindCoercion  -- ^ A kind cast. The coercion is always nominal.+                      -- INVARIANT: The cast is never reflexive+                      -- INVARIANT: The Type is not a CastTy (use TransCo instead)+                      -- INVARIANT: The Type is not a ForAllTy over a type variable+                      -- See Note [Respecting definitional equality] (EQ2), (EQ3), (EQ4)++  | CoercionTy+        Coercion    -- ^ Injection of a Coercion into a type+                    -- This should only ever be used in the RHS of an AppTy,+                    -- in the list of a TyConApp, when applying a promoted+                    -- GADT data constructor++  deriving Data.Data++instance Outputable Type where+  ppr = pprType++-- NOTE:  Other parts of the code assume that type literals do not contain+-- types or type variables.+data TyLit+  = NumTyLit Integer+  | StrTyLit FastString+  deriving (Eq, Ord, Data.Data)++instance Outputable TyLit where+   ppr = pprTyLit++{- Note [Function types]+~~~~~~~~~~~~~~~~~~~~~~~~+FFunTy is the constructor for a function type.  Lots of things to say+about it!++* FFunTy is the data constructor, meaning "full function type".++* The function type constructor (->) has kind+     (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> Type LiftedRep+  mkTyConApp ensure that we convert a saturated application+    TyConApp (->) [r1,r2,t1,t2] into FunTy t1 t2+  dropping the 'r1' and 'r2' arguments; they are easily recovered+  from 't1' and 't2'.++* The ft_af field says whether or not this is an invisible argument+     VisArg:   t1 -> t2    Ordinary function type+     InvisArg: t1 => t2    t1 is guaranteed to be a predicate type,+                           i.e. t1 :: Constraint+  See Note [Types for coercions, predicates, and evidence]++  This visibility info makes no difference in Core; it matters+  only when we regard the type as a Haskell source type.++* FunTy is a (unidirectional) pattern synonym that allows+  positional pattern matching (FunTy arg res), ignoring the+  ArgFlag.+-}++{- -----------------------+      Commented out until the pattern match+      checker can handle it; see #16185++      For now we use the CPP macro #define FunTy FFunTy _+      (see HsVersions.h) to allow pattern matching on a+      (positional) FunTy constructor.++{-# COMPLETE FunTy, TyVarTy, AppTy, TyConApp+           , ForAllTy, LitTy, CastTy, CoercionTy :: Type #-}++-- | 'FunTy' is a (uni-directional) pattern synonym for the common+-- case where we want to match on the argument/result type, but+-- ignoring the AnonArgFlag+pattern FunTy :: Type -> Type -> Type+pattern FunTy arg res <- FFunTy { ft_arg = arg, ft_res = res }++       End of commented out block+---------------------------------- -}++{- Note [Types for coercions, predicates, and evidence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We treat differently:++  (a) Predicate types+        Test: isPredTy+        Binders: DictIds+        Kind: Constraint+        Examples: (Eq a), and (a ~ b)++  (b) Coercion types are primitive, unboxed equalities+        Test: isCoVarTy+        Binders: CoVars (can appear in coercions)+        Kind: TYPE (TupleRep [])+        Examples: (t1 ~# t2) or (t1 ~R# t2)++  (c) Evidence types is the type of evidence manipulated by+      the type constraint solver.+        Test: isEvVarType+        Binders: EvVars+        Kind: Constraint or TYPE (TupleRep [])+        Examples: all coercion types and predicate types++Coercion types and predicate types are mutually exclusive,+but evidence types are a superset of both.++When treated as a user type,++  - Predicates (of kind Constraint) are invisible and are+    implicitly instantiated++  - Coercion types, and non-pred evidence types (i.e. not+    of kind Constrain), are just regular old types, are+    visible, and are not implicitly instantiated.++In a FunTy { ft_af = InvisArg }, the argument type is always+a Predicate type.++Note [Constraints in kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do we allow a type constructor to have a kind like+   S :: Eq a => a -> Type++No, we do not.  Doing so would mean would need a TyConApp like+   S @k @(d :: Eq k) (ty :: k)+ and we have no way to build, or decompose, evidence like+ (d :: Eq k) at the type level.++But we admit one exception: equality.  We /do/ allow, say,+   MkT :: (a ~ b) => a -> b -> Type a b++Why?  Because we can, without much difficulty.  Moreover+we can promote a GADT data constructor (see TyCon+Note [Promoted data constructors]), like+  data GT a b where+    MkGT : a -> a -> GT a a+so programmers might reasonably expect to be able to+promote MkT as well.++How does this work?++* In TcValidity.checkConstraintsOK we reject kinds that+  have constraints other than (a~b) and (a~~b).++* In Inst.tcInstInvisibleTyBinder we instantiate a call+  of MkT by emitting+     [W] co :: alpha ~# beta+  and producing the elaborated term+     MkT @alpha @beta (Eq# alpha beta co)+  We don't generate a boxed "Wanted"; we generate only a+  regular old /unboxed/ primitive-equality Wanted, and build+  the box on the spot.++* How can we get such a MkT?  By promoting a GADT-style data+  constructor+     data T a b where+       MkT :: (a~b) => a -> b -> T a b+  See DataCon.mkPromotedDataCon+  and Note [Promoted data constructors] in GHC.Core.TyCon++* We support both homogeneous (~) and heterogeneous (~~)+  equality.  (See Note [The equality types story]+  in TysPrim for a primer on these equality types.)++* How do we prevent a MkT having an illegal constraint like+  Eq a?  We check for this at use-sites; see TcHsType.tcTyVar,+  specifically dc_theta_illegal_constraint.++* Notice that nothing special happens if+    K :: (a ~# b) => blah+  because (a ~# b) is not a predicate type, and is never+  implicitly instantiated. (Mind you, it's not clear how you+  could creates a type constructor with such a kind.) See+  Note [Types for coercions, predicates, and evidence]++* The existence of promoted MkT with an equality-constraint+  argument is the (only) reason that the AnonTCB constructor+  of TyConBndrVis carries an AnonArgFlag (VisArg/InvisArg).+  For example, when we promote the data constructor+     MkT :: forall a b. (a~b) => a -> b -> T a b+  we get a PromotedDataCon with tyConBinders+      Bndr (a :: Type)  (NamedTCB Inferred)+      Bndr (b :: Type)  (NamedTCB Inferred)+      Bndr (_ :: a ~ b) (AnonTCB InvisArg)+      Bndr (_ :: a)     (AnonTCB VisArg))+      Bndr (_ :: b)     (AnonTCB VisArg))++* One might reasonably wonder who *unpacks* these boxes once they are+  made. After all, there is no type-level `case` construct. The+  surprising answer is that no one ever does. Instead, if a GADT+  constructor is used on the left-hand side of a type family equation,+  that occurrence forces GHC to unify the types in question. For+  example:++  data G a where+    MkG :: G Bool++  type family F (x :: G a) :: a where+    F MkG = False++  When checking the LHS `F MkG`, GHC sees the MkG constructor and then must+  unify F's implicit parameter `a` with Bool. This succeeds, making the equation++    F Bool (MkG @Bool <Bool>) = False++  Note that we never need unpack the coercion. This is because type+  family equations are *not* parametric in their kind variables. That+  is, we could have just said++  type family H (x :: G a) :: a where+    H _ = False++  The presence of False on the RHS also forces `a` to become Bool,+  giving us++    H Bool _ = False++  The fact that any of this works stems from the lack of phase+  separation between types and kinds (unlike the very present phase+  separation between terms and types).++  Once we have the ability to pattern-match on types below top-level,+  this will no longer cut it, but it seems fine for now.+++Note [Arguments to type constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because of kind polymorphism, in addition to type application we now+have kind instantiation. We reuse the same notations to do so.++For example:++  Just (* -> *) Maybe+  Right * Nat Zero++are represented by:++  TyConApp (PromotedDataCon Just) [* -> *, Maybe]+  TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)]++Important note: Nat is used as a *kind* and not as a type. This can be+confusing, since type-level Nat and kind-level Nat are identical. We+use the kind of (PromotedDataCon Right) to know if its arguments are+kinds or types.++This kind instantiation only happens in TyConApp currently.++Note [Non-trivial definitional equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Is Int |> <*> the same as Int? YES! In order to reduce headaches,+we decide that any reflexive casts in types are just ignored.+(Indeed they must be. See Note [Respecting definitional equality].)+More generally, the `eqType` function, which defines Core's type equality+relation, ignores casts and coercion arguments, as long as the+two types have the same kind. This allows us to be a little sloppier+in keeping track of coercions, which is a good thing. It also means+that eqType does not depend on eqCoercion, which is also a good thing.++Why is this sensible? That is, why is something different than α-equivalence+appropriate for the implementation of eqType?++Anything smaller than ~ and homogeneous is an appropriate definition for+equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any+expression of type τ can be transmuted to one of type σ at any point by+casting. The same is true of expressions of type σ. So in some sense, τ and σ+are interchangeable.++But let's be more precise. If we examine the typing rules of FC (say, those in+https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf)+there are several places where the same metavariable is used in two different+premises to a rule. (For example, see Ty_App.) There is an implicit equality+check here. What definition of equality should we use? By convention, we use+α-equivalence. Take any rule with one (or more) of these implicit equality+checks. Then there is an admissible rule that uses ~ instead of the implicit+check, adding in casts as appropriate.++The only problem here is that ~ is heterogeneous. To make the kinds work out+in the admissible rule that uses ~, it is necessary to homogenize the+coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η;+we use η |> kind η, which is homogeneous.++The effect of this all is that eqType, the implementation of the implicit+equality check, can use any homogeneous relation that is smaller than ~, as+those rules must also be admissible.++A more drawn out argument around all of this is presented in Section 7.2 of+Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf).++What would go wrong if we insisted on the casts matching? See the beginning of+Section 8 in the unpublished paper above. Theoretically, nothing at all goes+wrong. But in practical terms, getting the coercions right proved to be+nightmarish. And types would explode: during kind-checking, we often produce+reflexive kind coercions. When we try to cast by these, mkCastTy just discards+them. But if we used an eqType that distinguished between Int and Int |> <*>,+then we couldn't discard -- the output of kind-checking would be enormous,+and we would need enormous casts with lots of CoherenceCo's to straighten+them out.++Would anything go wrong if eqType respected type families? No, not at all. But+that makes eqType rather hard to implement.++Thus, the guideline for eqType is that it should be the largest+easy-to-implement relation that is still smaller than ~ and homogeneous. The+precise choice of relation is somewhat incidental, as long as the smart+constructors and destructors in Type respect whatever relation is chosen.++Another helpful principle with eqType is this:++ (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere.++This principle also tells us that eqType must relate only types with the+same kinds.++Note [Respecting definitional equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Non-trivial definitional equality] introduces the property (EQ).+How is this upheld?++Any function that pattern matches on all the constructors will have to+consider the possibility of CastTy. Presumably, those functions will handle+CastTy appropriately and we'll be OK.++More dangerous are the splitXXX functions. Let's focus on splitTyConApp.+We don't want it to fail on (T a b c |> co). Happily, if we have+  (T a b c |> co) `eqType` (T d e f)+then co must be reflexive. Why? eqType checks that the kinds are equal, as+well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f).+By the kind check, we know that (T a b c |> co) and (T d e f) have the same+kind. So the only way that co could be non-reflexive is for (T a b c) to have+a different kind than (T d e f). But because T's kind is closed (all tycon kinds+are closed), the only way for this to happen is that one of the arguments has+to differ, leading to a contradiction. Thus, co is reflexive.++Accordingly, by eliminating reflexive casts, splitTyConApp need not worry+about outermost casts to uphold (EQ). Eliminating reflexive casts is done+in mkCastTy.++Unforunately, that's not the end of the story. Consider comparing+  (T a b c)      =?       (T a b |> (co -> <Type>)) (c |> co)+These two types have the same kind (Type), but the left type is a TyConApp+while the right type is not. To handle this case, we say that the right-hand+type is ill-formed, requiring an AppTy never to have a casted TyConApp+on its left. It is easy enough to pull around the coercions to maintain+this invariant, as done in Type.mkAppTy. In the example above, trying to+form the right-hand type will instead yield (T a b (c |> co |> sym co) |> <Type>).+Both the casts there are reflexive and will be dropped. Huzzah.++This idea of pulling coercions to the right works for splitAppTy as well.++However, there is one hiccup: it's possible that a coercion doesn't relate two+Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@,+then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't+be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not+`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate+our (EQ) property.++In order to detect reflexive casts reliably, we must make sure not+to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)).++One other troublesome case is ForAllTy. See Note [Weird typing rule for ForAllTy].+The kind of the body is the same as the kind of the ForAllTy. Accordingly,++  ForAllTy tv (ty |> co)     and     (ForAllTy tv ty) |> co++are `eqType`. But only the first can be split by splitForAllTy. So we forbid+the second form, instead pushing the coercion inside to get the first form.+This is done in mkCastTy.++In sum, in order to uphold (EQ), we need the following invariants:++  (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable+        cast is one that relates either a FunTy to a FunTy or a+        ForAllTy to a ForAllTy.+  (EQ2) No reflexive casts in CastTy.+  (EQ3) No nested CastTys.+  (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body).+        See Note [Weird typing rule for ForAllTy]++These invariants are all documented above, in the declaration for Type.++Note [Unused coercion variable in ForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  \(co:t1 ~ t2). e++What type should we give to this expression?+  (1) forall (co:t1 ~ t2) -> t+  (2) (t1 ~ t2) -> t++If co is used in t, (1) should be the right choice.+if co is not used in t, we would like to have (1) and (2) equivalent.++However, we want to keep eqType simple and don't want eqType (1) (2) to return+True in any case.++We decide to always construct (2) if co is not used in t.++Thus in mkLamType, we check whether the variable is a coercion+variable (of type (t1 ~# t2), and whether it is un-used in the+body. If so, it returns a FunTy instead of a ForAllTy.++There are cases we want to skip the check. For example, the check is+unnecessary when it is known from the context that the input variable+is a type variable.  In those cases, we use mkForAllTy.++Note [Weird typing rule for ForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is the (truncated) typing rule for the dependent ForAllTy:++  inner : TYPE r+  tyvar is not free in r+  ----------------------------------------+  ForAllTy (Bndr tyvar vis) inner : TYPE r++Note that the kind of `inner` is the kind of the overall ForAllTy. This is+necessary because every ForAllTy over a type variable is erased at runtime.+Thus the runtime representation of a ForAllTy (as encoded, via TYPE rep, in+the kind) must be the same as the representation of the body. We must check+for skolem-escape, though. The skolem-escape would prevent a definition like++  undefined :: forall (r :: RuntimeRep) (a :: TYPE r). a++because the type's kind (TYPE r) mentions the out-of-scope r. Luckily, the real+type of undefined is++  undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a++and that HasCallStack constraint neatly sidesteps the potential skolem-escape+problem.++If the bound variable is a coercion variable:++  inner : TYPE r+  covar is free in inner+  ------------------------------------+  ForAllTy (Bndr covar vis) inner : Type++Here, the kind of the ForAllTy is just Type, because coercion abstractions+are *not* erased. The "covar is free in inner" premise is solely to maintain+the representation invariant documented in+Note [Unused coercion variable in ForAllTy]. Though there is surface similarity+between this free-var check and the one in the tyvar rule, these two restrictions+are truly unrelated.++-}++-- | A type labeled 'KnotTied' might have knot-tied tycons in it. See+-- Note [Type checking recursive type and class declarations] in+-- TcTyClsDecls+type KnotTied ty = ty++{- **********************************************************************+*                                                                       *+                  TyCoBinder and ArgFlag+*                                                                       *+********************************************************************** -}++-- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be+-- dependent ('Named') or nondependent ('Anon'). They may also be visible or+-- not. See Note [TyCoBinders]+data TyCoBinder+  = Named TyCoVarBinder    -- A type-lambda binder+  | Anon AnonArgFlag Type  -- A term-lambda binder. Type here can be CoercionTy.+                           -- Visibility is determined by the AnonArgFlag+  deriving Data.Data++instance Outputable TyCoBinder where+  ppr (Anon af ty) = ppr af <+> ppr ty+  ppr (Named (Bndr v Required))  = ppr v+  ppr (Named (Bndr v Specified)) = char '@' <> ppr v+  ppr (Named (Bndr v Inferred))  = braces (ppr v)+++-- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder'+-- in the 'Named' field.+type TyBinder = TyCoBinder++-- | Remove the binder's variable from the set, if the binder has+-- a variable.+delBinderVar :: VarSet -> TyCoVarBinder -> VarSet+delBinderVar vars (Bndr tv _) = vars `delVarSet` tv++-- | Does this binder bind an invisible argument?+isInvisibleBinder :: TyCoBinder -> Bool+isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis+isInvisibleBinder (Anon InvisArg _)    = True+isInvisibleBinder (Anon VisArg   _)    = False++-- | Does this binder bind a visible argument?+isVisibleBinder :: TyCoBinder -> Bool+isVisibleBinder = not . isInvisibleBinder++isNamedBinder :: TyCoBinder -> Bool+isNamedBinder (Named {}) = True+isNamedBinder (Anon {})  = False++-- | If its a named binder, is the binder a tyvar?+-- Returns True for nondependent binder.+-- This check that we're really returning a *Ty*Binder (as opposed to a+-- coercion binder). That way, if/when we allow coercion quantification+-- in more places, we'll know we missed updating some function.+isTyBinder :: TyCoBinder -> Bool+isTyBinder (Named bnd) = isTyVarBinder bnd+isTyBinder _ = True++{- Note [TyCoBinders]+~~~~~~~~~~~~~~~~~~~+A ForAllTy contains a TyCoVarBinder.  But a type can be decomposed+to a telescope consisting of a [TyCoBinder]++A TyCoBinder represents the type of binders -- that is, the type of an+argument to a Pi-type. GHC Core currently supports two different+Pi-types:++ * A non-dependent function type,+   written with ->, e.g. ty1 -> ty2+   represented as FunTy ty1 ty2. These are+   lifted to Coercions with the corresponding FunCo.++ * A dependent compile-time-only polytype,+   written with forall, e.g.  forall (a:*). ty+   represented as ForAllTy (Bndr a v) ty++Both Pi-types classify terms/types that take an argument. In other+words, if `x` is either a function or a polytype, `x arg` makes sense+(for an appropriate `arg`).+++Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder.+  Each TyCoVarBinder+      Bndr a tvis+  is equipped with tvis::ArgFlag, which says whether or not arguments+  for this binder should be visible (explicit) in source Haskell.++* A TyCon contains a list of TyConBinders.  Each TyConBinder+      Bndr a cvis+  is equipped with cvis::TyConBndrVis, which says whether or not type+  and kind arguments for this TyCon should be visible (explicit) in+  source Haskell.++This table summarises the visibility rules:+---------------------------------------------------------------------------------------+|                                                      Occurrences look like this+|                             GHC displays type as     in Haskell source code+|--------------------------------------------------------------------------------------+| Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term+|  tvis :: ArgFlag+|  tvis = Inferred:            f :: forall {a}. type    Arg not allowed:  f+                               f :: forall {co}. type   Arg not allowed:  f+|  tvis = Specified:           f :: forall a. type      Arg optional:     f  or  f @Int+|  tvis = Required:            T :: forall k -> type    Arg required:     T *+|    This last form is illegal in terms: See Note [No Required TyCoBinder in terms]+|+| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon+|  cvis :: TyConBndrVis+|  cvis = AnonTCB:             T :: kind -> kind        Required:            T *+|  cvis = NamedTCB Inferred:   T :: forall {k}. kind    Arg not allowed:     T+|                              T :: forall {co}. kind   Arg not allowed:     T+|  cvis = NamedTCB Specified:  T :: forall k. kind      Arg not allowed[1]:  T+|  cvis = NamedTCB Required:   T :: forall k -> kind    Required:            T *+---------------------------------------------------------------------------------------++[1] In types, in the Specified case, it would make sense to allow+    optional kind applications, thus (T @*), but we have not+    yet implemented that++---- In term declarations ----++* Inferred.  Function defn, with no signature:  f1 x = x+  We infer f1 :: forall {a}. a -> a, with 'a' Inferred+  It's Inferred because it doesn't appear in any+  user-written signature for f1++* Specified.  Function defn, with signature (implicit forall):+     f2 :: a -> a; f2 x = x+  So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified+  even though 'a' is not bound in the source code by an explicit forall++* Specified.  Function defn, with signature (explicit forall):+     f3 :: forall a. a -> a; f3 x = x+  So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified++* Inferred/Specified.  Function signature with inferred kind polymorphism.+     f4 :: a b -> Int+  So 'f4' gets the type f4 :: forall {k} (a:k->*) (b:k). a b -> Int+  Here 'k' is Inferred (it's not mentioned in the type),+  but 'a' and 'b' are Specified.++* Specified.  Function signature with explicit kind polymorphism+     f5 :: a (b :: k) -> Int+  This time 'k' is Specified, because it is mentioned explicitly,+  so we get f5 :: forall (k:*) (a:k->*) (b:k). a b -> Int++* Similarly pattern synonyms:+  Inferred - from inferred types (e.g. no pattern type signature)+           - or from inferred kind polymorphism++---- In type declarations ----++* Inferred (k)+     data T1 a b = MkT1 (a b)+  Here T1's kind is  T1 :: forall {k:*}. (k->*) -> k -> *+  The kind variable 'k' is Inferred, since it is not mentioned++  Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind,+  and Anon binders don't have a visibility flag. (Or you could think+  of Anon having an implicit Required flag.)++* Specified (k)+     data T2 (a::k->*) b = MkT (a b)+  Here T's kind is  T :: forall (k:*). (k->*) -> k -> *+  The kind variable 'k' is Specified, since it is mentioned in+  the signature.++* Required (k)+     data T k (a::k->*) b = MkT (a b)+  Here T's kind is  T :: forall k:* -> (k->*) -> k -> *+  The kind is Required, since it bound in a positional way in T's declaration+  Every use of T must be explicitly applied to a kind++* Inferred (k1), Specified (k)+     data T a b (c :: k) = MkT (a b) (Proxy c)+  Here T's kind is  T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> *+  So 'k' is Specified, because it appears explicitly,+  but 'k1' is Inferred, because it does not++Generally, in the list of TyConBinders for a TyCon,++* Inferred arguments always come first+* Specified, Anon and Required can be mixed++e.g.+  data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ...++Here Foo's TyConBinders are+   [Required 'a', Specified 'b', Anon]+and its kind prints as+   Foo :: forall a -> forall b. (a -> b -> Type) -> Type++See also Note [Required, Specified, and Inferred for types] in TcTyClsDecls++---- Printing -----++ We print forall types with enough syntax to tell you their visibility+ flag.  But this is not source Haskell, and these types may not all+ be parsable.++ Specified: a list of Specified binders is written between `forall` and `.`:+               const :: forall a b. a -> b -> a++ Inferred: like Specified, but every binder is written in braces:+               f :: forall {k} (a:k). S k a -> Int++ Required: binders are put between `forall` and `->`:+              T :: forall k -> *++---- Other points -----++* In classic Haskell, all named binders (that is, the type variables in+  a polymorphic function type f :: forall a. a -> a) have been Inferred.++* Inferred variables correspond to "generalized" variables from the+  Visible Type Applications paper (ESOP'16).++Note [No Required TyCoBinder in terms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't allow Required foralls for term variables, including pattern+synonyms and data constructors.  Why?  Because then an application+would need a /compulsory/ type argument (possibly without an "@"?),+thus (f Int); and we don't have concrete syntax for that.++We could change this decision, but Required, Named TyCoBinders are rare+anyway.  (Most are Anons.)++However the type of a term can (just about) have a required quantifier;+see Note [Required quantifiers in the type of a term] in TcExpr.+-}+++{- **********************************************************************+*                                                                       *+                        PredType+*                                                                       *+********************************************************************** -}+++-- | A type of the form @p@ of constraint kind represents a value whose type is+-- the Haskell predicate @p@, where a predicate is what occurs before+-- the @=>@ in a Haskell type.+--+-- We use 'PredType' as documentation to mark those types that we guarantee to+-- have this kind.+--+-- It can be expanded into its representation, but:+--+-- * The type checker must treat it as opaque+--+-- * The rest of the compiler treats it as transparent+--+-- Consider these examples:+--+-- > f :: (Eq a) => a -> Int+-- > g :: (?x :: Int -> Int) => a -> Int+-- > h :: (r\l) => {r} => {l::Int | r}+--+-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\"+type PredType = Type++-- | A collection of 'PredType's+type ThetaType = [PredType]++{-+(We don't support TREX records yet, but the setup is designed+to expand to allow them.)++A Haskell qualified type, such as that for f,g,h above, is+represented using+        * a FunTy for the double arrow+        * with a type of kind Constraint as the function argument++The predicate really does turn into a real extra argument to the+function.  If the argument has type (p :: Constraint) then the predicate p is+represented by evidence of type p.+++%************************************************************************+%*                                                                      *+            Simple constructors+%*                                                                      *+%************************************************************************++These functions are here so that they can be used by TysPrim,+which in turn is imported by Type+-}++mkTyVarTy  :: TyVar   -> Type+mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) )+              TyVarTy v++mkTyVarTys :: [TyVar] -> [Type]+mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy++mkTyCoVarTy :: TyCoVar -> Type+mkTyCoVarTy v+  | isTyVar v+  = TyVarTy v+  | otherwise+  = CoercionTy (CoVarCo v)++mkTyCoVarTys :: [TyCoVar] -> [Type]+mkTyCoVarTys = map mkTyCoVarTy++infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy`      -- Associates to the right++mkFunTy :: AnonArgFlag -> Type -> Type -> Type+mkFunTy af arg res = FunTy { ft_af = af, ft_arg = arg, ft_res = res }++mkVisFunTy, mkInvisFunTy :: Type -> Type -> Type+mkVisFunTy   = mkFunTy VisArg+mkInvisFunTy = mkFunTy InvisArg++-- | Make nested arrow types+mkVisFunTys, mkInvisFunTys :: [Type] -> Type -> Type+mkVisFunTys   tys ty = foldr mkVisFunTy   ty tys+mkInvisFunTys tys ty = foldr mkInvisFunTy ty tys++-- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder+-- See Note [Unused coercion variable in ForAllTy]+mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type+mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty++-- | Wraps foralls over the type using the provided 'TyCoVar's from left to right+mkForAllTys :: [TyCoVarBinder] -> Type -> Type+mkForAllTys tyvars ty = foldr ForAllTy ty tyvars++mkPiTy:: TyCoBinder -> Type -> Type+mkPiTy (Anon af ty1) ty2        = FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 }+mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty++mkPiTys :: [TyCoBinder] -> Type -> Type+mkPiTys tbs ty = foldr mkPiTy ty tbs++-- | Create the plain type constructor type which has been applied to no type arguments at all.+mkTyConTy :: TyCon -> Type+mkTyConTy tycon = TyConApp tycon []++{-+%************************************************************************+%*                                                                      *+            Coercions+%*                                                                      *+%************************************************************************+-}++-- | A 'Coercion' is concrete evidence of the equality/convertibility+-- of two types.++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data Coercion+  -- Each constructor has a "role signature", indicating the way roles are+  -- propagated through coercions.+  --    -  P, N, and R stand for coercions of the given role+  --    -  e stands for a coercion of a specific unknown role+  --           (think "role polymorphism")+  --    -  "e" stands for an explicit role parameter indicating role e.+  --    -   _ stands for a parameter that is not a Role or Coercion.++  -- These ones mirror the shape of types+  = -- Refl :: _ -> N+    Refl Type  -- See Note [Refl invariant]+          -- Invariant: applications of (Refl T) to a bunch of identity coercions+          --            always show up as Refl.+          -- For example  (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)).++          -- Applications of (Refl T) to some coercions, at least one of+          -- which is NOT the identity, show up as TyConAppCo.+          -- (They may not be fully saturated however.)+          -- ConAppCo coercions (like all coercions other than Refl)+          -- are NEVER the identity.++          -- Use (GRefl Representational ty MRefl), not (SubCo (Refl ty))++  -- GRefl :: "e" -> _ -> Maybe N -> e+  -- See Note [Generalized reflexive coercion]+  | GRefl Role Type MCoercionN  -- See Note [Refl invariant]+          -- Use (Refl ty), not (GRefl Nominal ty MRefl)+          -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _))++  -- These ones simply lift the correspondingly-named+  -- Type constructors into Coercions++  -- TyConAppCo :: "e" -> _ -> ?? -> e+  -- See Note [TyConAppCo roles]+  | TyConAppCo Role TyCon [Coercion]    -- lift TyConApp+               -- The TyCon is never a synonym;+               -- we expand synonyms eagerly+               -- But it can be a type function+               -- TyCon is never a saturated (->); use FunCo instead++  | AppCo Coercion CoercionN             -- lift AppTy+          -- AppCo :: e -> N -> e++  -- See Note [Forall coercions]+  | ForAllCo TyCoVar KindCoercion Coercion+         -- ForAllCo :: _ -> N -> e -> e++  | FunCo Role Coercion Coercion         -- lift FunTy+         -- FunCo :: "e" -> e -> e -> e+         -- Note: why doesn't FunCo have a AnonArgFlag, like FunTy?+         -- Because the AnonArgFlag has no impact on Core; it is only+         -- there to guide implicit instantiation of Haskell source+         -- types, and that is irrelevant for coercions, which are+         -- Core-only.++  -- These are special+  | CoVarCo CoVar      -- :: _ -> (N or R)+                       -- result role depends on the tycon of the variable's type++    -- AxiomInstCo :: e -> _ -> ?? -> e+  | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion]+     -- See also [CoAxiom index]+     -- The coercion arguments always *precisely* saturate+     -- arity of (that branch of) the CoAxiom. If there are+     -- any left over, we use AppCo.+     -- See [Coercion axioms applied to coercions]+     -- The roles of the argument coercions are determined+     -- by the cab_roles field of the relevant branch of the CoAxiom++  | AxiomRuleCo CoAxiomRule [Coercion]+    -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule+    -- The number coercions should match exactly the expectations+    -- of the CoAxiomRule (i.e., the rule is fully saturated).++  | UnivCo UnivCoProvenance Role Type Type+      -- :: _ -> "e" -> _ -> _ -> e++  | SymCo Coercion             -- :: e -> e+  | TransCo Coercion Coercion  -- :: e -> e -> e++  | NthCo  Role Int Coercion     -- Zero-indexed; decomposes (T t0 ... tn)+    -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles])+    -- Using NthCo on a ForAllCo gives an N coercion always+    -- See Note [NthCo and newtypes]+    --+    -- Invariant:  (NthCo r i co), it is always the case that r = role of (Nth i co)+    -- That is: the role of the entire coercion is redundantly cached here.+    -- See Note [NthCo Cached Roles]++  | LRCo   LeftOrRight CoercionN     -- Decomposes (t_left t_right)+    -- :: _ -> N -> N+  | InstCo Coercion CoercionN+    -- :: e -> N -> e+    -- See Note [InstCo roles]++  -- Extract a kind coercion from a (heterogeneous) type coercion+  -- NB: all kind coercions are Nominal+  | KindCo Coercion+     -- :: e -> N++  | SubCo CoercionN                  -- Turns a ~N into a ~R+    -- :: N -> R++  | HoleCo CoercionHole              -- ^ See Note [Coercion holes]+                                     -- Only present during typechecking+  deriving Data.Data++type CoercionN = Coercion       -- always nominal+type CoercionR = Coercion       -- always representational+type CoercionP = Coercion       -- always phantom+type KindCoercion = CoercionN   -- always nominal++instance Outputable Coercion where+  ppr = pprCo++-- | A semantically more meaningful type to represent what may or may not be a+-- useful 'Coercion'.+data MCoercion+  = MRefl+    -- A trivial Reflexivity coercion+  | MCo Coercion+    -- Other coercions+  deriving Data.Data+type MCoercionR = MCoercion+type MCoercionN = MCoercion++instance Outputable MCoercion where+  ppr MRefl    = text "MRefl"+  ppr (MCo co) = text "MCo" <+> ppr co++{-+Note [Refl invariant]+~~~~~~~~~~~~~~~~~~~~~+Invariant 1:++Coercions have the following invariant+     Refl (similar for GRefl r ty MRefl) is always lifted as far as possible.++You might think that a consequences is:+     Every identity coercions has Refl at the root++But that's not quite true because of coercion variables.  Consider+     g         where g :: Int~Int+     Left h    where h :: Maybe Int ~ Maybe Int+etc.  So the consequence is only true of coercions that+have no coercion variables.++Note [Generalized reflexive coercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++GRefl is a generalized reflexive coercion (see #15192). It wraps a kind+coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing+rules for GRefl:++  ty : k1+  ------------------------------------+  GRefl r ty MRefl: ty ~r ty++  ty : k1       co :: k1 ~ k2+  ------------------------------------+  GRefl r ty (MCo co) : ty ~r ty |> co++Consider we have++   g1 :: s ~r t+   s  :: k1+   g2 :: k1 ~ k2++and we want to construct a coercions co which has type++   (s |> g2) ~r t++We can define++   co = Sym (GRefl r s g2) ; g1++It is easy to see that++   Refl == GRefl Nominal ty MRefl :: ty ~n ty++A nominal reflexive coercion is quite common, so we keep the special form Refl to+save allocation.++Note [Coercion axioms applied to coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The reason coercion axioms can be applied to coercions and not just+types is to allow for better optimization.  There are some cases where+we need to be able to "push transitivity inside" an axiom in order to+expose further opportunities for optimization.++For example, suppose we have++  C a : t[a] ~ F a+  g   : b ~ c++and we want to optimize++  sym (C b) ; t[g] ; C c++which has the kind++  F b ~ F c++(stopping through t[b] and t[c] along the way).++We'd like to optimize this to just F g -- but how?  The key is+that we need to allow axioms to be instantiated by *coercions*,+not just by types.  Then we can (in certain cases) push+transitivity inside the axiom instantiations, and then react+opposite-polarity instantiations of the same axiom.  In this+case, e.g., we match t[g] against the LHS of (C c)'s kind, to+obtain the substitution  a |-> g  (note this operation is sort+of the dual of lifting!) and hence end up with++  C g : t[b] ~ F c++which indeed has the same kind as  t[g] ; C c.++Now we have++  sym (C b) ; C g++which can be optimized to F g.++Note [CoAxiom index]+~~~~~~~~~~~~~~~~~~~~+A CoAxiom has 1 or more branches. Each branch has contains a list+of the free type variables in that branch, the LHS type patterns,+and the RHS type for that branch. When we apply an axiom to a list+of coercions, we must choose which branch of the axiom we wish to+use, as the different branches may have different numbers of free+type variables. (The number of type patterns is always the same+among branches, but that doesn't quite concern us here.)++The Int in the AxiomInstCo constructor is the 0-indexed number+of the chosen branch.++Note [Forall coercions]+~~~~~~~~~~~~~~~~~~~~~~~+Constructing coercions between forall-types can be a bit tricky,+because the kinds of the bound tyvars can be different.++The typing rule is:+++  kind_co : k1 ~ k2+  tv1:k1 |- co : t1 ~ t2+  -------------------------------------------------------------------+  ForAllCo tv1 kind_co co : all tv1:k1. t1  ~+                            all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co])++First, the TyCoVar stored in a ForAllCo is really an optimisation: this field+should be a Name, as its kind is redundant. Thinking of the field as a Name+is helpful in understanding what a ForAllCo means.+The kind of TyCoVar always matches the left-hand kind of the coercion.++The idea is that kind_co gives the two kinds of the tyvar. See how, in the+conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right.++Of course, a type variable can't have different kinds at the same time. So,+we arbitrarily prefer the first kind when using tv1 in the inner coercion+co, which shows that t1 equals t2.++The last wrinkle is that we need to fix the kinds in the conclusion. In+t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of+the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with+(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it+mentions the same name with different kinds, but it *is* well-kinded, noting+that `(tv1:k2) |> sym kind_co` has kind k1.++This all really would work storing just a Name in the ForAllCo. But we can't+add Names to, e.g., VarSets, and there generally is just an impedance mismatch+in a bunch of places. So we use tv1. When we need tv2, we can use+setTyVarKind.++Note [Predicate coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   g :: a~b+How can we coerce between types+   ([c]~a) => [a] -> c+and+   ([c]~b) => [b] -> c+where the equality predicate *itself* differs?++Answer: we simply treat (~) as an ordinary type constructor, so these+types really look like++   ((~) [c] a) -> [a] -> c+   ((~) [c] b) -> [b] -> c++So the coercion between the two is obviously++   ((~) [c] g) -> [g] -> c++Another way to see this to say that we simply collapse predicates to+their representation type (see Type.coreView and Type.predTypeRep).++This collapse is done by mkPredCo; there is no PredCo constructor+in Coercion.  This is important because we need Nth to work on+predicates too:+    Nth 1 ((~) [c] g) = g+See Simplify.simplCoercionF, which generates such selections.++Note [Roles]+~~~~~~~~~~~~+Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated+in #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see+https://gitlab.haskell.org/ghc/ghc/wikis/roles-implementation++Here is one way to phrase the problem:++Given:+newtype Age = MkAge Int+type family F x+type instance F Age = Bool+type instance F Int = Char++This compiles down to:+axAge :: Age ~ Int+axF1 :: F Age ~ Bool+axF2 :: F Int ~ Char++Then, we can make:+(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char++Yikes!++The solution is _roles_, as articulated in "Generative Type Abstraction and+Type-level Computation" (POPL 2010), available at+http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf++The specification for roles has evolved somewhat since that paper. For the+current full details, see the documentation in docs/core-spec. Here are some+highlights.++We label every equality with a notion of type equivalence, of which there are+three options: Nominal, Representational, and Phantom. A ground type is+nominally equivalent only with itself. A newtype (which is considered a ground+type in Haskell) is representationally equivalent to its representation.+Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P"+to denote the equivalences.++The axioms above would be:+axAge :: Age ~R Int+axF1 :: F Age ~N Bool+axF2 :: F Age ~N Char++Then, because transitivity applies only to coercions proving the same notion+of equivalence, the above construction is impossible.++However, there is still an escape hatch: we know that any two types that are+nominally equivalent are representationally equivalent as well. This is what+the form SubCo proves -- it "demotes" a nominal equivalence into a+representational equivalence. So, it would seem the following is possible:++sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char   -- WRONG++What saves us here is that the arguments to a type function F, lifted into a+coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and+we are safe.++Roles are attached to parameters to TyCons. When lifting a TyCon into a+coercion (through TyConAppCo), we need to ensure that the arguments to the+TyCon respect their roles. For example:++data T a b = MkT a (F b)++If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know+that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because+the type function F branches on b's *name*, not representation. So, we say+that 'a' has role Representational and 'b' has role Nominal. The third role,+Phantom, is for parameters not used in the type's definition. Given the+following definition++data Q a = MkQ Int++the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we+can construct the coercion Bool ~P Char (using UnivCo).++See the paper cited above for more examples and information.++Note [TyConAppCo roles]+~~~~~~~~~~~~~~~~~~~~~~~+The TyConAppCo constructor has a role parameter, indicating the role at+which the coercion proves equality. The choice of this parameter affects+the required roles of the arguments of the TyConAppCo. To help explain+it, assume the following definition:++  type instance F Int = Bool   -- Axiom axF : F Int ~N Bool+  newtype Age = MkAge Int      -- Axiom axAge : Age ~R Int+  data Foo a = MkFoo a         -- Role on Foo's parameter is Representational++TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool+  For (TyConAppCo Nominal) all arguments must have role Nominal. Why?+  So that Foo Age ~N Foo Int does *not* hold.++TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool+TyConAppCo Representational Foo axAge       : Foo Age     ~R Foo Int+  For (TyConAppCo Representational), all arguments must have the roles+  corresponding to the result of tyConRoles on the TyCon. This is the+  whole point of having roles on the TyCon to begin with. So, we can+  have Foo Age ~R Foo Int, if Foo's parameter has role R.++  If a Representational TyConAppCo is over-saturated (which is otherwise fine),+  the spill-over arguments must all be at Nominal. This corresponds to the+  behavior for AppCo.++TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool+  All arguments must have role Phantom. This one isn't strictly+  necessary for soundness, but this choice removes ambiguity.++The rules here dictate the roles of the parameters to mkTyConAppCo+(should be checked by Lint).++Note [NthCo and newtypes]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++  newtype N a = MkN Int+  type role N representational++This yields axiom++  NTCo:N :: forall a. N a ~R Int++We can then build++  co :: forall a b. N a ~R N b+  co = NTCo:N a ; sym (NTCo:N b)++for any `a` and `b`. Because of the role annotation on N, if we use+NthCo, we'll get out a representational coercion. That is:++  NthCo r 0 co :: forall a b. a ~R b++Yikes! Clearly, this is terrible. The solution is simple: forbid+NthCo to be used on newtypes if the internal coercion is representational.++This is not just some corner case discovered by a segfault somewhere;+it was discovered in the proof of soundness of roles and described+in the "Safe Coercions" paper (ICFP '14).++Note [NthCo Cached Roles]+~~~~~~~~~~~~~~~~~~~~~~~~~+Why do we cache the role of NthCo in the NthCo constructor?+Because computing role(Nth i co) involves figuring out that++  co :: T tys1 ~ T tys2++using coercionKind, and finding (coercionRole co), and then looking+at the tyConRoles of T. Avoiding bad asymptotic behaviour here means+we have to compute the kind and role of a coercion simultaneously,+which makes the code complicated and inefficient.++This only happens for NthCo. Caching the role solves the problem, and+allows coercionKind and coercionRole to be simple.++See #11735++Note [InstCo roles]+~~~~~~~~~~~~~~~~~~~+Here is (essentially) the typing rule for InstCo:++g :: (forall a. t1) ~r (forall a. t2)+w :: s1 ~N s2+------------------------------- InstCo+InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2])++Note that the Coercion w *must* be nominal. This is necessary+because the variable a might be used in a "nominal position"+(that is, a place where role inference would require a nominal+role) in t1 or t2. If we allowed w to be representational, we+could get bogus equalities.++A more nuanced treatment might be able to relax this condition+somewhat, by checking if t1 and/or t2 use their bound variables+in nominal ways. If not, having w be representational is OK.+++%************************************************************************+%*                                                                      *+                UnivCoProvenance+%*                                                                      *+%************************************************************************++A UnivCo is a coercion whose proof does not directly express its role+and kind (indeed for some UnivCos, like PluginProv, there /is/ no proof).++The different kinds of UnivCo are described by UnivCoProvenance.  Really+each is entirely separate, but they all share the need to represent their+role and kind, which is done in the UnivCo constructor.++-}++-- | For simplicity, we have just one UnivCo that represents a coercion from+-- some type to some other type, with (in general) no restrictions on the+-- type. The UnivCoProvenance specifies more exactly what the coercion really+-- is and why a program should (or shouldn't!) trust the coercion.+-- It is reasonable to consider each constructor of 'UnivCoProvenance'+-- as a totally independent coercion form; their only commonality is+-- that they don't tell you what types they coercion between. (That info+-- is in the 'UnivCo' constructor of 'Coercion'.+data UnivCoProvenance+  = PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom+                             -- roled coercions++  | ProofIrrelProv KindCoercion  -- ^ From the fact that any two coercions are+                                 --   considered equivalent. See Note [ProofIrrelProv].+                                 -- Can be used in Nominal or Representational coercions++  | PluginProv String  -- ^ From a plugin, which asserts that this coercion+                       --   is sound. The string is for the use of the plugin.++  deriving Data.Data++instance Outputable UnivCoProvenance where+  ppr (PhantomProv _)    = text "(phantom)"+  ppr (ProofIrrelProv _) = text "(proof irrel.)"+  ppr (PluginProv str)   = parens (text "plugin" <+> brackets (text str))++-- | A coercion to be filled in by the type-checker. See Note [Coercion holes]+data CoercionHole+  = CoercionHole { ch_co_var  :: CoVar+                       -- See Note [CoercionHoles and coercion free variables]++                 , ch_blocker :: BlockSubstFlag  -- should this hole block substitution?+                                                 -- See (2a) in TcCanonical+                                                 -- Note [Equalities with incompatible kinds]+                 , ch_ref     :: IORef (Maybe Coercion)+                 }++data BlockSubstFlag = YesBlockSubst+                    | NoBlockSubst++coHoleCoVar :: CoercionHole -> CoVar+coHoleCoVar = ch_co_var++setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole+setCoHoleCoVar h cv = h { ch_co_var = cv }++instance Data.Data CoercionHole where+  -- don't traverse?+  toConstr _   = abstractConstr "CoercionHole"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "CoercionHole"++instance Outputable CoercionHole where+  ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv)++instance Outputable BlockSubstFlag where+  ppr YesBlockSubst = text "YesBlockSubst"+  ppr NoBlockSubst  = text "NoBlockSubst"++{- Note [Phantom coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+     data T a = T1 | T2+Then we have+     T s ~R T t+for any old s,t. The witness for this is (TyConAppCo T Rep co),+where (co :: s ~P t) is a phantom coercion built with PhantomProv.+The role of the UnivCo is always Phantom.  The Coercion stored is the+(nominal) kind coercion between the types+   kind(s) ~N kind (t)++Note [Coercion holes]+~~~~~~~~~~~~~~~~~~~~~~~~+During typechecking, constraint solving for type classes works by+  - Generate an evidence Id,  d7 :: Num a+  - Wrap it in a Wanted constraint, [W] d7 :: Num a+  - Use the evidence Id where the evidence is needed+  - Solve the constraint later+  - When solved, add an enclosing let-binding  let d7 = .... in ....+    which actually binds d7 to the (Num a) evidence++For equality constraints we use a different strategy.  See Note [The+equality types story] in TysPrim for background on equality constraints.+  - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just+    like type classes above. (Indeed, boxed equality constraints *are* classes.)+  - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2)+    we use a different plan++For unboxed equalities:+  - Generate a CoercionHole, a mutable variable just like a unification+    variable+  - Wrap the CoercionHole in a Wanted constraint; see TcRnTypes.TcEvDest+  - Use the CoercionHole in a Coercion, via HoleCo+  - Solve the constraint later+  - When solved, fill in the CoercionHole by side effect, instead of+    doing the let-binding thing++The main reason for all this is that there may be no good place to let-bind+the evidence for unboxed equalities:++  - We emit constraints for kind coercions, to be used to cast a+    type's kind. These coercions then must be used in types. Because+    they might appear in a top-level type, there is no place to bind+    these (unlifted) coercions in the usual way.++  - A coercion for (forall a. t1) ~ (forall a. t2) will look like+       forall a. (coercion for t1~t2)+    But the coercion for (t1~t2) may mention 'a', and we don't have+    let-bindings within coercions.  We could add them, but coercion+    holes are easier.++  - Moreover, nothing is lost from the lack of let-bindings. For+    dictionaries want to achieve sharing to avoid recomoputing the+    dictionary.  But coercions are entirely erased, so there's little+    benefit to sharing. Indeed, even if we had a let-binding, we+    always inline types and coercions at every use site and drop the+    binding.++Other notes about HoleCo:++ * INVARIANT: CoercionHole and HoleCo are used only during type checking,+   and should never appear in Core. Just like unification variables; a Type+   can contain a TcTyVar, but only during type checking. If, one day, we+   use type-level information to separate out forms that can appear during+   type-checking vs forms that can appear in core proper, holes in Core will+   be ruled out.++ * See Note [CoercionHoles and coercion free variables]++ * Coercion holes can be compared for equality like other coercions:+   by looking at the types coerced.+++Note [CoercionHoles and coercion free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Why does a CoercionHole contain a CoVar, as well as reference to+fill in?  Because we want to treat that CoVar as a free variable of+the coercion.  See #14584, and Note [What prevents a+constraint from floating] in TcSimplify, item (4):++        forall k. [W] co1 :: t1 ~# t2 |> co2+                  [W] co2 :: k ~# *++Here co2 is a CoercionHole. But we /must/ know that it is free in+co1, because that's all that stops it floating outside the+implication.+++Note [ProofIrrelProv]+~~~~~~~~~~~~~~~~~~~~~+A ProofIrrelProv is a coercion between coercions. For example:++  data G a where+    MkG :: G Bool++In core, we get++  G :: * -> *+  MkG :: forall (a :: *). (a ~ Bool) -> G a++Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want+a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be++  TyConAppCo Nominal MkG [co3, co4]+  where+    co3 :: co1 ~ co2+    co4 :: a1 ~ a2++Note that+  co1 :: a1 ~ Bool+  co2 :: a2 ~ Bool++Here,+  co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2)+  where+    co5 :: (a1 ~ Bool) ~ (a2 ~ Bool)+    co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, <Bool>]+-}+++{- *********************************************************************+*                                                                      *+                foldType  and   foldCoercion+*                                                                      *+********************************************************************* -}++{- Note [foldType]+~~~~~~~~~~~~~~~~~~+foldType is a bit more powerful than perhaps it looks:++* You can fold with an accumulating parameter, via+     TyCoFolder env (Endo a)+  Recall newtype Endo a = Endo (a->a)++* You can fold monadically with a monad M, via+     TyCoFolder env (M a)+  provided you have+     instance ..  => Monoid (M a)++Note [mapType vs foldType]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We define foldType here, but mapType in module Type. Why?++* foldType is used in GHC.Core.TyCo.FVs for finding free variables.+  It's a very simple function that analyses a type,+  but does not construct one.++* mapType constructs new types, and so it needs to call+  the "smart constructors", mkAppTy, mkCastTy, and so on.+  These are sophisticated functions, and can't be defined+  here in GHC.Core.TyCo.Rep.++Note [Specialising foldType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We inline foldType at every call site (there are not many), so that it+becomes specialised for the particular monoid *and* TyCoFolder at+that site.  This is just for efficiency, but walking over types is+done a *lot* in GHC, so worth optimising.++We were worried that+    TyCoFolder env (Endo a)+might not eta-expand.  Recall newtype Endo a = Endo (a->a).++In particular, given+   fvs :: Type -> TyCoVarSet+   fvs ty = appEndo (foldType tcf emptyVarSet ty) emptyVarSet++   tcf :: TyCoFolder enf (Endo a)+   tcf = TyCoFolder { tcf_tyvar = do_tv, ... }+      where+        do_tvs is tv = Endo do_it+           where+             do_it acc | tv `elemVarSet` is  = acc+                       | tv `elemVarSet` acc = acc+                       | otherwise = acc `extendVarSet` tv+++we want to end up with+   fvs ty = go emptyVarSet ty emptyVarSet+     where+       go env (TyVarTy tv) acc = acc `extendVarSet` tv+       ..etc..++And indeed this happens.+  - Selections from 'tcf' are done at compile time+  - 'go' is nicely eta-expanded.++We were also worried about+   deep_fvs :: Type -> TyCoVarSet+   deep_fvs ty = appEndo (foldType deep_tcf emptyVarSet ty) emptyVarSet++   deep_tcf :: TyCoFolder enf (Endo a)+   deep_tcf = TyCoFolder { tcf_tyvar = do_tv, ... }+      where+        do_tvs is tv = Endo do_it+           where+             do_it acc | tv `elemVarSet` is  = acc+                       | tv `elemVarSet` acc = acc+                       | otherwise = deep_fvs (varType tv)+                                     `unionVarSet` acc+                                     `extendVarSet` tv++Here deep_fvs and deep_tcf are mutually recursive, unlike fvs and tcf.+But, amazingly, we get good code here too. GHC is careful not to makr+TyCoFolder data constructor for deep_tcf as a loop breaker, so the+record selections still cancel.  And eta expansion still happens too.+-}++data TyCoFolder env a+  = TyCoFolder+      { tcf_view  :: Type -> Maybe Type   -- Optional "view" function+                                          -- E.g. expand synonyms+      , tcf_tyvar :: env -> TyVar -> a+      , tcf_covar :: env -> CoVar -> a+      , tcf_hole  :: env -> CoercionHole -> a+          -- ^ What to do with coercion holes.+          -- See Note [Coercion holes] in GHC.Core.TyCo.Rep.++      , tcf_tycobinder :: env -> TyCoVar -> ArgFlag -> env+          -- ^ The returned env is used in the extended scope+      }++{-# INLINE foldTyCo  #-}  -- See Note [Specialising foldType]+foldTyCo :: Monoid a => TyCoFolder env a -> env+         -> (Type -> a, [Type] -> a, Coercion -> a, [Coercion] -> a)+foldTyCo (TyCoFolder { tcf_view       = view+                     , tcf_tyvar      = tyvar+                     , tcf_tycobinder = tycobinder+                     , tcf_covar      = covar+                     , tcf_hole       = cohole }) env+  = (go_ty env, go_tys env, go_co env, go_cos env)+  where+    go_ty env ty | Just ty' <- view ty = go_ty env ty'+    go_ty env (TyVarTy tv)      = tyvar env tv+    go_ty env (AppTy t1 t2)     = go_ty env t1 `mappend` go_ty env t2+    go_ty _   (LitTy {})        = mempty+    go_ty env (CastTy ty co)    = go_ty env ty `mappend` go_co env co+    go_ty env (CoercionTy co)   = go_co env co+    go_ty env (FunTy _ arg res) = go_ty env arg `mappend` go_ty env res+    go_ty env (TyConApp _ tys)  = go_tys env tys+    go_ty env (ForAllTy (Bndr tv vis) inner)+      = let !env' = tycobinder env tv vis  -- Avoid building a thunk here+        in go_ty env (varType tv) `mappend` go_ty env' inner++    -- Explicit recursion becuase using foldr builds a local+    -- loop (with env free) and I'm not confident it'll be+    -- lambda lifted in the end+    go_tys _   []     = mempty+    go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts++    go_cos _   []     = mempty+    go_cos env (c:cs) = go_co env c `mappend` go_cos env cs++    go_co env (Refl ty)               = go_ty env ty+    go_co env (GRefl _ ty MRefl)      = go_ty env ty+    go_co env (GRefl _ ty (MCo co))   = go_ty env ty `mappend` go_co env co+    go_co env (TyConAppCo _ _ args)   = go_cos env args+    go_co env (AppCo c1 c2)           = go_co env c1 `mappend` go_co env c2+    go_co env (FunCo _ c1 c2)         = go_co env c1 `mappend` go_co env c2+    go_co env (CoVarCo cv)            = covar env cv+    go_co env (AxiomInstCo _ _ args)  = go_cos env args+    go_co env (HoleCo hole)           = cohole env hole+    go_co env (UnivCo p _ t1 t2)      = go_prov env p `mappend` go_ty env t1+                                                      `mappend` go_ty env t2+    go_co env (SymCo co)              = go_co env co+    go_co env (TransCo c1 c2)         = go_co env c1 `mappend` go_co env c2+    go_co env (AxiomRuleCo _ cos)     = go_cos env cos+    go_co env (NthCo _ _ co)          = go_co env co+    go_co env (LRCo _ co)             = go_co env co+    go_co env (InstCo co arg)         = go_co env co `mappend` go_co env arg+    go_co env (KindCo co)             = go_co env co+    go_co env (SubCo co)              = go_co env co+    go_co env (ForAllCo tv kind_co co)+      = go_co env kind_co `mappend` go_ty env (varType tv)+                          `mappend` go_co env' co+      where+        env' = tycobinder env tv Inferred++    go_prov env (PhantomProv co)    = go_co env co+    go_prov env (ProofIrrelProv co) = go_co env co+    go_prov _   (PluginProv _)      = mempty++{- *********************************************************************+*                                                                      *+                   typeSize, coercionSize+*                                                                      *+********************************************************************* -}++-- NB: We put typeSize/coercionSize here because they are mutually+--     recursive, and have the CPR property.  If we have mutual+--     recursion across a hi-boot file, we don't get the CPR property+--     and these functions allocate a tremendous amount of rubbish.+--     It's not critical (because typeSize is really only used in+--     debug mode, but I tripped over an example (T5642) in which+--     typeSize was one of the biggest single allocators in all of GHC.+--     And it's easy to fix, so I did.++-- NB: typeSize does not respect `eqType`, in that two types that+--     are `eqType` may return different sizes. This is OK, because this+--     function is used only in reporting, not decision-making.++typeSize :: Type -> Int+typeSize (LitTy {})                 = 1+typeSize (TyVarTy {})               = 1+typeSize (AppTy t1 t2)              = typeSize t1 + typeSize t2+typeSize (FunTy _ t1 t2)            = typeSize t1 + typeSize t2+typeSize (ForAllTy (Bndr tv _) t)   = typeSize (varType tv) + typeSize t+typeSize (TyConApp _ ts)            = 1 + sum (map typeSize ts)+typeSize (CastTy ty co)             = typeSize ty + coercionSize co+typeSize (CoercionTy co)            = coercionSize co++coercionSize :: Coercion -> Int+coercionSize (Refl ty)             = typeSize ty+coercionSize (GRefl _ ty MRefl)    = typeSize ty+coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co+coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args)+coercionSize (AppCo co arg)      = coercionSize co + coercionSize arg+coercionSize (ForAllCo _ h co)   = 1 + coercionSize co + coercionSize h+coercionSize (FunCo _ co1 co2)   = 1 + coercionSize co1 + coercionSize co2+coercionSize (CoVarCo _)         = 1+coercionSize (HoleCo _)          = 1+coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args)+coercionSize (UnivCo p _ t1 t2)  = 1 + provSize p + typeSize t1 + typeSize t2+coercionSize (SymCo co)          = 1 + coercionSize co+coercionSize (TransCo co1 co2)   = 1 + coercionSize co1 + coercionSize co2+coercionSize (NthCo _ _ co)      = 1 + coercionSize co+coercionSize (LRCo  _ co)        = 1 + coercionSize co+coercionSize (InstCo co arg)     = 1 + coercionSize co + coercionSize arg+coercionSize (KindCo co)         = 1 + coercionSize co+coercionSize (SubCo co)          = 1 + coercionSize co+coercionSize (AxiomRuleCo _ cs)  = 1 + sum (map coercionSize cs)++provSize :: UnivCoProvenance -> Int+provSize (PhantomProv co)    = 1 + coercionSize co+provSize (ProofIrrelProv co) = 1 + coercionSize co+provSize (PluginProv _)      = 1
+ compiler/GHC/Core/TyCo/Rep.hs-boot view
@@ -0,0 +1,23 @@+module GHC.Core.TyCo.Rep where++import Data.Data  ( Data )+import {-# SOURCE #-} GHC.Types.Var( Var, ArgFlag, AnonArgFlag )++data Type+data TyThing+data Coercion+data UnivCoProvenance+data TyLit+data TyCoBinder+data MCoercion++type PredType = Type+type Kind = Type+type ThetaType = [PredType]+type CoercionN = Coercion+type MCoercionN = MCoercion++mkFunTy   :: AnonArgFlag -> Type -> Type -> Type+mkForAllTy :: Var -> ArgFlag -> Type -> Type++instance Data Type  -- To support Data instances in GHC.Core.Coercion.Axiom
+ compiler/GHC/Core/TyCo/Subst.hs view
@@ -0,0 +1,1032 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998+Type and Coercion - friends' interface+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++-- | Substitution into types and coercions.+module GHC.Core.TyCo.Subst+  (+        -- * Substitutions+        TCvSubst(..), TvSubstEnv, CvSubstEnv,+        emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst,+        emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst,+        mkTCvSubst, mkTvSubst, mkCvSubst,+        getTvSubstEnv,+        getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs,+        isInScope, notElemTCvSubst,+        setTvSubstEnv, setCvSubstEnv, zapTCvSubst,+        extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet,+        extendTCvSubst, extendTCvSubstWithClone,+        extendCvSubst, extendCvSubstWithClone,+        extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone,+        extendTvSubstList, extendTvSubstAndInScope,+        extendTCvSubstList,+        unionTCvSubst, zipTyEnv, zipCoEnv,+        zipTvSubst, zipCvSubst,+        zipTCvSubst,+        mkTvSubstPrs,++        substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars,+        substCoWith,+        substTy, substTyAddInScope,+        substTyUnchecked, substTysUnchecked, substThetaUnchecked,+        substTyWithUnchecked,+        substCoUnchecked, substCoWithUnchecked,+        substTyWithInScope,+        substTys, substTheta,+        lookupTyVar,+        substCo, substCos, substCoVar, substCoVars, lookupCoVar,+        cloneTyVarBndr, cloneTyVarBndrs,+        substVarBndr, substVarBndrs,+        substTyVarBndr, substTyVarBndrs,+        substCoVarBndr,+        substTyVar, substTyVars, substTyCoVars,+        substForAllCoBndr,+        substVarBndrUsing, substForAllCoBndrUsing,+        checkValidSubst, isValidTCvSubst,+  ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-} GHC.Core.Type+   ( mkCastTy, mkAppTy, isCoercionTy )+import {-# SOURCE #-} GHC.Core.Coercion+   ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo+   , mkNomReflCo, mkSubCo, mkSymCo+   , mkFunCo, mkForAllCo, mkUnivCo+   , mkAxiomInstCo, mkAppCo, mkGReflCo+   , mkInstCo, mkLRCo, mkTyConAppCo+   , mkCoercionType+   , coercionKind, coercionLKind, coVarKindsTypesRole )++import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.FVs+import GHC.Core.TyCo.Ppr++import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env++import Pair+import Util+import GHC.Types.Unique.Supply+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import Outputable++import Data.List (mapAccumL)++{-+%************************************************************************+%*                                                                      *+                        Substitutions+      Data type defined here to avoid unnecessary mutual recursion+%*                                                                      *+%************************************************************************+-}++-- | Type & coercion substitution+--+-- #tcvsubst_invariant#+-- The following invariants must hold of a 'TCvSubst':+--+-- 1. The in-scope set is needed /only/ to+-- guide the generation of fresh uniques+--+-- 2. In particular, the /kind/ of the type variables in+-- the in-scope set is not relevant+--+-- 3. The substitution is only applied ONCE! This is because+-- in general such application will not reach a fixed point.+data TCvSubst+  = TCvSubst InScopeSet -- The in-scope type and kind variables+             TvSubstEnv -- Substitutes both type and kind variables+             CvSubstEnv -- Substitutes coercion variables+        -- See Note [Substitutions apply only once]+        -- and Note [Extending the TvSubstEnv]+        -- and Note [Substituting types and coercions]+        -- and Note [The substitution invariant]++-- | A substitution of 'Type's for 'TyVar's+--                 and 'Kind's for 'KindVar's+type TvSubstEnv = TyVarEnv Type+  -- NB: A TvSubstEnv is used+  --   both inside a TCvSubst (with the apply-once invariant+  --        discussed in Note [Substitutions apply only once],+  --   and  also independently in the middle of matching,+  --        and unification (see Types.Unify).+  -- So you have to look at the context to know if it's idempotent or+  -- apply-once or whatever++-- | A substitution of 'Coercion's for 'CoVar's+type CvSubstEnv = CoVarEnv Coercion++{- Note [The substitution invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When calling (substTy subst ty) it should be the case that+the in-scope set in the substitution is a superset of both:++  (SIa) The free vars of the range of the substitution+  (SIb) The free vars of ty minus the domain of the substitution++The same rules apply to other substitutions (notably GHC.Core.Subst.Subst)++* Reason for (SIa). Consider+      substTy [a :-> Maybe b] (forall b. b->a)+  we must rename the forall b, to get+      forall b2. b2 -> Maybe b+  Making 'b' part of the in-scope set forces this renaming to+  take place.++* Reason for (SIb). Consider+     substTy [a :-> Maybe b] (forall b. (a,b,x))+  Then if we use the in-scope set {b}, satisfying (SIa), there is+  a danger we will rename the forall'd variable to 'x' by mistake,+  getting this:+      forall x. (Maybe b, x, x)+  Breaking (SIb) caused the bug from #11371.++Note: if the free vars of the range of the substitution are freshly created,+then the problems of (SIa) can't happen, and so it would be sound to+ignore (SIa).++Note [Substitutions apply only once]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use TCvSubsts to instantiate things, and we might instantiate+        forall a b. ty+with the types+        [a, b], or [b, a].+So the substitution might go [a->b, b->a].  A similar situation arises in Core+when we find a beta redex like+        (/\ a /\ b -> e) b a+Then we also end up with a substitution that permutes type variables. Other+variations happen to; for example [a -> (a, b)].++        ********************************************************+        *** So a substitution must be applied precisely once ***+        ********************************************************++A TCvSubst is not idempotent, but, unlike the non-idempotent substitution+we use during unifications, it must not be repeatedly applied.++Note [Extending the TvSubstEnv]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See #tcvsubst_invariant# for the invariants that must hold.++This invariant allows a short-cut when the subst envs are empty:+if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst)+holds --- then (substTy subst ty) does nothing.++For example, consider:+        (/\a. /\b:(a~Int). ...b..) Int+We substitute Int for 'a'.  The Unique of 'b' does not change, but+nevertheless we add 'b' to the TvSubstEnv, because b's kind does change++This invariant has several crucial consequences:++* In substVarBndr, we need extend the TvSubstEnv+        - if the unique has changed+        - or if the kind has changed++* In substTyVar, we do not need to consult the in-scope set;+  the TvSubstEnv is enough++* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty++Note [Substituting types and coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Types and coercions are mutually recursive, and either may have variables+"belonging" to the other. Thus, every time we wish to substitute in a+type, we may also need to substitute in a coercion, and vice versa.+However, the constructor used to create type variables is distinct from+that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note+that it would be possible to use the CoercionTy constructor to combine+these environments, but that seems like a false economy.++Note that the TvSubstEnv should *never* map a CoVar (built with the Id+constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore,+the range of the TvSubstEnv should *never* include a type headed with+CoercionTy.+-}++emptyTvSubstEnv :: TvSubstEnv+emptyTvSubstEnv = emptyVarEnv++emptyCvSubstEnv :: CvSubstEnv+emptyCvSubstEnv = emptyVarEnv++composeTCvSubstEnv :: InScopeSet+                   -> (TvSubstEnv, CvSubstEnv)+                   -> (TvSubstEnv, CvSubstEnv)+                   -> (TvSubstEnv, CvSubstEnv)+-- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@.+-- It assumes that both are idempotent.+-- Typically, @env1@ is the refinement to a base substitution @env2@+composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2)+  = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2+    , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 )+        -- First apply env1 to the range of env2+        -- Then combine the two, making sure that env1 loses if+        -- both bind the same variable; that's why env1 is the+        --  *left* argument to plusVarEnv, because the right arg wins+  where+    subst1 = TCvSubst in_scope tenv1 cenv1++-- | Composes two substitutions, applying the second one provided first,+-- like in function composition.+composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst+composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2)+  = TCvSubst is3 tenv3 cenv3+  where+    is3 = is1 `unionInScope` is2+    (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2)++emptyTCvSubst :: TCvSubst+emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv++mkEmptyTCvSubst :: InScopeSet -> TCvSubst+mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv++isEmptyTCvSubst :: TCvSubst -> Bool+         -- See Note [Extending the TvSubstEnv]+isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv++mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst+mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv++mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst+-- ^ Make a TCvSubst with specified tyvar subst and empty covar subst+mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv++mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst+-- ^ Make a TCvSubst with specified covar subst and empty tyvar subst+mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv++getTvSubstEnv :: TCvSubst -> TvSubstEnv+getTvSubstEnv (TCvSubst _ env _) = env++getCvSubstEnv :: TCvSubst -> CvSubstEnv+getCvSubstEnv (TCvSubst _ _ env) = env++getTCvInScope :: TCvSubst -> InScopeSet+getTCvInScope (TCvSubst in_scope _ _) = in_scope++-- | Returns the free variables of the types in the range of a substitution as+-- a non-deterministic set.+getTCvSubstRangeFVs :: TCvSubst -> VarSet+getTCvSubstRangeFVs (TCvSubst _ tenv cenv)+    = unionVarSet tenvFVs cenvFVs+  where+    tenvFVs = shallowTyCoVarsOfTyVarEnv tenv+    cenvFVs = shallowTyCoVarsOfCoVarEnv cenv++isInScope :: Var -> TCvSubst -> Bool+isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope++notElemTCvSubst :: Var -> TCvSubst -> Bool+notElemTCvSubst v (TCvSubst _ tenv cenv)+  | isTyVar v+  = not (v `elemVarEnv` tenv)+  | otherwise+  = not (v `elemVarEnv` cenv)++setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst+setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv++setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst+setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv++zapTCvSubst :: TCvSubst -> TCvSubst+zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv++extendTCvInScope :: TCvSubst -> Var -> TCvSubst+extendTCvInScope (TCvSubst in_scope tenv cenv) var+  = TCvSubst (extendInScopeSet in_scope var) tenv cenv++extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst+extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars+  = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv++extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst+extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars+  = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv++extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst+extendTCvSubst subst v ty+  | isTyVar v+  = extendTvSubst subst v ty+  | CoercionTy co <- ty+  = extendCvSubst subst v co+  | otherwise+  = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty)++extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst+extendTCvSubstWithClone subst tcv+  | isTyVar tcv = extendTvSubstWithClone subst tcv+  | otherwise   = extendCvSubstWithClone subst tcv++extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst+extendTvSubst (TCvSubst in_scope tenv cenv) tv ty+  = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv++extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst+extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty+  = ASSERT( isTyVar v )+    extendTvSubstAndInScope subst v ty+extendTvSubstBinderAndInScope subst (Anon {}) _+  = subst++extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst+-- Adds a new tv -> tv mapping, /and/ extends the in-scope set+extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv'+  = TCvSubst (extendInScopeSetSet in_scope new_in_scope)+             (extendVarEnv tenv tv (mkTyVarTy tv'))+             cenv+  where+    new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv'++extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst+extendCvSubst (TCvSubst in_scope tenv cenv) v co+  = TCvSubst in_scope tenv (extendVarEnv cenv v co)++extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst+extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv'+  = TCvSubst (extendInScopeSetSet in_scope new_in_scope)+             tenv+             (extendVarEnv cenv cv (mkCoVarCo cv'))+  where+    new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv'++extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst+-- Also extends the in-scope set+extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty+  = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty)+             (extendVarEnv tenv tv ty)+             cenv++extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst+extendTvSubstList subst tvs tys+  = foldl2 extendTvSubst subst tvs tys++extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst+extendTCvSubstList subst tvs tys+  = foldl2 extendTCvSubst subst tvs tys++unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst+-- Works when the ranges are disjoint+unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2)+  = ASSERT( not (tenv1 `intersectsVarEnv` tenv2)+         && not (cenv1 `intersectsVarEnv` cenv2) )+    TCvSubst (in_scope1 `unionInScope` in_scope2)+             (tenv1     `plusVarEnv`   tenv2)+             (cenv1     `plusVarEnv`   cenv2)++-- mkTvSubstPrs and zipTvSubst generate the in-scope set from+-- the types given; but it's just a thunk so with a bit of luck+-- it'll never be evaluated++-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming+-- environment. No CoVars, please!+zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst+zipTvSubst tvs tys+  = mkTvSubst (mkInScopeSet (shallowTyCoVarsOfTypes tys)) tenv+  where+    tenv = zipTyEnv tvs tys++-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming+-- environment.  No TyVars, please!+zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst+zipCvSubst cvs cos+  = TCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) emptyTvSubstEnv cenv+  where+    cenv = zipCoEnv cvs cos++zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst+zipTCvSubst tcvs tys+  = zip_tcvsubst tcvs tys $+    mkEmptyTCvSubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys+  where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst+        zip_tcvsubst (tv:tvs) (ty:tys) subst+          = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty)+        zip_tcvsubst [] [] subst = subst -- empty case+        zip_tcvsubst _  _  _     = pprPanic "zipTCvSubst: length mismatch"+                                            (ppr tcvs <+> ppr tys)++-- | Generates the in-scope set for the 'TCvSubst' from the types in the+-- incoming environment. No CoVars, please!+mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst+mkTvSubstPrs prs =+    ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs )+    mkTvSubst in_scope tenv+  where tenv = mkVarEnv prs+        in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ map snd prs+        onlyTyVarsAndNoCoercionTy =+          and [ isTyVar tv && not (isCoercionTy ty)+              | (tv, ty) <- prs ]++zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv+zipTyEnv tyvars tys+  | debugIsOn+  , not (all isTyVar tyvars)+  = pprPanic "zipTyEnv" (ppr tyvars <+> ppr tys)+  | otherwise+  = ASSERT( all (not . isCoercionTy) tys )+    mkVarEnv (zipEqual "zipTyEnv" tyvars tys)+        -- There used to be a special case for when+        --      ty == TyVarTy tv+        -- (a not-uncommon case) in which case the substitution was dropped.+        -- But the type-tidier changes the print-name of a type variable without+        -- changing the unique, and that led to a bug.   Why?  Pre-tidying, we had+        -- a type {Foo t}, where Foo is a one-method class.  So Foo is really a newtype.+        -- And it happened that t was the type variable of the class.  Post-tiding,+        -- it got turned into {Foo t2}.  The ext-core printer expanded this using+        -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique,+        -- and so generated a rep type mentioning t not t2.+        --+        -- Simplest fix is to nuke the "optimisation"++zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv+zipCoEnv cvs cos+  | debugIsOn+  , not (all isCoVar cvs)+  = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos)+  | otherwise+  = mkVarEnv (zipEqual "zipCoEnv" cvs cos)++instance Outputable TCvSubst where+  ppr (TCvSubst ins tenv cenv)+    = brackets $ sep[ text "TCvSubst",+                      nest 2 (text "In scope:" <+> ppr ins),+                      nest 2 (text "Type env:" <+> ppr tenv),+                      nest 2 (text "Co env:" <+> ppr cenv) ]++{-+%************************************************************************+%*                                                                      *+                Performing type or kind substitutions+%*                                                                      *+%************************************************************************++Note [Sym and ForAllCo]+~~~~~~~~~~~~~~~~~~~~~~~+In OptCoercion, we try to push "sym" out to the leaves of a coercion. But,+how do we push sym into a ForAllCo? It's a little ugly.++Here is the typing rule:++h : k1 ~# k2+(tv : k1) |- g : ty1 ~# ty2+----------------------------+ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~#+                  (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h]))++Here is what we want:++ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~#+                    (ForAllTy (tv : k1) ty1)+++Because the kinds of the type variables to the right of the colon are the kinds+coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h).++Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want++ForAllCo tv h' g' :+  (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~#+  (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h']))++We thus see that we want++g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h']++and thus g' = sym (g[tv |-> tv |> h']).++Putting it all together, we get this:++sym (ForAllCo tv h g)+==>+ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h])++Note [Substituting in a coercion hole]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It seems highly suspicious to be substituting in a coercion that still+has coercion holes. Yet, this can happen in a situation like this:++  f :: forall k. k :~: Type -> ()+  f Refl = let x :: forall (a :: k). [a] -> ...+               x = ...++When we check x's type signature, we require that k ~ Type. We indeed+know this due to the Refl pattern match, but the eager unifier can't+make use of givens. So, when we're done looking at x's type, a coercion+hole will remain. Then, when we're checking x's definition, we skolemise+x's type (in order to, e.g., bring the scoped type variable `a` into scope).+This requires performing a substitution for the fresh skolem variables.++This substitution needs to affect the kind of the coercion hole, too --+otherwise, the kind will have an out-of-scope variable in it. More problematically+in practice (we won't actually notice the out-of-scope variable ever), skolems+in the kind might have too high a level, triggering a failure to uphold the+invariant that no free variables in a type have a higher level than the+ambient level in the type checker. In the event of having free variables in the+hole's kind, I'm pretty sure we'll always have an erroneous program, so we+don't need to worry what will happen when the hole gets filled in. After all,+a hole relating a locally-bound type variable will be unable to be solved. This+is why it's OK not to look through the IORef of a coercion hole during+substitution.++-}++-- | Type substitution, see 'zipTvSubst'+substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type+-- Works only if the domain of the substitution is a+-- superset of the type being substituted into+substTyWith tvs tys = {-#SCC "substTyWith" #-}+                      ASSERT( tvs `equalLength` tys )+                      substTy (zipTvSubst tvs tys)++-- | Type substitution, see 'zipTvSubst'. Disables sanity checks.+-- The problems that the sanity checks in substTy catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substTyUnchecked to+-- substTy and remove this function. Please don't use in new code.+substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type+substTyWithUnchecked tvs tys+  = ASSERT( tvs `equalLength` tys )+    substTyUnchecked (zipTvSubst tvs tys)++-- | Substitute tyvars within a type using a known 'InScopeSet'.+-- Pre-condition: the 'in_scope' set should satisfy Note [The substitution+-- invariant]; specifically it should include the free vars of 'tys',+-- and of 'ty' minus the domain of the subst.+substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type+substTyWithInScope in_scope tvs tys ty =+  ASSERT( tvs `equalLength` tys )+  substTy (mkTvSubst in_scope tenv) ty+  where tenv = zipTyEnv tvs tys++-- | Coercion substitution, see 'zipTvSubst'+substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion+substCoWith tvs tys = ASSERT( tvs `equalLength` tys )+                      substCo (zipTvSubst tvs tys)++-- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks.+-- The problems that the sanity checks in substCo catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substCoUnchecked to+-- substCo and remove this function. Please don't use in new code.+substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion+substCoWithUnchecked tvs tys+  = ASSERT( tvs `equalLength` tys )+    substCoUnchecked (zipTvSubst tvs tys)++++-- | Substitute covars within a type+substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type+substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos)++-- | Type substitution, see 'zipTvSubst'+substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]+substTysWith tvs tys = ASSERT( tvs `equalLength` tys )+                       substTys (zipTvSubst tvs tys)++-- | Type substitution, see 'zipTvSubst'+substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type]+substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos )+                             substTys (zipCvSubst cvs cos)++-- | Substitute within a 'Type' after adding the free variables of the type+-- to the in-scope set. This is useful for the case when the free variables+-- aren't already in the in-scope set or easily available.+-- See also Note [The substitution invariant].+substTyAddInScope :: TCvSubst -> Type -> Type+substTyAddInScope subst ty =+  substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty++-- | When calling `substTy` it should be the case that the in-scope set in+-- the substitution is a superset of the free vars of the range of the+-- substitution.+-- See also Note [The substitution invariant].+isValidTCvSubst :: TCvSubst -> Bool+isValidTCvSubst (TCvSubst in_scope tenv cenv) =+  (tenvFVs `varSetInScope` in_scope) &&+  (cenvFVs `varSetInScope` in_scope)+  where+  tenvFVs = shallowTyCoVarsOfTyVarEnv tenv+  cenvFVs = shallowTyCoVarsOfCoVarEnv cenv++-- | This checks if the substitution satisfies the invariant from+-- Note [The substitution invariant].+checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a+checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a+  = ASSERT2( isValidTCvSubst subst,+             text "in_scope" <+> ppr in_scope $$+             text "tenv" <+> ppr tenv $$+             text "tenvFVs" <+> ppr (shallowTyCoVarsOfTyVarEnv tenv) $$+             text "cenv" <+> ppr cenv $$+             text "cenvFVs" <+> ppr (shallowTyCoVarsOfCoVarEnv cenv) $$+             text "tys" <+> ppr tys $$+             text "cos" <+> ppr cos )+    ASSERT2( tysCosFVsInScope,+             text "in_scope" <+> ppr in_scope $$+             text "tenv" <+> ppr tenv $$+             text "cenv" <+> ppr cenv $$+             text "tys" <+> ppr tys $$+             text "cos" <+> ppr cos $$+             text "needInScope" <+> ppr needInScope )+    a+  where+  substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv+    -- It's OK to use nonDetKeysUFM here, because we only use this list to+    -- remove some elements from a set+  needInScope = (shallowTyCoVarsOfTypes tys `unionVarSet`+                 shallowTyCoVarsOfCos cos)+                `delListFromUniqSet_Directly` substDomain+  tysCosFVsInScope = needInScope `varSetInScope` in_scope+++-- | Substitute within a 'Type'+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substTy :: HasCallStack => TCvSubst -> Type  -> Type+substTy subst ty+  | isEmptyTCvSubst subst = ty+  | otherwise             = checkValidSubst subst [ty] [] $+                            subst_ty subst ty++-- | Substitute within a 'Type' disabling the sanity checks.+-- The problems that the sanity checks in substTy catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substTyUnchecked to+-- substTy and remove this function. Please don't use in new code.+substTyUnchecked :: TCvSubst -> Type -> Type+substTyUnchecked subst ty+                 | isEmptyTCvSubst subst = ty+                 | otherwise             = subst_ty subst ty++-- | Substitute within several 'Type's+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substTys :: HasCallStack => TCvSubst -> [Type] -> [Type]+substTys subst tys+  | isEmptyTCvSubst subst = tys+  | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys++-- | Substitute within several 'Type's disabling the sanity checks.+-- The problems that the sanity checks in substTys catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substTysUnchecked to+-- substTys and remove this function. Please don't use in new code.+substTysUnchecked :: TCvSubst -> [Type] -> [Type]+substTysUnchecked subst tys+                 | isEmptyTCvSubst subst = tys+                 | otherwise             = map (subst_ty subst) tys++-- | Substitute within a 'ThetaType'+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType+substTheta = substTys++-- | Substitute within a 'ThetaType' disabling the sanity checks.+-- The problems that the sanity checks in substTys catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substThetaUnchecked to+-- substTheta and remove this function. Please don't use in new code.+substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType+substThetaUnchecked = substTysUnchecked+++subst_ty :: TCvSubst -> Type -> Type+-- subst_ty is the main workhorse for type substitution+--+-- Note that the in_scope set is poked only if we hit a forall+-- so it may often never be fully computed+subst_ty subst ty+   = go ty+  where+    go (TyVarTy tv)      = substTyVar subst tv+    go (AppTy fun arg)   = mkAppTy (go fun) $! (go arg)+                -- The mkAppTy smart constructor is important+                -- we might be replacing (a Int), represented with App+                -- by [Int], represented with TyConApp+    go (TyConApp tc tys) = let args = map go tys+                           in  args `seqList` TyConApp tc args+    go ty@(FunTy { ft_arg = arg, ft_res = res })+      = let !arg' = go arg+            !res' = go res+        in ty { ft_arg = arg', ft_res = res' }+    go (ForAllTy (Bndr tv vis) ty)+                         = case substVarBndrUnchecked subst tv of+                             (subst', tv') ->+                               (ForAllTy $! ((Bndr $! tv') vis)) $!+                                            (subst_ty subst' ty)+    go (LitTy n)         = LitTy $! n+    go (CastTy ty co)    = (mkCastTy $! (go ty)) $! (subst_co subst co)+    go (CoercionTy co)   = CoercionTy $! (subst_co subst co)++substTyVar :: TCvSubst -> TyVar -> Type+substTyVar (TCvSubst _ tenv _) tv+  = ASSERT( isTyVar tv )+    case lookupVarEnv tenv tv of+      Just ty -> ty+      Nothing -> TyVarTy tv++substTyVars :: TCvSubst -> [TyVar] -> [Type]+substTyVars subst = map $ substTyVar subst++substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type]+substTyCoVars subst = map $ substTyCoVar subst++substTyCoVar :: TCvSubst -> TyCoVar -> Type+substTyCoVar subst tv+  | isTyVar tv = substTyVar subst tv+  | otherwise = CoercionTy $ substCoVar subst tv++lookupTyVar :: TCvSubst -> TyVar  -> Maybe Type+        -- See Note [Extending the TCvSubst]+lookupTyVar (TCvSubst _ tenv _) tv+  = ASSERT( isTyVar tv )+    lookupVarEnv tenv tv++-- | Substitute within a 'Coercion'+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion+substCo subst co+  | isEmptyTCvSubst subst = co+  | otherwise = checkValidSubst subst [] [co] $ subst_co subst co++-- | Substitute within a 'Coercion' disabling sanity checks.+-- The problems that the sanity checks in substCo catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substCoUnchecked to+-- substCo and remove this function. Please don't use in new code.+substCoUnchecked :: TCvSubst -> Coercion -> Coercion+substCoUnchecked subst co+  | isEmptyTCvSubst subst = co+  | otherwise = subst_co subst co++-- | Substitute within several 'Coercion's+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion]+substCos subst cos+  | isEmptyTCvSubst subst = cos+  | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos++subst_co :: TCvSubst -> Coercion -> Coercion+subst_co subst co+  = go co+  where+    go_ty :: Type -> Type+    go_ty = subst_ty subst++    go_mco :: MCoercion -> MCoercion+    go_mco MRefl    = MRefl+    go_mco (MCo co) = MCo (go co)++    go :: Coercion -> Coercion+    go (Refl ty)             = mkNomReflCo $! (go_ty ty)+    go (GRefl r ty mco)      = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco)+    go (TyConAppCo r tc args)= let args' = map go args+                               in  args' `seqList` mkTyConAppCo r tc args'+    go (AppCo co arg)        = (mkAppCo $! go co) $! go arg+    go (ForAllCo tv kind_co co)+      = case substForAllCoBndrUnchecked subst tv kind_co of+         (subst', tv', kind_co') ->+          ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co+    go (FunCo r co1 co2)     = (mkFunCo r $! go co1) $! go co2+    go (CoVarCo cv)          = substCoVar subst cv+    go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos+    go (UnivCo p r t1 t2)    = (((mkUnivCo $! go_prov p) $! r) $!+                                (go_ty t1)) $! (go_ty t2)+    go (SymCo co)            = mkSymCo $! (go co)+    go (TransCo co1 co2)     = (mkTransCo $! (go co1)) $! (go co2)+    go (NthCo r d co)        = mkNthCo r d $! (go co)+    go (LRCo lr co)          = mkLRCo lr $! (go co)+    go (InstCo co arg)       = (mkInstCo $! (go co)) $! go arg+    go (KindCo co)           = mkKindCo $! (go co)+    go (SubCo co)            = mkSubCo $! (go co)+    go (AxiomRuleCo c cs)    = let cs1 = map go cs+                                in cs1 `seqList` AxiomRuleCo c cs1+    go (HoleCo h)            = HoleCo $! go_hole h++    go_prov (PhantomProv kco)    = PhantomProv (go kco)+    go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco)+    go_prov p@(PluginProv _)     = p++    -- See Note [Substituting in a coercion hole]+    go_hole h@(CoercionHole { ch_co_var = cv })+      = h { ch_co_var = updateVarType go_ty cv }++substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion+                  -> (TCvSubst, TyCoVar, Coercion)+substForAllCoBndr subst+  = substForAllCoBndrUsing False (substCo subst) subst++-- | Like 'substForAllCoBndr', but disables sanity checks.+-- The problems that the sanity checks in substCo catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substCoUnchecked to+-- substCo and remove this function. Please don't use in new code.+substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion+                           -> (TCvSubst, TyCoVar, Coercion)+substForAllCoBndrUnchecked subst+  = substForAllCoBndrUsing False (substCoUnchecked subst) subst++-- See Note [Sym and ForAllCo]+substForAllCoBndrUsing :: Bool  -- apply sym to binder?+                       -> (Coercion -> Coercion)  -- transformation to kind co+                       -> TCvSubst -> TyCoVar -> KindCoercion+                       -> (TCvSubst, TyCoVar, KindCoercion)+substForAllCoBndrUsing sym sco subst old_var+  | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var+  | otherwise       = substForAllCoCoVarBndrUsing sym sco subst old_var++substForAllCoTyVarBndrUsing :: Bool  -- apply sym to binder?+                            -> (Coercion -> Coercion)  -- transformation to kind co+                            -> TCvSubst -> TyVar -> KindCoercion+                            -> (TCvSubst, TyVar, KindCoercion)+substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co+  = ASSERT( isTyVar old_var )+    ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv+    , new_var, new_kind_co )+  where+    new_env | no_change && not sym = delVarEnv tenv old_var+            | sym       = extendVarEnv tenv old_var $+                          TyVarTy new_var `CastTy` new_kind_co+            | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)++    no_kind_change = noFreeVarsOfCo old_kind_co+    no_change = no_kind_change && (new_var == old_var)++    new_kind_co | no_kind_change = old_kind_co+                | otherwise      = sco old_kind_co++    new_ki1 = coercionLKind new_kind_co+    -- We could do substitution to (tyVarKind old_var). We don't do so because+    -- we already substituted new_kind_co, which contains the kind information+    -- we want. We don't want to do substitution once more. Also, in most cases,+    -- new_kind_co is a Refl, in which case coercionKind is really fast.++    new_var  = uniqAway in_scope (setTyVarKind old_var new_ki1)++substForAllCoCoVarBndrUsing :: Bool  -- apply sym to binder?+                            -> (Coercion -> Coercion)  -- transformation to kind co+                            -> TCvSubst -> CoVar -> KindCoercion+                            -> (TCvSubst, CoVar, KindCoercion)+substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv)+                            old_var old_kind_co+  = ASSERT( isCoVar old_var )+    ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv+    , new_var, new_kind_co )+  where+    new_cenv | no_change && not sym = delVarEnv cenv old_var+             | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var)++    no_kind_change = noFreeVarsOfCo old_kind_co+    no_change = no_kind_change && (new_var == old_var)++    new_kind_co | no_kind_change = old_kind_co+                | otherwise      = sco old_kind_co++    Pair h1 h2 = coercionKind new_kind_co++    new_var       = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type+    new_var_type  | sym       = h2+                  | otherwise = h1++substCoVar :: TCvSubst -> CoVar -> Coercion+substCoVar (TCvSubst _ _ cenv) cv+  = case lookupVarEnv cenv cv of+      Just co -> co+      Nothing -> CoVarCo cv++substCoVars :: TCvSubst -> [CoVar] -> [Coercion]+substCoVars subst cvs = map (substCoVar subst) cvs++lookupCoVar :: TCvSubst -> Var -> Maybe Coercion+lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v++substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar)+substTyVarBndr = substTyVarBndrUsing substTy++substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])+substTyVarBndrs = mapAccumL substTyVarBndr++substVarBndr :: HasCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar)+substVarBndr = substVarBndrUsing substTy++substVarBndrs :: HasCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar])+substVarBndrs = mapAccumL substVarBndr++substCoVarBndr :: HasCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar)+substCoVarBndr = substCoVarBndrUsing substTy++-- | Like 'substVarBndr', but disables sanity checks.+-- The problems that the sanity checks in substTy catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substTyUnchecked to+-- substTy and remove this function. Please don't use in new code.+substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar)+substVarBndrUnchecked = substVarBndrUsing substTyUnchecked++substVarBndrUsing :: (TCvSubst -> Type -> Type)+                  -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar)+substVarBndrUsing subst_fn subst v+  | isTyVar v = substTyVarBndrUsing subst_fn subst v+  | otherwise = substCoVarBndrUsing subst_fn subst v++-- | Substitute a tyvar in a binding position, returning an+-- extended subst and a new tyvar.+-- Use the supplied function to substitute in the kind+substTyVarBndrUsing+  :: (TCvSubst -> Type -> Type)  -- ^ Use this to substitute in the kind+  -> TCvSubst -> TyVar -> (TCvSubst, TyVar)+substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var+  = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst )+    ASSERT( isTyVar old_var )+    (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var)+  where+    new_env | no_change = delVarEnv tenv old_var+            | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)++    _no_capture = not (new_var `elemVarSet` shallowTyCoVarsOfTyVarEnv tenv)+    -- Assertion check that we are not capturing something in the substitution++    old_ki = tyVarKind old_var+    no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed+    no_change = no_kind_change && (new_var == old_var)+        -- no_change means that the new_var is identical in+        -- all respects to the old_var (same unique, same kind)+        -- See Note [Extending the TCvSubst]+        --+        -- In that case we don't need to extend the substitution+        -- to map old to new.  But instead we must zap any+        -- current substitution for the variable. For example:+        --      (\x.e) with id_subst = [x |-> e']+        -- Here we must simply zap the substitution for x++    new_var | no_kind_change = uniqAway in_scope old_var+            | otherwise = uniqAway in_scope $+                          setTyVarKind old_var (subst_fn subst old_ki)+        -- The uniqAway part makes sure the new variable is not already in scope++-- | Substitute a covar in a binding position, returning an+-- extended subst and a new covar.+-- Use the supplied function to substitute in the kind+substCoVarBndrUsing+  :: (TCvSubst -> Type -> Type)+  -> TCvSubst -> CoVar -> (TCvSubst, CoVar)+substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var+  = ASSERT( isCoVar old_var )+    (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var)+  where+    new_co         = mkCoVarCo new_var+    no_kind_change = noFreeVarsOfTypes [t1, t2]+    no_change      = new_var == old_var && no_kind_change++    new_cenv | no_change = delVarEnv cenv old_var+             | otherwise = extendVarEnv cenv old_var new_co++    new_var = uniqAway in_scope subst_old_var+    subst_old_var = mkCoVar (varName old_var) new_var_type++    (_, _, t1, t2, role) = coVarKindsTypesRole old_var+    t1' = subst_fn subst t1+    t2' = subst_fn subst t2+    new_var_type = mkCoercionType role t1' t2'+                  -- It's important to do the substitution for coercions,+                  -- because they can have free type variables++cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar)+cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq+  = ASSERT2( isTyVar tv, ppr tv )   -- I think it's only called on TyVars+    (TCvSubst (extendInScopeSet in_scope tv')+              (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv')+  where+    old_ki = tyVarKind tv+    no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed++    tv1 | no_kind_change = tv+        | otherwise      = setTyVarKind tv (substTy subst old_ki)++    tv' = setVarUnique tv1 uniq++cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar])+cloneTyVarBndrs subst []     _usupply = (subst, [])+cloneTyVarBndrs subst (t:ts)  usupply = (subst'', tv:tvs)+  where+    (uniq, usupply') = takeUniqFromSupply usupply+    (subst' , tv )   = cloneTyVarBndr subst t uniq+    (subst'', tvs)   = cloneTyVarBndrs subst' ts usupply'
+ compiler/GHC/Core/TyCo/Tidy.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}++-- | Tidying types and coercions for printing in error messages.+module GHC.Core.TyCo.Tidy+  (+        -- * Tidying type related things up for printing+        tidyType,      tidyTypes,+        tidyOpenType,  tidyOpenTypes,+        tidyOpenKind,+        tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes,+        tidyOpenTyCoVar, tidyOpenTyCoVars,+        tidyTyCoVarOcc,+        tidyTopType,+        tidyKind,+        tidyCo, tidyCos,+        tidyTyCoVarBinder, tidyTyCoVarBinders+  ) where++import GhcPrelude++import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.FVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList)++import GHC.Types.Name hiding (varName)+import GHC.Types.Var+import GHC.Types.Var.Env+import Util (seqList)++import Data.List (mapAccumL)++{-+%************************************************************************+%*                                                                      *+\subsection{TidyType}+%*                                                                      *+%************************************************************************+-}++-- | This tidies up a type for printing in an error message, or in+-- an interface file.+--+-- It doesn't change the uniques at all, just the print names.+tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])+tidyVarBndrs tidy_env tvs+  = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs++tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)+tidyVarBndr tidy_env@(occ_env, subst) var+  = case tidyOccName occ_env (getHelpfulOccName var) of+      (occ_env', occ') -> ((occ_env', subst'), var')+        where+          subst' = extendVarEnv subst var var'+          var'   = setVarType (setVarName var name') type'+          type'  = tidyType tidy_env (varType var)+          name'  = tidyNameOcc name occ'+          name   = varName var++avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv+-- Seed the occ_env with clashes among the names, see+-- Note [Tidying multiple names at once] in GHC.Types.Names.OccName+avoidNameClashes tvs (occ_env, subst)+  = (avoidClashesOccEnv occ_env occs, subst)+  where+    occs = map getHelpfulOccName tvs++getHelpfulOccName :: TyCoVar -> OccName+-- A TcTyVar with a System Name is probably a+-- unification variable; when we tidy them we give them a trailing+-- "0" (or 1 etc) so that they don't take precedence for the+-- un-modified name. Plus, indicating a unification variable in+-- this way is a helpful clue for users+getHelpfulOccName tv+  | isSystemName name, isTcTyVar tv+  = mkTyVarOcc (occNameString occ ++ "0")+  | otherwise+  = occ+  where+   name = varName tv+   occ  = getOccName name++tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis+                  -> (TidyEnv, VarBndr TyCoVar vis)+tidyTyCoVarBinder tidy_env (Bndr tv vis)+  = (tidy_env', Bndr tv' vis)+  where+    (tidy_env', tv') = tidyVarBndr tidy_env tv++tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis]+                   -> (TidyEnv, [VarBndr TyCoVar vis])+tidyTyCoVarBinders tidy_env tvbs+  = mapAccumL tidyTyCoVarBinder+              (avoidNameClashes (binderVars tvbs) tidy_env) tvbs++---------------+tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv+-- ^ Add the free 'TyVar's to the env in tidy form,+-- so that we can tidy the type they are free in+tidyFreeTyCoVars tidy_env tyvars+  = fst (tidyOpenTyCoVars tidy_env tyvars)++---------------+tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])+tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars++---------------+tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)+-- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name+-- using the environment if one has not already been allocated. See+-- also 'tidyVarBndr'+tidyOpenTyCoVar env@(_, subst) tyvar+  = case lookupVarEnv subst tyvar of+        Just tyvar' -> (env, tyvar')              -- Already substituted+        Nothing     ->+          let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar))+          in tidyVarBndr env' tyvar  -- Treat it as a binder++---------------+tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar+tidyTyCoVarOcc env@(_, subst) tv+  = case lookupVarEnv subst tv of+        Nothing  -> updateVarType (tidyType env) tv+        Just tv' -> tv'++---------------+tidyTypes :: TidyEnv -> [Type] -> [Type]+tidyTypes env tys = map (tidyType env) tys++---------------+tidyType :: TidyEnv -> Type -> Type+tidyType _   (LitTy n)             = LitTy n+tidyType env (TyVarTy tv)          = TyVarTy (tidyTyCoVarOcc env tv)+tidyType env (TyConApp tycon tys)  = let args = tidyTypes env tys+                                     in args `seqList` TyConApp tycon args+tidyType env (AppTy fun arg)       = (AppTy $! (tidyType env fun)) $! (tidyType env arg)+tidyType env ty@(FunTy _ arg res)  = let { !arg' = tidyType env arg+                                         ; !res' = tidyType env res }+                                     in ty { ft_arg = arg', ft_res = res' }+tidyType env (ty@(ForAllTy{}))     = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty+  where+    (tvs, vis, body_ty) = splitForAllTys' ty+    (env', tvs') = tidyVarBndrs env tvs+tidyType env (CastTy ty co)       = (CastTy $! tidyType env ty) $! (tidyCo env co)+tidyType env (CoercionTy co)      = CoercionTy $! (tidyCo env co)+++-- The following two functions differ from mkForAllTys and splitForAllTys in that+-- they expect/preserve the ArgFlag argument. These belong to types/Type.hs, but+-- how should they be named?+mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type+mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs+  where+    strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty++splitForAllTys' :: Type -> ([TyCoVar], [ArgFlag], Type)+splitForAllTys' ty = go ty [] []+  where+    go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss)+    go ty                          tvs viss = (reverse tvs, reverse viss, ty)+++---------------+-- | Grabs the free type variables, tidies them+-- and then uses 'tidyType' to work over the type itself+tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])+tidyOpenTypes env tys+  = (env', tidyTypes (trimmed_occ_env, var_env) tys)+  where+    (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $+                                tyCoVarsOfTypesWellScoped tys+    trimmed_occ_env = initTidyOccEnv (map getOccName tvs')+      -- The idea here was that we restrict the new TidyEnv to the+      -- _free_ vars of the types, so that we don't gratuitously rename+      -- the _bound_ variables of the types.++---------------+tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)+tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in+                      (env', ty')++---------------+-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment)+tidyTopType :: Type -> Type+tidyTopType ty = tidyType emptyTidyEnv ty++---------------+tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind)+tidyOpenKind = tidyOpenType++tidyKind :: TidyEnv -> Kind -> Kind+tidyKind = tidyType++----------------+tidyCo :: TidyEnv -> Coercion -> Coercion+tidyCo env@(_, subst) co+  = go co+  where+    go_mco MRefl    = MRefl+    go_mco (MCo co) = MCo (go co)++    go (Refl ty)             = Refl (tidyType env ty)+    go (GRefl r ty mco)      = GRefl r (tidyType env ty) $! go_mco mco+    go (TyConAppCo r tc cos) = let args = map go cos+                               in args `seqList` TyConAppCo r tc args+    go (AppCo co1 co2)       = (AppCo $! go co1) $! go co2+    go (ForAllCo tv h co)    = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co)+                               where (envp, tvp) = tidyVarBndr env tv+            -- the case above duplicates a bit of work in tidying h and the kind+            -- of tv. But the alternative is to use coercionKind, which seems worse.+    go (FunCo r co1 co2)     = (FunCo r $! go co1) $! go co2+    go (CoVarCo cv)          = case lookupVarEnv subst cv of+                                 Nothing  -> CoVarCo cv+                                 Just cv' -> CoVarCo cv'+    go (HoleCo h)            = HoleCo h+    go (AxiomInstCo con ind cos) = let args = map go cos+                               in  args `seqList` AxiomInstCo con ind args+    go (UnivCo p r t1 t2)    = (((UnivCo $! (go_prov p)) $! r) $!+                                tidyType env t1) $! tidyType env t2+    go (SymCo co)            = SymCo $! go co+    go (TransCo co1 co2)     = (TransCo $! go co1) $! go co2+    go (NthCo r d co)        = NthCo r d $! go co+    go (LRCo lr co)          = LRCo lr $! go co+    go (InstCo co ty)        = (InstCo $! go co) $! go ty+    go (KindCo co)           = KindCo $! go co+    go (SubCo co)            = SubCo $! go co+    go (AxiomRuleCo ax cos)  = let cos1 = tidyCos env cos+                               in cos1 `seqList` AxiomRuleCo ax cos1++    go_prov (PhantomProv co)    = PhantomProv (go co)+    go_prov (ProofIrrelProv co) = ProofIrrelProv (go co)+    go_prov p@(PluginProv _)    = p++tidyCos :: TidyEnv -> [Coercion] -> [Coercion]+tidyCos env = map (tidyCo env)
+ compiler/GHC/Core/TyCon.hs view
@@ -0,0 +1,2813 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++The @TyCon@ datatype+-}++{-# LANGUAGE CPP, FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}++module GHC.Core.TyCon(+        -- * Main TyCon data types+        TyCon,+        AlgTyConRhs(..), visibleDataCons,+        AlgTyConFlav(..), isNoParent,+        FamTyConFlav(..), Role(..), Injectivity(..),+        RuntimeRepInfo(..), TyConFlavour(..),++        -- * TyConBinder+        TyConBinder, TyConBndrVis(..), TyConTyCoBinder,+        mkNamedTyConBinder, mkNamedTyConBinders,+        mkRequiredTyConBinder,+        mkAnonTyConBinder, mkAnonTyConBinders,+        tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder,+        isVisibleTyConBinder, isInvisibleTyConBinder,++        -- ** Field labels+        tyConFieldLabels, lookupTyConFieldLabel,++        -- ** Constructing TyCons+        mkAlgTyCon,+        mkClassTyCon,+        mkFunTyCon,+        mkPrimTyCon,+        mkKindTyCon,+        mkLiftedPrimTyCon,+        mkTupleTyCon,+        mkSumTyCon,+        mkDataTyConRhs,+        mkSynonymTyCon,+        mkFamilyTyCon,+        mkPromotedDataCon,+        mkTcTyCon,+        noTcTyConScopedTyVars,++        -- ** Predicates on TyCons+        isAlgTyCon, isVanillaAlgTyCon,+        isClassTyCon, isFamInstTyCon,+        isFunTyCon,+        isPrimTyCon,+        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,+        isUnboxedSumTyCon, isPromotedTupleTyCon,+        isTypeSynonymTyCon,+        mustBeSaturated,+        isPromotedDataCon, isPromotedDataCon_maybe,+        isKindTyCon, isLiftedTypeKindTyConName,+        isTauTyCon, isFamFreeTyCon,++        isDataTyCon, isProductTyCon, isDataProductTyCon_maybe,+        isDataSumTyCon_maybe,+        isEnumerationTyCon,+        isNewTyCon, isAbstractTyCon,+        isFamilyTyCon, isOpenFamilyTyCon,+        isTypeFamilyTyCon, isDataFamilyTyCon,+        isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe,+        tyConInjectivityInfo,+        isBuiltInSynFamTyCon_maybe,+        isUnliftedTyCon,+        isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs,+        isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe,+        isImplicitTyCon,+        isTyConWithSrcDataCons,+        isTcTyCon, setTcTyConKind,+        isTcLevPoly,++        -- ** Extracting information out of TyCons+        tyConName,+        tyConSkolem,+        tyConKind,+        tyConUnique,+        tyConTyVars, tyConVisibleTyVars,+        tyConCType, tyConCType_maybe,+        tyConDataCons, tyConDataCons_maybe,+        tyConSingleDataCon_maybe, tyConSingleDataCon,+        tyConSingleAlgDataCon_maybe,+        tyConFamilySize,+        tyConStupidTheta,+        tyConArity,+        tyConRoles,+        tyConFlavour,+        tyConTuple_maybe, tyConClass_maybe, tyConATs,+        tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe,+        tyConFamilyResVar_maybe,+        synTyConDefn_maybe, synTyConRhs_maybe,+        famTyConFlav_maybe, famTcResVar,+        algTyConRhs,+        newTyConRhs, newTyConEtadArity, newTyConEtadRhs,+        unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe,+        newTyConDataCon_maybe,+        algTcFields,+        tyConRuntimeRepInfo,+        tyConBinders, tyConResKind, tyConTyVarBinders,+        tcTyConScopedTyVars, tcTyConIsPoly,+        mkTyConTagMap,++        -- ** Manipulating TyCons+        expandSynTyCon_maybe,+        newTyConCo, newTyConCo_maybe,+        pprPromotionQuote, mkTyConKind,++        -- ** Predicated on TyConFlavours+        tcFlavourIsOpen,++        -- * Runtime type representation+        TyConRepName, tyConRepName_maybe,+        mkPrelTyConRepName,+        tyConRepModOcc,++        -- * Primitive representations of Types+        PrimRep(..), PrimElemRep(..),+        isVoidRep, isGcPtrRep,+        primRepSizeB,+        primElemRepSizeB,+        primRepIsFloat,+        primRepsCompatible,+        primRepCompatible,++        -- * Recursion breaking+        RecTcChecker, initRecTc, defaultRecTcMaxBound,+        setRecTcMaxBound, checkRecTc++) where++#include "HsVersions.h"++import GhcPrelude+import GHC.Platform++import {-# SOURCE #-} GHC.Core.TyCo.Rep+   ( Kind, Type, PredType, mkForAllTy, mkFunTy )+import {-# SOURCE #-} GHC.Core.TyCo.Ppr+   ( pprType )+import {-# SOURCE #-} TysWiredIn+   ( runtimeRepTyCon, constraintKind+   , vecCountTyCon, vecElemTyCon, liftedTypeKind )+import {-# SOURCE #-} GHC.Core.DataCon+   ( DataCon, dataConExTyCoVars, dataConFieldLabels+   , dataConTyCon, dataConFullSig+   , isUnboxedSumCon )++import Binary+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Core.Class+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Core.Coercion.Axiom+import PrelNames+import Maybes+import Outputable+import FastStringEnv+import GHC.Types.FieldLabel+import Constants+import Util+import GHC.Types.Unique( tyConRepNameUnique, dataConTyRepNameUnique )+import GHC.Types.Unique.Set+import GHC.Types.Module++import qualified Data.Data as Data++{-+-----------------------------------------------+        Notes about type families+-----------------------------------------------++Note [Type synonym families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Type synonym families, also known as "type functions", map directly+  onto the type functions in FC:++        type family F a :: *+        type instance F Int = Bool+        ..etc...++* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon++* From the user's point of view (F Int) and Bool are simply+  equivalent types.++* A Haskell 98 type synonym is a degenerate form of a type synonym+  family.++* Type functions can't appear in the LHS of a type function:+        type instance F (F Int) = ...   -- BAD!++* Translation of type family decl:+        type family F a :: *+  translates to+    a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon++        type family G a :: * where+          G Int = Bool+          G Bool = Char+          G a = ()+  translates to+    a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the+    appropriate CoAxiom representing the equations++We also support injective type families -- see Note [Injective type families]++Note [Data type families]+~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make++* Data type families are declared thus+        data family T a :: *+        data instance T Int = T1 | T2 Bool++  Here T is the "family TyCon".++* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon++* The user does not see any "equivalent types" as he did with type+  synonym families.  He just sees constructors with types+        T1 :: T Int+        T2 :: Bool -> T Int++* Here's the FC version of the above declarations:++        data T a+        data R:TInt = T1 | T2 Bool+        axiom ax_ti : T Int ~R R:TInt++  Note that this is a *representational* coercion+  The R:TInt is the "representation TyCons".+  It has an AlgTyConFlav of+        DataFamInstTyCon T [Int] ax_ti++* The axiom ax_ti may be eta-reduced; see+  Note [Eta reduction for data families] in GHC.Core.FamInstEnv++* Data family instances may have a different arity than the data family.+  See Note [Arity of data families] in GHC.Core.FamInstEnv++* The data constructor T2 has a wrapper (which is what the+  source-level "T2" invokes):++        $WT2 :: Bool -> T Int+        $WT2 b = T2 b `cast` sym ax_ti++* A data instance can declare a fully-fledged GADT:++        data instance T (a,b) where+          X1 :: T (Int,Bool)+          X2 :: a -> b -> T (a,b)++  Here's the FC version of the above declaration:++        data R:TPair a b where+          X1 :: R:TPair Int Bool+          X2 :: a -> b -> R:TPair a b+        axiom ax_pr :: T (a,b)  ~R  R:TPair a b++        $WX1 :: forall a b. a -> b -> T (a,b)+        $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b)++  The R:TPair are the "representation TyCons".+  We have a bit of work to do, to unpick the result types of the+  data instance declaration for T (a,b), to get the result type in the+  representation; e.g.  T (a,b) --> R:TPair a b++  The representation TyCon R:TList, has an AlgTyConFlav of++        DataFamInstTyCon T [(a,b)] ax_pr++* Notice that T is NOT translated to a FC type function; it just+  becomes a "data type" with no constructors, which can be coerced+  into R:TInt, R:TPair by the axioms.  These axioms+  axioms come into play when (and *only* when) you+        - use a data constructor+        - do pattern matching+  Rather like newtype, in fact++  As a result++  - T behaves just like a data type so far as decomposition is concerned++  - (T Int) is not implicitly converted to R:TInt during type inference.+    Indeed the latter type is unknown to the programmer.++  - There *is* an instance for (T Int) in the type-family instance+    environment, but it is only used for overlap checking++  - It's fine to have T in the LHS of a type function:+    type instance F (T a) = [a]++  It was this last point that confused me!  The big thing is that you+  should not think of a data family T as a *type function* at all, not+  even an injective one!  We can't allow even injective type functions+  on the LHS of a type function:+        type family injective G a :: *+        type instance F (G Int) = Bool+  is no good, even if G is injective, because consider+        type instance G Int = Bool+        type instance F Bool = Char++  So a data type family is not an injective type function. It's just a+  data type with some axioms that connect it to other data types.++* The tyConTyVars of the representation tycon are the tyvars that the+  user wrote in the patterns. This is important in TcDeriv, where we+  bring these tyvars into scope before type-checking the deriving+  clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl.++Note [Associated families and their parent class]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Associated* families are just like *non-associated* families, except+that they have a famTcParent field of (Just cls_tc), which identifies the+parent class.++However there is an important sharing relationship between+  * the tyConTyVars of the parent Class+  * the tyConTyVars of the associated TyCon++   class C a b where+     data T p a+     type F a q b++Here the 'a' and 'b' are shared with the 'Class'; that is, they have+the same Unique.++This is important. In an instance declaration we expect+  * all the shared variables to be instantiated the same way+  * the non-shared variables of the associated type should not+    be instantiated at all++  instance C [x] (Tree y) where+     data T p [x] = T1 x | T2 p+     type F [x] q (Tree y) = (x,y,q)++Note [TyCon Role signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Every tycon has a role signature, assigning a role to each of the tyConTyVars+(or of equal length to the tyConArity, if there are no tyConTyVars). An+example demonstrates these best: say we have a tycon T, with parameters a at+nominal, b at representational, and c at phantom. Then, to prove+representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have+nominal equality between a1 and a2, representational equality between b1 and+b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This+might happen, say, with the following declaration:++  data T a b c where+    MkT :: b -> T Int b c++Data and class tycons have their roles inferred (see inferRoles in TcTyDecls),+as do vanilla synonym tycons. Family tycons have all parameters at role N,+though it is conceivable that we could relax this restriction. (->)'s and+tuples' parameters are at role R. Each primitive tycon declares its roles;+it's worth noting that (~#)'s parameters are at role N. Promoted data+constructors' type arguments are at role R. All kind arguments are at role+N.++Note [Unboxed tuple RuntimeRep vars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The contents of an unboxed tuple may have any representation. Accordingly,+the kind of the unboxed tuple constructor is runtime-representation+polymorphic.++Type constructor (2 kind arguments)+   (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep).+                   TYPE q -> TYPE r -> TYPE (TupleRep [q, r])+Data constructor (4 type arguments)+   (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep)+                   (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #)++These extra tyvars (q and r) cause some delicate processing around tuples,+where we need to manually insert RuntimeRep arguments.+The same situation happens with unboxed sums: each alternative+has its own RuntimeRep.+For boxed tuples, there is no levity polymorphism, and therefore+we add RuntimeReps only for the unboxed version.++Type constructor (no kind arguments)+   (,) :: Type -> Type -> Type+Data constructor (2 type arguments)+   (,) :: forall a b. a -> b -> (a, b)+++Note [Injective type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We allow injectivity annotations for type families (both open and closed):++  type family F (a :: k) (b :: k) = r | r -> a+  type family G a b = res | res -> a b where ...++Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`.+`famTcInj` maybe stores a list of Bools, where each entry corresponds to a+single element of `tyConTyVars` (both lists should have identical length). If no+injectivity annotation was provided `famTcInj` is Nothing. From this follows an+invariant that if `famTcInj` is a Just then at least one element in the list+must be True.++See also:+ * [Injectivity annotation] in GHC.Hs.Decls+ * [Renaming injectivity annotation] in GHC.Rename.Source+ * [Verifying injectivity annotation] in GHC.Core.FamInstEnv+ * [Type inference for type families with injectivity] in TcInteract++************************************************************************+*                                                                      *+                    TyConBinder, TyConTyCoBinder+*                                                                      *+************************************************************************+-}++type TyConBinder = VarBndr TyVar TyConBndrVis++-- In the whole definition of @data TyCon@, only @PromotedDataCon@ will really+-- contain CoVar.+type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis++data TyConBndrVis+  = NamedTCB ArgFlag+  | AnonTCB  AnonArgFlag++instance Outputable TyConBndrVis where+  ppr (NamedTCB flag) = text "NamedTCB" <> ppr flag+  ppr (AnonTCB af)    = text "AnonTCB"  <> ppr af++mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder+mkAnonTyConBinder af tv = ASSERT( isTyVar tv)+                          Bndr tv (AnonTCB af)++mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder]+mkAnonTyConBinders af tvs = map (mkAnonTyConBinder af) tvs++mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder+-- The odd argument order supports currying+mkNamedTyConBinder vis tv = ASSERT( isTyVar tv )+                            Bndr tv (NamedTCB vis)++mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder]+-- The odd argument order supports currying+mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs++-- | Make a Required TyConBinder. It chooses between NamedTCB and+-- AnonTCB based on whether the tv is mentioned in the dependent set+mkRequiredTyConBinder :: TyCoVarSet  -- these are used dependently+                      -> TyVar+                      -> TyConBinder+mkRequiredTyConBinder dep_set tv+  | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv+  | otherwise               = mkAnonTyConBinder  VisArg   tv++tyConBinderArgFlag :: TyConBinder -> ArgFlag+tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis++tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag+tyConBndrVisArgFlag (NamedTCB vis)     = vis+tyConBndrVisArgFlag (AnonTCB VisArg)   = Required+tyConBndrVisArgFlag (AnonTCB InvisArg) = Inferred    -- See Note [AnonTCB InvisArg]++isNamedTyConBinder :: TyConBinder -> Bool+-- Identifies kind variables+-- E.g. data T k (a:k) = blah+-- Here 'k' is a NamedTCB, a variable used in the kind of other binders+isNamedTyConBinder (Bndr _ (NamedTCB {})) = True+isNamedTyConBinder _                      = False++isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool+-- Works for IfaceTyConBinder too+isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis++isVisibleTcbVis :: TyConBndrVis -> Bool+isVisibleTcbVis (NamedTCB vis)     = isVisibleArgFlag vis+isVisibleTcbVis (AnonTCB VisArg)   = True+isVisibleTcbVis (AnonTCB InvisArg) = False++isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool+-- Works for IfaceTyConBinder too+isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb)++-- Build the 'tyConKind' from the binders and the result kind.+-- Keep in sync with 'mkTyConKind' in GHC.Iface.Type.+mkTyConKind :: [TyConBinder] -> Kind -> Kind+mkTyConKind bndrs res_kind = foldr mk res_kind bndrs+  where+    mk :: TyConBinder -> Kind -> Kind+    mk (Bndr tv (AnonTCB af))   k = mkFunTy af (varType tv) k+    mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k++tyConTyVarBinders :: [TyConBinder]   -- From the TyCon+                  -> [TyVarBinder]   -- Suitable for the foralls of a term function+-- See Note [Building TyVarBinders from TyConBinders]+tyConTyVarBinders tc_bndrs+ = map mk_binder tc_bndrs+ where+   mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv+      where+        vis = case tc_vis of+                AnonTCB VisArg    -> Specified+                AnonTCB InvisArg  -> Inferred   -- See Note [AnonTCB InvisArg]+                NamedTCB Required -> Specified+                NamedTCB vis      -> vis++-- Returns only tyvars, as covars are always inferred+tyConVisibleTyVars :: TyCon -> [TyVar]+tyConVisibleTyVars tc+  = [ tv | Bndr tv vis <- tyConBinders tc+         , isVisibleTcbVis vis ]++{- Note [AnonTCB InvisArg]+~~~~~~~~~~~~~~~~~~~~~~~~~~+It's pretty rare to have an (AnonTCB InvisArg) binder.  The+only way it can occur is through equality constraints in kinds. These+can arise in one of two ways:++* In a PromotedDataCon whose kind has an equality constraint:++    'MkT :: forall a b. (a~b) => blah++  See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and+  Note [Promoted data constructors] in this module.+* In a data type whose kind has an equality constraint, as in the+  following example from #12102:++    data T :: forall a. (IsTypeLit a ~ 'True) => a -> Type++When mapping an (AnonTCB InvisArg) to an ArgFlag, in+tyConBndrVisArgFlag, we use "Inferred" to mean "the user cannot+specify this arguments, even with visible type/kind application;+instead the type checker must fill it in.++We map (AnonTCB VisArg) to Required, of course: the user must+provide it. It would be utterly wrong to do this for constraint+arguments, which is why AnonTCB must have the AnonArgFlag in+the first place.++Note [Building TyVarBinders from TyConBinders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We sometimes need to build the quantified type of a value from+the TyConBinders of a type or class.  For that we need not+TyConBinders but TyVarBinders (used in forall-type)  E.g:++ *  From   data T a = MkT (Maybe a)+    we are going to make a data constructor with type+           MkT :: forall a. Maybe a -> T a+    See the TyCoVarBinders passed to buildDataCon++ * From    class C a where { op :: a -> Maybe a }+   we are going to make a default method+           $dmop :: forall a. C a => a -> Maybe a+   See the TyCoVarBinders passed to mkSigmaTy in mkDefaultMethodType++Both of these are user-callable.  (NB: default methods are not callable+directly by the user but rather via the code generated by 'deriving',+which uses visible type application; see mkDefMethBind.)++Since they are user-callable we must get their type-argument visibility+information right; and that info is in the TyConBinders.+Here is an example:++  data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> *++The TyCon has++  tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ]++The TyConBinders for App line up with App's kind, given above.++But the DataCon MkApp has the type+  MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b++That is, its TyCoVarBinders should be++  dataConUnivTyVarBinders = [ Bndr (k:*)    Inferred+                            , Bndr (a:k->*) Specified+                            , Bndr (b:k)    Specified ]++So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders:+  - variable names from the TyConBinders+  - but changing Anon/Required to Specified++The last part about Required->Specified comes from this:+  data T k (a:k) b = MkT (a b)+Here k is Required in T's kind, but we don't have Required binders in+the TyCoBinders for a term (see Note [No Required TyCoBinder in terms]+in GHC.Core.TyCo.Rep), so we change it to Specified when making MkT's TyCoBinders+-}+++{- Note [The binders/kind/arity fields of a TyCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All TyCons have this group of fields+  tyConBinders   :: [TyConBinder/TyConTyCoBinder]+  tyConResKind   :: Kind+  tyConTyVars    :: [TyVar]   -- Cached = binderVars tyConBinders+                              --   NB: Currently (Aug 2018), TyCons that own this+                              --   field really only contain TyVars. So it is+                              --   [TyVar] instead of [TyCoVar].+  tyConKind      :: Kind      -- Cached = mkTyConKind tyConBinders tyConResKind+  tyConArity     :: Arity     -- Cached = length tyConBinders++They fit together like so:++* tyConBinders gives the telescope of type/coercion variables on the LHS of the+  type declaration.  For example:++    type App a (b :: k) = a b++  tyConBinders = [ Bndr (k::*)   (NamedTCB Inferred)+                 , Bndr (a:k->*) AnonTCB+                 , Bndr (b:k)    AnonTCB ]++  Note that that are three binders here, including the+  kind variable k.++* See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep+  for what the visibility flag means.++* Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and+  that TyVar may scope over some other part of the TyCon's definition. Eg+      type T a = a -> a+  we have+      tyConBinders = [ Bndr (a:*) AnonTCB ]+      synTcRhs     = a -> a+  So the 'a' scopes over the synTcRhs++* From the tyConBinders and tyConResKind we can get the tyConKind+  E.g for our App example:+      App :: forall k. (k->*) -> k -> *++  We get a 'forall' in the kind for each NamedTCB, and an arrow+  for each AnonTCB++  tyConKind is the full kind of the TyCon, not just the result kind++* For type families, tyConArity is the arguments this TyCon must be+  applied to, to be considered saturated.  Here we mean "applied to in+  the actual Type", not surface syntax; i.e. including implicit kind+  variables.  So it's just (length tyConBinders)++* For an algebraic data type, or data instance, the tyConResKind is+  always (TYPE r); that is, the tyConBinders are enough to saturate+  the type constructor.  I'm not quite sure why we have this invariant,+  but it's enforced by etaExpandAlgTyCon+-}++instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where+  ppr (Bndr v bi) = ppr_bi bi <+> parens (pprBndr LetBind v)+    where+      ppr_bi (AnonTCB VisArg)     = text "anon-vis"+      ppr_bi (AnonTCB InvisArg)   = text "anon-invis"+      ppr_bi (NamedTCB Required)  = text "req"+      ppr_bi (NamedTCB Specified) = text "spec"+      ppr_bi (NamedTCB Inferred)  = text "inf"++instance Binary TyConBndrVis where+  put_ bh (AnonTCB af)   = do { putByte bh 0; put_ bh af }+  put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis }++  get bh = do { h <- getByte bh+              ; case h of+                  0 -> do { af  <- get bh; return (AnonTCB af) }+                  _ -> do { vis <- get bh; return (NamedTCB vis) } }+++{- *********************************************************************+*                                                                      *+               The TyCon type+*                                                                      *+************************************************************************+-}+++-- | TyCons represent type constructors. Type constructors are introduced by+-- things such as:+--+-- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of+--    kind @*@+--+-- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor+--+-- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor+--    of kind @* -> *@+--+-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor+--    of kind @*@+--+-- This data type also encodes a number of primitive, built in type constructors+-- such as those for function and tuple types.++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data TyCon+  = -- | The function type constructor, @(->)@+    FunTyCon {+        tyConUnique :: Unique,   -- ^ A Unique of this TyCon. Invariant:+                                 -- identical to Unique of Name stored in+                                 -- tyConName field.++        tyConName   :: Name,     -- ^ Name of the constructor++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders :: [TyConBinder], -- ^ Full binders+        tyConResKind :: Kind,             -- ^ Result kind+        tyConKind    :: Kind,             -- ^ Kind of this TyCon+        tyConArity   :: Arity,            -- ^ Arity++        tcRepName :: TyConRepName+    }++  -- | Algebraic data types, from+  --     - @data@ declarations+  --     - @newtype@ declarations+  --     - data instance declarations+  --     - type instance declarations+  --     - the TyCon generated by a class declaration+  --     - boxed tuples+  --     - unboxed tuples+  --     - constraint tuples+  -- All these constructors are lifted and boxed except unboxed tuples+  -- which should have an 'UnboxedAlgTyCon' parent.+  -- Data/newtype/type /families/ are handled by 'FamilyTyCon'.+  -- See 'AlgTyConRhs' for more information.+  | AlgTyCon {+        tyConUnique  :: Unique,  -- ^ A Unique of this TyCon. Invariant:+                                 -- identical to Unique of Name stored in+                                 -- tyConName field.++        tyConName    :: Name,    -- ^ Name of the constructor++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders :: [TyConBinder], -- ^ Full binders+        tyConTyVars  :: [TyVar],          -- ^ TyVar binders+        tyConResKind :: Kind,             -- ^ Result kind+        tyConKind    :: Kind,             -- ^ Kind of this TyCon+        tyConArity   :: Arity,            -- ^ Arity++              -- The tyConTyVars scope over:+              --+              -- 1. The 'algTcStupidTheta'+              -- 2. The cached types in algTyConRhs.NewTyCon+              -- 3. The family instance types if present+              --+              -- Note that it does /not/ scope over the data+              -- constructors.++        tcRoles      :: [Role],  -- ^ The role for each type variable+                                 -- This list has length = tyConArity+                                 -- See also Note [TyCon Role signatures]++        tyConCType   :: Maybe CType,-- ^ The C type that should be used+                                    -- for this type when using the FFI+                                    -- and CAPI++        algTcGadtSyntax  :: Bool,   -- ^ Was the data type declared with GADT+                                    -- syntax?  If so, that doesn't mean it's a+                                    -- true GADT; only that the "where" form+                                    -- was used.  This field is used only to+                                    -- guide pretty-printing++        algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data+                                        -- type (always empty for GADTs).  A+                                        -- \"stupid theta\" is the context to+                                        -- the left of an algebraic type+                                        -- declaration, e.g. @Eq a@ in the+                                        -- declaration @data Eq a => T a ...@.++        algTcRhs    :: AlgTyConRhs, -- ^ Contains information about the+                                    -- data constructors of the algebraic type++        algTcFields :: FieldLabelEnv, -- ^ Maps a label to information+                                      -- about the field++        algTcParent :: AlgTyConFlav -- ^ Gives the class or family declaration+                                       -- 'TyCon' for derived 'TyCon's representing+                                       -- class or family instances, respectively.++    }++  -- | Represents type synonyms+  | SynonymTyCon {+        tyConUnique  :: Unique,  -- ^ A Unique of this TyCon. Invariant:+                                 -- identical to Unique of Name stored in+                                 -- tyConName field.++        tyConName    :: Name,    -- ^ Name of the constructor++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders :: [TyConBinder], -- ^ Full binders+        tyConTyVars  :: [TyVar],          -- ^ TyVar binders+        tyConResKind :: Kind,             -- ^ Result kind+        tyConKind    :: Kind,             -- ^ Kind of this TyCon+        tyConArity   :: Arity,            -- ^ Arity+             -- tyConTyVars scope over: synTcRhs++        tcRoles      :: [Role],  -- ^ The role for each type variable+                                 -- This list has length = tyConArity+                                 -- See also Note [TyCon Role signatures]++        synTcRhs     :: Type,    -- ^ Contains information about the expansion+                                 -- of the synonym++        synIsTau     :: Bool,   -- True <=> the RHS of this synonym does not+                                 --          have any foralls, after expanding any+                                 --          nested synonyms+        synIsFamFree  :: Bool    -- True <=> the RHS of this synonym does not mention+                                 --          any type synonym families (data families+                                 --          are fine), again after expanding any+                                 --          nested synonyms+    }++  -- | Represents families (both type and data)+  -- Argument roles are all Nominal+  | FamilyTyCon {+        tyConUnique  :: Unique,  -- ^ A Unique of this TyCon. Invariant:+                                 -- identical to Unique of Name stored in+                                 -- tyConName field.++        tyConName    :: Name,    -- ^ Name of the constructor++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders :: [TyConBinder], -- ^ Full binders+        tyConTyVars  :: [TyVar],          -- ^ TyVar binders+        tyConResKind :: Kind,             -- ^ Result kind+        tyConKind    :: Kind,             -- ^ Kind of this TyCon+        tyConArity   :: Arity,            -- ^ Arity+            -- tyConTyVars connect an associated family TyCon+            -- with its parent class; see TcValidity.checkConsistentFamInst++        famTcResVar  :: Maybe Name,   -- ^ Name of result type variable, used+                                      -- for pretty-printing with --show-iface+                                      -- and for reifying TyCon in Template+                                      -- Haskell++        famTcFlav    :: FamTyConFlav, -- ^ Type family flavour: open, closed,+                                      -- abstract, built-in. See comments for+                                      -- FamTyConFlav++        famTcParent  :: Maybe TyCon,  -- ^ For *associated* type/data families+                                      -- The class tycon in which the family is declared+                                      -- See Note [Associated families and their parent class]++        famTcInj     :: Injectivity   -- ^ is this a type family injective in+                                      -- its type variables? Nothing if no+                                      -- injectivity annotation was given+    }++  -- | Primitive types; cannot be defined in Haskell. This includes+  -- the usual suspects (such as @Int#@) as well as foreign-imported+  -- types and kinds (@*@, @#@, and @?@)+  | PrimTyCon {+        tyConUnique   :: Unique, -- ^ A Unique of this TyCon. Invariant:+                                 -- identical to Unique of Name stored in+                                 -- tyConName field.++        tyConName     :: Name,   -- ^ Name of the constructor++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders :: [TyConBinder], -- ^ Full binders+        tyConResKind :: Kind,             -- ^ Result kind+        tyConKind    :: Kind,             -- ^ Kind of this TyCon+        tyConArity   :: Arity,            -- ^ Arity++        tcRoles       :: [Role], -- ^ The role for each type variable+                                 -- This list has length = tyConArity+                                 -- See also Note [TyCon Role signatures]++        isUnlifted   :: Bool,    -- ^ Most primitive tycons are unlifted (may+                                 -- not contain bottom) but other are lifted,+                                 -- e.g. @RealWorld@+                                 -- Only relevant if tyConKind = *++        primRepName :: Maybe TyConRepName   -- Only relevant for kind TyCons+                                            -- i.e, *, #, ?+    }++  -- | Represents promoted data constructor.+  | PromotedDataCon {          -- See Note [Promoted data constructors]+        tyConUnique  :: Unique,     -- ^ Same Unique as the data constructor+        tyConName    :: Name,       -- ^ Same Name as the data constructor++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders :: [TyConTyCoBinder], -- ^ Full binders+        tyConResKind :: Kind,             -- ^ Result kind+        tyConKind    :: Kind,             -- ^ Kind of this TyCon+        tyConArity   :: Arity,            -- ^ Arity++        tcRoles       :: [Role],    -- ^ Roles: N for kind vars, R for type vars+        dataCon       :: DataCon,   -- ^ Corresponding data constructor+        tcRepName     :: TyConRepName,+        promDcRepInfo :: RuntimeRepInfo  -- ^ See comments with 'RuntimeRepInfo'+    }++  -- | These exist only during type-checking. See Note [How TcTyCons work]+  -- in TcTyClsDecls+  | TcTyCon {+        tyConUnique :: Unique,+        tyConName   :: Name,++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders :: [TyConBinder], -- ^ Full binders+        tyConTyVars  :: [TyVar],       -- ^ TyVar binders+        tyConResKind :: Kind,          -- ^ Result kind+        tyConKind    :: Kind,          -- ^ Kind of this TyCon+        tyConArity   :: Arity,         -- ^ Arity++          -- NB: the TyConArity of a TcTyCon must match+          -- the number of Required (positional, user-specified)+          -- arguments to the type constructor; see the use+          -- of tyConArity in generaliseTcTyCon++        tcTyConScopedTyVars :: [(Name,TyVar)],+          -- ^ Scoped tyvars over the tycon's body+          -- See Note [Scoped tyvars in a TcTyCon]++        tcTyConIsPoly     :: Bool, -- ^ Is this TcTyCon already generalized?++        tcTyConFlavour :: TyConFlavour+                           -- ^ What sort of 'TyCon' this represents.+      }+{- Note [Scoped tyvars in a TcTyCon]++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The tcTyConScopedTyVars field records the lexicial-binding connection+between the original, user-specified Name (i.e. thing in scope) and+the TcTyVar that the Name is bound to.++Order *does* matter; the tcTyConScopedTyvars list consists of+     specified_tvs ++ required_tvs++where+   * specified ones first+   * required_tvs the same as tyConTyVars+   * tyConArity = length required_tvs++See also Note [How TcTyCons work] in TcTyClsDecls+-}++-- | Represents right-hand-sides of 'TyCon's for algebraic types+data AlgTyConRhs++    -- | Says that we know nothing about this data type, except that+    -- it's represented by a pointer.  Used when we export a data type+    -- abstractly into an .hi file.+  = AbstractTyCon++    -- | Information about those 'TyCon's derived from a @data@+    -- declaration. This includes data types with no constructors at+    -- all.+  | DataTyCon {+        data_cons :: [DataCon],+                          -- ^ The data type constructors; can be empty if the+                          --   user declares the type to have no constructors+                          --+                          -- INVARIANT: Kept in order of increasing 'DataCon'+                          -- tag (see the tag assignment in mkTyConTagMap)+        data_cons_size :: Int,+                          -- ^ Cached value: length data_cons+        is_enum :: Bool   -- ^ Cached value: is this an enumeration type?+                          --   See Note [Enumeration types]+    }++  | TupleTyCon {                   -- A boxed, unboxed, or constraint tuple+        data_con :: DataCon,       -- NB: it can be an *unboxed* tuple+        tup_sort :: TupleSort      -- ^ Is this a boxed, unboxed or constraint+                                   -- tuple?+    }++  -- | An unboxed sum type.+  | SumTyCon {+        data_cons :: [DataCon],+        data_cons_size :: Int  -- ^ Cached value: length data_cons+    }++  -- | Information about those 'TyCon's derived from a @newtype@ declaration+  | NewTyCon {+        data_con :: DataCon,    -- ^ The unique constructor for the @newtype@.+                                --   It has no existentials++        nt_rhs :: Type,         -- ^ Cached value: the argument type of the+                                -- constructor, which is just the representation+                                -- type of the 'TyCon' (remember that @newtype@s+                                -- do not exist at runtime so need a different+                                -- representation type).+                                --+                                -- The free 'TyVar's of this type are the+                                -- 'tyConTyVars' from the corresponding 'TyCon'++        nt_etad_rhs :: ([TyVar], Type),+                        -- ^ Same as the 'nt_rhs', but this time eta-reduced.+                        -- Hence the list of 'TyVar's in this field may be+                        -- shorter than the declared arity of the 'TyCon'.++                        -- See Note [Newtype eta]+        nt_co :: CoAxiom Unbranched,+                             -- The axiom coercion that creates the @newtype@+                             -- from the representation 'Type'.++                             -- See Note [Newtype coercions]+                             -- Invariant: arity = #tvs in nt_etad_rhs;+                             -- See Note [Newtype eta]+                             -- Watch out!  If any newtypes become transparent+                             -- again check #1072.+        nt_lev_poly :: Bool+                        -- 'True' if the newtype can be levity polymorphic when+                        -- fully applied to its arguments, 'False' otherwise.+                        -- This can only ever be 'True' with UnliftedNewtypes.+                        --+                        -- Invariant: nt_lev_poly nt = isTypeLevPoly (nt_rhs nt)+                        --+                        -- This is cached to make it cheaper to check if a+                        -- variable binding is levity polymorphic, as used by+                        -- isTcLevPoly.+    }++mkSumTyConRhs :: [DataCon] -> AlgTyConRhs+mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons)++mkDataTyConRhs :: [DataCon] -> AlgTyConRhs+mkDataTyConRhs cons+  = DataTyCon {+        data_cons = cons,+        data_cons_size = length cons,+        is_enum = not (null cons) && all is_enum_con cons+                  -- See Note [Enumeration types] in GHC.Core.TyCon+    }+  where+    is_enum_con con+       | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res)+           <- dataConFullSig con+       = null ex_tvs && null eq_spec && null theta && null arg_tys++-- | Some promoted datacons signify extra info relevant to GHC. For example,+-- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep'+-- constructor of 'PrimRep'. This data structure allows us to store this+-- information right in the 'TyCon'. The other approach would be to look+-- up things like @RuntimeRep@'s @PrimRep@ by known-key every time.+-- See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType+data RuntimeRepInfo+  = NoRRI       -- ^ an ordinary promoted data con+  | RuntimeRep ([Type] -> [PrimRep])+      -- ^ A constructor of @RuntimeRep@. The argument to the function should+      -- be the list of arguments to the promoted datacon.+  | VecCount Int         -- ^ A constructor of @VecCount@+  | VecElem PrimElemRep  -- ^ A constructor of @VecElem@++-- | Extract those 'DataCon's that we are able to learn about.  Note+-- that visibility in this sense does not correspond to visibility in+-- the context of any particular user program!+visibleDataCons :: AlgTyConRhs -> [DataCon]+visibleDataCons (AbstractTyCon {})            = []+visibleDataCons (DataTyCon{ data_cons = cs }) = cs+visibleDataCons (NewTyCon{ data_con = c })    = [c]+visibleDataCons (TupleTyCon{ data_con = c })  = [c]+visibleDataCons (SumTyCon{ data_cons = cs })  = cs++-- ^ Both type classes as well as family instances imply implicit+-- type constructors.  These implicit type constructors refer to their parent+-- structure (ie, the class or family from which they derive) using a type of+-- the following form.+data AlgTyConFlav+  = -- | An ordinary type constructor has no parent.+    VanillaAlgTyCon+       TyConRepName   -- For Typeable++    -- | An unboxed type constructor. The TyConRepName is a Maybe since we+    -- currently don't allow unboxed sums to be Typeable since there are too+    -- many of them. See #13276.+  | UnboxedAlgTyCon+       (Maybe TyConRepName)++  -- | Type constructors representing a class dictionary.+  -- See Note [ATyCon for classes] in GHC.Core.TyCo.Rep+  | ClassTyCon+        Class           -- INVARIANT: the classTyCon of this Class is the+                        -- current tycon+        TyConRepName++  -- | Type constructors representing an *instance* of a *data* family.+  -- Parameters:+  --+  --  1) The type family in question+  --+  --  2) Instance types; free variables are the 'tyConTyVars'+  --  of the current 'TyCon' (not the family one). INVARIANT:+  --  the number of types matches the arity of the family 'TyCon'+  --+  --  3) A 'CoTyCon' identifying the representation+  --  type with the type instance family+  | DataFamInstTyCon          -- See Note [Data type families]+        (CoAxiom Unbranched)  -- The coercion axiom.+               -- A *Representational* coercion,+               -- of kind   T ty1 ty2   ~R   R:T a b c+               -- where T is the family TyCon,+               -- and R:T is the representation TyCon (ie this one)+               -- and a,b,c are the tyConTyVars of this TyCon+               --+               -- BUT may be eta-reduced; see FamInstEnv+               --     Note [Eta reduction for data families]++          -- Cached fields of the CoAxiom, but adjusted to+          -- use the tyConTyVars of this TyCon+        TyCon   -- The family TyCon+        [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)+                -- No shorter in length than the tyConTyVars of the family TyCon+                -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv++        -- E.g.  data instance T [a] = ...+        -- gives a representation tycon:+        --      data R:TList a = ...+        --      axiom co a :: T [a] ~ R:TList a+        -- with R:TList's algTcParent = DataFamInstTyCon T [a] co++instance Outputable AlgTyConFlav where+    ppr (VanillaAlgTyCon {})        = text "Vanilla ADT"+    ppr (UnboxedAlgTyCon {})        = text "Unboxed ADT"+    ppr (ClassTyCon cls _)          = text "Class parent" <+> ppr cls+    ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)"+                                      <+> ppr tc <+> sep (map pprType tys)++-- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class+-- name, if any+okParent :: Name -> AlgTyConFlav -> Bool+okParent _       (VanillaAlgTyCon {})            = True+okParent _       (UnboxedAlgTyCon {})            = True+okParent tc_name (ClassTyCon cls _)              = tc_name == tyConName (classTyCon cls)+okParent _       (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc++isNoParent :: AlgTyConFlav -> Bool+isNoParent (VanillaAlgTyCon {}) = True+isNoParent _                   = False++--------------------++data Injectivity+  = NotInjective+  | Injective [Bool]   -- 1-1 with tyConTyVars (incl kind vars)+  deriving( Eq )++-- | Information pertaining to the expansion of a type synonym (@type@)+data FamTyConFlav+  = -- | Represents an open type family without a fixed right hand+    -- side.  Additional instances can appear at any time.+    --+    -- These are introduced by either a top level declaration:+    --+    -- > data family T a :: *+    --+    -- Or an associated data type declaration, within a class declaration:+    --+    -- > class C a b where+    -- >   data T b :: *+     DataFamilyTyCon+       TyConRepName++     -- | An open type synonym family  e.g. @type family F x y :: * -> *@+   | OpenSynFamilyTyCon++   -- | A closed type synonym family  e.g.+   -- @type family F x where { F Int = Bool }@+   | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched))+     -- See Note [Closed type families]++   -- | A closed type synonym family declared in an hs-boot file with+   -- type family F a where ..+   | AbstractClosedSynFamilyTyCon++   -- | Built-in type family used by the TypeNats solver+   | BuiltInSynFamTyCon BuiltInSynFamily++instance Outputable FamTyConFlav where+    ppr (DataFamilyTyCon n) = text "data family" <+> ppr n+    ppr OpenSynFamilyTyCon = text "open type family"+    ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family"+    ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax+    ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family"+    ppr (BuiltInSynFamTyCon _) = text "built-in type family"++{- Note [Closed type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* In an open type family you can add new instances later.  This is the+  usual case.++* In a closed type family you can only put equations where the family+  is defined.++A non-empty closed type family has a single axiom with multiple+branches, stored in the 'ClosedSynFamilyTyCon' constructor.  A closed+type family with no equations does not have an axiom, because there is+nothing for the axiom to prove!+++Note [Promoted data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All data constructors can be promoted to become a type constructor,+via the PromotedDataCon alternative in GHC.Core.TyCon.++* The TyCon promoted from a DataCon has the *same* Name and Unique as+  the DataCon.  Eg. If the data constructor Data.Maybe.Just(unique 78,+  say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78)++* We promote the *user* type of the DataCon.  Eg+     data T = MkT {-# UNPACK #-} !(Bool, Bool)+  The promoted kind is+     'MkT :: (Bool,Bool) -> T+  *not*+     'MkT :: Bool -> Bool -> T++* Similarly for GADTs:+     data G a where+       MkG :: forall b. b -> G [b]+  The promoted data constructor has kind+       'MkG :: forall b. b -> G [b]+  *not*+       'MkG :: forall a b. (a ~# [b]) => b -> G a++Note [Enumeration types]+~~~~~~~~~~~~~~~~~~~~~~~~+We define datatypes with no constructors to *not* be+enumerations; this fixes trac #2578,  Otherwise we+end up generating an empty table for+  <mod>_<type>_closure_tbl+which is used by tagToEnum# to map Int# to constructors+in an enumeration. The empty table apparently upset+the linker.++Moreover, all the data constructor must be enumerations, meaning+they have type  (forall abc. T a b c).  GADTs are not enumerations.+For example consider+    data T a where+      T1 :: T Int+      T2 :: T Bool+      T3 :: T a+What would [T1 ..] be?  [T1,T3] :: T Int? Easiest thing is to exclude them.+See #4528.++Note [Newtype coercions]+~~~~~~~~~~~~~~~~~~~~~~~~+The NewTyCon field nt_co is a CoAxiom which is used for coercing from+the representation type of the newtype, to the newtype itself. For+example,++   newtype T a = MkT (a -> a)++the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t.++In the case that the right hand side is a type application+ending with the same type variables as the left hand side, we+"eta-contract" the coercion.  So if we had++   newtype S a = MkT [a]++then we would generate the arity 0 axiom CoS : S ~ [].  The+primary reason we do this is to make newtype deriving cleaner.++In the paper we'd write+        axiom CoT : (forall t. T t) ~ (forall t. [t])+and then when we used CoT at a particular type, s, we'd say+        CoT @ s+which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s])++Note [Newtype eta]+~~~~~~~~~~~~~~~~~~+Consider+        newtype Parser a = MkParser (IO a) deriving Monad+Are these two types equal (to Core)?+        Monad Parser+        Monad IO+which we need to make the derived instance for Monad Parser.++Well, yes.  But to see that easily we eta-reduce the RHS type of+Parser, in this case to ([], Froogle), so that even unsaturated applications+of Parser will work right.  This eta reduction is done when the type+constructor is built, and cached in NewTyCon.++Here's an example that I think showed up in practice+Source code:+        newtype T a = MkT [a]+        newtype Foo m = MkFoo (forall a. m a -> Int)++        w1 :: Foo []+        w1 = ...++        w2 :: Foo T+        w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x)++After desugaring, and discarding the data constructors for the newtypes,+we get:+        w2 = w1 `cast` Foo CoT+so the coercion tycon CoT must have+        kind:    T ~ []+ and    arity:   0++This eta-reduction is implemented in BuildTyCl.mkNewTyConRhs.+++************************************************************************+*                                                                      *+                 TyConRepName+*                                                                      *+********************************************************************* -}++type TyConRepName = Name+   -- The Name of the top-level declaration for the Typeable world+   --    $tcMaybe :: Data.Typeable.Internal.TyCon+   --    $tcMaybe = TyCon { tyConName = "Maybe", ... }++tyConRepName_maybe :: TyCon -> Maybe TyConRepName+tyConRepName_maybe (FunTyCon   { tcRepName = rep_nm })+  = Just rep_nm+tyConRepName_maybe (PrimTyCon  { primRepName = mb_rep_nm })+  = mb_rep_nm+tyConRepName_maybe (AlgTyCon { algTcParent = parent })+  | VanillaAlgTyCon rep_nm <- parent = Just rep_nm+  | ClassTyCon _ rep_nm    <- parent = Just rep_nm+  | UnboxedAlgTyCon rep_nm <- parent = rep_nm+tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })+  = Just rep_nm+tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm })+  | isUnboxedSumCon dc   -- see #13276+  = Nothing+  | otherwise+  = Just rep_nm+tyConRepName_maybe _ = Nothing++-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type+mkPrelTyConRepName :: Name -> TyConRepName+-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.+mkPrelTyConRepName tc_name  -- Prelude tc_name is always External,+                            -- so nameModule will work+  = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name)+  where+    name_occ  = nameOccName tc_name+    name_mod  = nameModule  tc_name+    name_uniq = nameUnique  tc_name+    rep_uniq | isTcOcc name_occ = tyConRepNameUnique   name_uniq+             | otherwise        = dataConTyRepNameUnique name_uniq+    (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ++-- | The name (and defining module) for the Typeable representation (TyCon) of a+-- type constructor.+--+-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.+tyConRepModOcc :: Module -> OccName -> (Module, OccName)+tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ)+  where+    rep_module+      | tc_module == gHC_PRIM = gHC_TYPES+      | otherwise             = tc_module+++{- *********************************************************************+*                                                                      *+                 PrimRep+*                                                                      *+************************************************************************++Note [rep swamp]++GHC has a rich selection of types that represent "primitive types" of+one kind or another.  Each of them makes a different set of+distinctions, and mostly the differences are for good reasons,+although it's probably true that we could merge some of these.++Roughly in order of "includes more information":++ - A Width (cmm/CmmType) is simply a binary value with the specified+   number of bits.  It may represent a signed or unsigned integer, a+   floating-point value, or an address.++    data Width = W8 | W16 | W32 | W64  | W128++ - Size, which is used in the native code generator, is Width ++   floating point information.++   data Size = II8 | II16 | II32 | II64 | FF32 | FF64++   it is necessary because e.g. the instruction to move a 64-bit float+   on x86 (movsd) is different from the instruction to move a 64-bit+   integer (movq), so the mov instruction is parameterised by Size.++ - CmmType wraps Width with more information: GC ptr, float, or+   other value.++    data CmmType = CmmType CmmCat Width++    data CmmCat     -- "Category" (not exported)+       = GcPtrCat   -- GC pointer+       | BitsCat    -- Non-pointer+       | FloatCat   -- Float++   It is important to have GcPtr information in Cmm, since we generate+   info tables containing pointerhood for the GC from this.  As for+   why we have float (and not signed/unsigned) here, see Note [Signed+   vs unsigned].++ - ArgRep makes only the distinctions necessary for the call and+   return conventions of the STG machine.  It is essentially CmmType+   + void.++ - PrimRep makes a few more distinctions than ArgRep: it divides+   non-GC-pointers into signed/unsigned and addresses, information+   that is necessary for passing these values to foreign functions.++There's another tension here: whether the type encodes its size in+bytes, or whether its size depends on the machine word size.  Width+and CmmType have the size built-in, whereas ArgRep and PrimRep do not.++This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags.++On the other hand, CmmType includes some "nonsense" values, such as+CmmType GcPtrCat W32 on a 64-bit machine.++The PrimRep type is closely related to the user-visible RuntimeRep type.+See Note [RuntimeRep and PrimRep] in GHC.Types.RepType.++-}++-- | A 'PrimRep' is an abstraction of a type.  It contains information that+-- the code generator needs in order to pass arguments, return results,+-- and store values of this type. See also Note [RuntimeRep and PrimRep] in+-- GHC.Types.RepType and Note [VoidRep] in GHC.Types.RepType.+data PrimRep+  = VoidRep+  | LiftedRep+  | UnliftedRep   -- ^ Unlifted pointer+  | Int8Rep       -- ^ Signed, 8-bit value+  | Int16Rep      -- ^ Signed, 16-bit value+  | Int32Rep      -- ^ Signed, 32-bit value+  | Int64Rep      -- ^ Signed, 64 bit value (with 32-bit words only)+  | IntRep        -- ^ Signed, word-sized value+  | Word8Rep      -- ^ Unsigned, 8 bit value+  | Word16Rep     -- ^ Unsigned, 16 bit value+  | Word32Rep     -- ^ Unsigned, 32 bit value+  | Word64Rep     -- ^ Unsigned, 64 bit value (with 32-bit words only)+  | WordRep       -- ^ Unsigned, word-sized value+  | AddrRep       -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep')+  | FloatRep+  | DoubleRep+  | VecRep Int PrimElemRep  -- ^ A vector+  deriving( Show )++data PrimElemRep+  = Int8ElemRep+  | Int16ElemRep+  | Int32ElemRep+  | Int64ElemRep+  | Word8ElemRep+  | Word16ElemRep+  | Word32ElemRep+  | Word64ElemRep+  | FloatElemRep+  | DoubleElemRep+   deriving( Eq, Show )++instance Outputable PrimRep where+  ppr r = text (show r)++instance Outputable PrimElemRep where+  ppr r = text (show r)++isVoidRep :: PrimRep -> Bool+isVoidRep VoidRep = True+isVoidRep _other  = False++isGcPtrRep :: PrimRep -> Bool+isGcPtrRep LiftedRep   = True+isGcPtrRep UnliftedRep = True+isGcPtrRep _           = False++-- A PrimRep is compatible with another iff one can be coerced to the other.+-- See Note [bad unsafe coercion] in GHC.Core.Lint for when are two types coercible.+primRepCompatible :: Platform -> PrimRep -> PrimRep -> Bool+primRepCompatible platform rep1 rep2 =+    (isUnboxed rep1 == isUnboxed rep2) &&+    (primRepSizeB platform rep1 == primRepSizeB platform rep2) &&+    (primRepIsFloat rep1 == primRepIsFloat rep2)+  where+    isUnboxed = not . isGcPtrRep++-- More general version of `primRepCompatible` for types represented by zero or+-- more than one PrimReps.+primRepsCompatible :: Platform -> [PrimRep] -> [PrimRep] -> Bool+primRepsCompatible platform reps1 reps2 =+    length reps1 == length reps2 &&+    and (zipWith (primRepCompatible platform) reps1 reps2)++-- | The size of a 'PrimRep' in bytes.+--+-- This applies also when used in a constructor, where we allow packing the+-- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will+-- take only 8 bytes, which for 64-bit arch will be equal to 1 word.+-- See also mkVirtHeapOffsetsWithPadding for details of how data fields are+-- laid out.+primRepSizeB :: Platform -> PrimRep -> Int+primRepSizeB platform = \case+   IntRep           -> platformWordSizeInBytes platform+   WordRep          -> platformWordSizeInBytes platform+   Int8Rep          -> 1+   Int16Rep         -> 2+   Int32Rep         -> 4+   Int64Rep         -> wORD64_SIZE+   Word8Rep         -> 1+   Word16Rep        -> 2+   Word32Rep        -> 4+   Word64Rep        -> wORD64_SIZE+   FloatRep         -> fLOAT_SIZE+   DoubleRep        -> dOUBLE_SIZE+   AddrRep          -> platformWordSizeInBytes platform+   LiftedRep        -> platformWordSizeInBytes platform+   UnliftedRep      -> platformWordSizeInBytes platform+   VoidRep          -> 0+   (VecRep len rep) -> len * primElemRepSizeB rep++primElemRepSizeB :: PrimElemRep -> Int+primElemRepSizeB Int8ElemRep   = 1+primElemRepSizeB Int16ElemRep  = 2+primElemRepSizeB Int32ElemRep  = 4+primElemRepSizeB Int64ElemRep  = 8+primElemRepSizeB Word8ElemRep  = 1+primElemRepSizeB Word16ElemRep = 2+primElemRepSizeB Word32ElemRep = 4+primElemRepSizeB Word64ElemRep = 8+primElemRepSizeB FloatElemRep  = 4+primElemRepSizeB DoubleElemRep = 8++-- | Return if Rep stands for floating type,+-- returns Nothing for vector types.+primRepIsFloat :: PrimRep -> Maybe Bool+primRepIsFloat  FloatRep     = Just True+primRepIsFloat  DoubleRep    = Just True+primRepIsFloat  (VecRep _ _) = Nothing+primRepIsFloat  _            = Just False+++{-+************************************************************************+*                                                                      *+                             Field labels+*                                                                      *+************************************************************************+-}++-- | The labels for the fields of this particular 'TyCon'+tyConFieldLabels :: TyCon -> [FieldLabel]+tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc++-- | The labels for the fields of this particular 'TyCon'+tyConFieldLabelEnv :: TyCon -> FieldLabelEnv+tyConFieldLabelEnv tc+  | isAlgTyCon tc = algTcFields tc+  | otherwise     = emptyDFsEnv++-- | Look up a field label belonging to this 'TyCon'+lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel+lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl++-- | Make a map from strings to FieldLabels from all the data+-- constructors of this algebraic tycon+fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv+fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl)+                                | fl <- dataConsFields (visibleDataCons rhs) ]+  where+    -- Duplicates in this list will be removed by 'mkFsEnv'+    dataConsFields dcs = concatMap dataConFieldLabels dcs+++{-+************************************************************************+*                                                                      *+\subsection{TyCon Construction}+*                                                                      *+************************************************************************++Note: the TyCon constructors all take a Kind as one argument, even though+they could, in principle, work out their Kind from their other arguments.+But to do so they need functions from Types, and that makes a nasty+module mutual-recursion.  And they aren't called from many places.+So we compromise, and move their Kind calculation to the call site.+-}++-- | Given the name of the function type constructor and it's kind, create the+-- corresponding 'TyCon'. It is recommended to use 'GHC.Core.TyCo.Rep.funTyCon' if you want+-- this functionality+mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon+mkFunTyCon name binders rep_nm+  = FunTyCon {+        tyConUnique  = nameUnique name,+        tyConName    = name,+        tyConBinders = binders,+        tyConResKind = liftedTypeKind,+        tyConKind    = mkTyConKind binders liftedTypeKind,+        tyConArity   = length binders,+        tcRepName    = rep_nm+    }++-- | This is the making of an algebraic 'TyCon'. Notably, you have to+-- pass in the generic (in the -XGenerics sense) information about the+-- type constructor - you can get hold of it easily (see Generics+-- module)+mkAlgTyCon :: Name+           -> [TyConBinder]  -- ^ Binders of the 'TyCon'+           -> Kind              -- ^ Result kind+           -> [Role]            -- ^ The roles for each TyVar+           -> Maybe CType       -- ^ The C type this type corresponds to+                                --   when using the CAPI FFI+           -> [PredType]        -- ^ Stupid theta: see 'algTcStupidTheta'+           -> AlgTyConRhs       -- ^ Information about data constructors+           -> AlgTyConFlav      -- ^ What flavour is it?+                                -- (e.g. vanilla, type family)+           -> Bool              -- ^ Was the 'TyCon' declared with GADT syntax?+           -> TyCon+mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn+  = AlgTyCon {+        tyConName        = name,+        tyConUnique      = nameUnique name,+        tyConBinders     = binders,+        tyConResKind     = res_kind,+        tyConKind        = mkTyConKind binders res_kind,+        tyConArity       = length binders,+        tyConTyVars      = binderVars binders,+        tcRoles          = roles,+        tyConCType       = cType,+        algTcStupidTheta = stupid,+        algTcRhs         = rhs,+        algTcFields      = fieldsOfAlgTcRhs rhs,+        algTcParent      = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent,+        algTcGadtSyntax  = gadt_syn+    }++-- | Simpler specialization of 'mkAlgTyCon' for classes+mkClassTyCon :: Name -> [TyConBinder]+             -> [Role] -> AlgTyConRhs -> Class+             -> Name -> TyCon+mkClassTyCon name binders roles rhs clas tc_rep_name+  = mkAlgTyCon name binders constraintKind roles Nothing [] rhs+               (ClassTyCon clas tc_rep_name)+               False++mkTupleTyCon :: Name+             -> [TyConBinder]+             -> Kind    -- ^ Result kind of the 'TyCon'+             -> Arity   -- ^ Arity of the tuple 'TyCon'+             -> DataCon+             -> TupleSort    -- ^ Whether the tuple is boxed or unboxed+             -> AlgTyConFlav+             -> TyCon+mkTupleTyCon name binders res_kind arity con sort parent+  = AlgTyCon {+        tyConUnique      = nameUnique name,+        tyConName        = name,+        tyConBinders     = binders,+        tyConTyVars      = binderVars binders,+        tyConResKind     = res_kind,+        tyConKind        = mkTyConKind binders res_kind,+        tyConArity       = arity,+        tcRoles          = replicate arity Representational,+        tyConCType       = Nothing,+        algTcGadtSyntax  = False,+        algTcStupidTheta = [],+        algTcRhs         = TupleTyCon { data_con = con,+                                        tup_sort = sort },+        algTcFields      = emptyDFsEnv,+        algTcParent      = parent+    }++mkSumTyCon :: Name+             -> [TyConBinder]+             -> Kind    -- ^ Kind of the resulting 'TyCon'+             -> Arity   -- ^ Arity of the sum+             -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'+             -> [DataCon]+             -> AlgTyConFlav+             -> TyCon+mkSumTyCon name binders res_kind arity tyvars cons parent+  = AlgTyCon {+        tyConUnique      = nameUnique name,+        tyConName        = name,+        tyConBinders     = binders,+        tyConTyVars      = tyvars,+        tyConResKind     = res_kind,+        tyConKind        = mkTyConKind binders res_kind,+        tyConArity       = arity,+        tcRoles          = replicate arity Representational,+        tyConCType       = Nothing,+        algTcGadtSyntax  = False,+        algTcStupidTheta = [],+        algTcRhs         = mkSumTyConRhs cons,+        algTcFields      = emptyDFsEnv,+        algTcParent      = parent+    }++-- | Makes a tycon suitable for use during type-checking. It stores+-- a variety of details about the definition of the TyCon, but no+-- right-hand side. It lives only during the type-checking of a+-- mutually-recursive group of tycons; it is then zonked to a proper+-- TyCon in zonkTcTyCon.+-- See also Note [Kind checking recursive type and class declarations]+-- in TcTyClsDecls.+mkTcTyCon :: Name+          -> [TyConBinder]+          -> Kind                -- ^ /result/ kind only+          -> [(Name,TcTyVar)]    -- ^ Scoped type variables;+                                 -- see Note [How TcTyCons work] in TcTyClsDecls+          -> Bool                -- ^ Is this TcTyCon generalised already?+          -> TyConFlavour        -- ^ What sort of 'TyCon' this represents+          -> TyCon+mkTcTyCon name binders res_kind scoped_tvs poly flav+  = TcTyCon { tyConUnique  = getUnique name+            , tyConName    = name+            , tyConTyVars  = binderVars binders+            , tyConBinders = binders+            , tyConResKind = res_kind+            , tyConKind    = mkTyConKind binders res_kind+            , tyConArity   = length binders+            , tcTyConScopedTyVars = scoped_tvs+            , tcTyConIsPoly       = poly+            , tcTyConFlavour      = flav }++-- | No scoped type variables (to be used with mkTcTyCon).+noTcTyConScopedTyVars :: [(Name, TcTyVar)]+noTcTyConScopedTyVars = []++-- | Create an unlifted primitive 'TyCon', such as @Int#@.+mkPrimTyCon :: Name -> [TyConBinder]+            -> Kind   -- ^ /result/ kind, never levity-polymorphic+            -> [Role] -> TyCon+mkPrimTyCon name binders res_kind roles+  = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name)++-- | Kind constructors+mkKindTyCon :: Name -> [TyConBinder]+            -> Kind  -- ^ /result/ kind+            -> [Role] -> Name -> TyCon+mkKindTyCon name binders res_kind roles rep_nm+  = tc+  where+    tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm)++-- | Create a lifted primitive 'TyCon' such as @RealWorld@+mkLiftedPrimTyCon :: Name -> [TyConBinder]+                  -> Kind   -- ^ /result/ kind+                  -> [Role] -> TyCon+mkLiftedPrimTyCon name binders res_kind roles+  = mkPrimTyCon' name binders res_kind roles False (Just rep_nm)+  where rep_nm = mkPrelTyConRepName name++mkPrimTyCon' :: Name -> [TyConBinder]+             -> Kind    -- ^ /result/ kind, never levity-polymorphic+                        -- (If you need a levity-polymorphic PrimTyCon, change+                        --  isTcLevPoly.)+             -> [Role]+             -> Bool -> Maybe TyConRepName -> TyCon+mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm+  = PrimTyCon {+        tyConName    = name,+        tyConUnique  = nameUnique name,+        tyConBinders = binders,+        tyConResKind = res_kind,+        tyConKind    = mkTyConKind binders res_kind,+        tyConArity   = length roles,+        tcRoles      = roles,+        isUnlifted   = is_unlifted,+        primRepName  = rep_nm+    }++-- | Create a type synonym 'TyCon'+mkSynonymTyCon :: Name -> [TyConBinder] -> Kind   -- ^ /result/ kind+               -> [Role] -> Type -> Bool -> Bool -> TyCon+mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free+  = SynonymTyCon {+        tyConName    = name,+        tyConUnique  = nameUnique name,+        tyConBinders = binders,+        tyConResKind = res_kind,+        tyConKind    = mkTyConKind binders res_kind,+        tyConArity   = length binders,+        tyConTyVars  = binderVars binders,+        tcRoles      = roles,+        synTcRhs     = rhs,+        synIsTau     = is_tau,+        synIsFamFree = is_fam_free+    }++-- | Create a type family 'TyCon'+mkFamilyTyCon :: Name -> [TyConBinder] -> Kind  -- ^ /result/ kind+              -> Maybe Name -> FamTyConFlav+              -> Maybe Class -> Injectivity -> TyCon+mkFamilyTyCon name binders res_kind resVar flav parent inj+  = FamilyTyCon+      { tyConUnique  = nameUnique name+      , tyConName    = name+      , tyConBinders = binders+      , tyConResKind = res_kind+      , tyConKind    = mkTyConKind binders res_kind+      , tyConArity   = length binders+      , tyConTyVars  = binderVars binders+      , famTcResVar  = resVar+      , famTcFlav    = flav+      , famTcParent  = classTyCon <$> parent+      , famTcInj     = inj+      }+++-- | Create a promoted data constructor 'TyCon'+-- Somewhat dodgily, we give it the same Name+-- as the data constructor itself; when we pretty-print+-- the TyCon we add a quote; see the Outputable TyCon instance+mkPromotedDataCon :: DataCon -> Name -> TyConRepName+                  -> [TyConTyCoBinder] -> Kind -> [Role]+                  -> RuntimeRepInfo -> TyCon+mkPromotedDataCon con name rep_name binders res_kind roles rep_info+  = PromotedDataCon {+        tyConUnique   = nameUnique name,+        tyConName     = name,+        tyConArity    = length roles,+        tcRoles       = roles,+        tyConBinders  = binders,+        tyConResKind  = res_kind,+        tyConKind     = mkTyConKind binders res_kind,+        dataCon       = con,+        tcRepName     = rep_name,+        promDcRepInfo = rep_info+  }++isFunTyCon :: TyCon -> Bool+isFunTyCon (FunTyCon {}) = True+isFunTyCon _             = False++-- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors)+isAbstractTyCon :: TyCon -> Bool+isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True+isAbstractTyCon _ = False++-- | Does this 'TyCon' represent something that cannot be defined in Haskell?+isPrimTyCon :: TyCon -> Bool+isPrimTyCon (PrimTyCon {}) = True+isPrimTyCon _              = False++-- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can+-- only be true for primitive and unboxed-tuple 'TyCon's+isUnliftedTyCon :: TyCon -> Bool+isUnliftedTyCon (PrimTyCon  {isUnlifted = is_unlifted})+  = is_unlifted+isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } )+  | TupleTyCon { tup_sort = sort } <- rhs+  = not (isBoxed (tupleSortBoxity sort))+isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } )+  | SumTyCon {} <- rhs+  = True+isUnliftedTyCon _ = False++-- | Returns @True@ if the supplied 'TyCon' resulted from either a+-- @data@ or @newtype@ declaration+isAlgTyCon :: TyCon -> Bool+isAlgTyCon (AlgTyCon {})   = True+isAlgTyCon _               = False++-- | Returns @True@ for vanilla AlgTyCons -- that is, those created+-- with a @data@ or @newtype@ declaration.+isVanillaAlgTyCon :: TyCon -> Bool+isVanillaAlgTyCon (AlgTyCon { algTcParent = VanillaAlgTyCon _ }) = True+isVanillaAlgTyCon _                                              = False++isDataTyCon :: TyCon -> Bool+-- ^ Returns @True@ for data types that are /definitely/ represented by+-- heap-allocated constructors.  These are scrutinised by Core-level+-- @case@ expressions, and they get info tables allocated for them.+--+-- Generally, the function will be true for all @data@ types and false+-- for @newtype@s, unboxed tuples, unboxed sums and type family+-- 'TyCon's. But it is not guaranteed to return @True@ in all cases+-- that it could.+--+-- NB: for a data type family, only the /instance/ 'TyCon's+--     get an info table.  The family declaration 'TyCon' does not+isDataTyCon (AlgTyCon {algTcRhs = rhs})+  = case rhs of+        TupleTyCon { tup_sort = sort }+                           -> isBoxed (tupleSortBoxity sort)+        SumTyCon {}        -> False+        DataTyCon {}       -> True+        NewTyCon {}        -> False+        AbstractTyCon {}   -> False      -- We don't know, so return False+isDataTyCon _ = False++-- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds+-- (where X is the role passed in):+--   If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2)+-- (where X1, X2, and X3, are the roles given by tyConRolesX tc X)+-- See also Note [Decomposing equality] in TcCanonical+isInjectiveTyCon :: TyCon -> Role -> Bool+isInjectiveTyCon _                             Phantom          = False+isInjectiveTyCon (FunTyCon {})                 _                = True+isInjectiveTyCon (AlgTyCon {})                 Nominal          = True+isInjectiveTyCon (AlgTyCon {algTcRhs = rhs})   Representational+  = isGenInjAlgRhs rhs+isInjectiveTyCon (SynonymTyCon {})             _                = False+isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ })+                                               Nominal          = True+isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj+isInjectiveTyCon (FamilyTyCon {})              _                = False+isInjectiveTyCon (PrimTyCon {})                _                = True+isInjectiveTyCon (PromotedDataCon {})          _                = True+isInjectiveTyCon (TcTyCon {})                  _                = True+  -- Reply True for TcTyCon to minimise knock on type errors+  -- See Note [How TcTyCons work] item (1) in TcTyClsDecls++-- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds+-- (where X is the role passed in):+--   If (T tys ~X t), then (t's head ~X T).+-- See also Note [Decomposing equality] in TcCanonical+isGenerativeTyCon :: TyCon -> Role -> Bool+isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True+isGenerativeTyCon (FamilyTyCon {}) _ = False+  -- in all other cases, injectivity implies generativity+isGenerativeTyCon tc               r = isInjectiveTyCon tc r++-- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective+-- with respect to representational equality?+isGenInjAlgRhs :: AlgTyConRhs -> Bool+isGenInjAlgRhs (TupleTyCon {})          = True+isGenInjAlgRhs (SumTyCon {})            = True+isGenInjAlgRhs (DataTyCon {})           = True+isGenInjAlgRhs (AbstractTyCon {})       = False+isGenInjAlgRhs (NewTyCon {})            = False++-- | Is this 'TyCon' that for a @newtype@+isNewTyCon :: TyCon -> Bool+isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True+isNewTyCon _                                   = False++-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it+-- expands into, and (possibly) a coercion from the representation type to the+-- @newtype@.+-- Returns @Nothing@ if this is not possible.+unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched)+unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs,+                                 algTcRhs = NewTyCon { nt_co = co,+                                                       nt_rhs = rhs }})+                           = Just (tvs, rhs, co)+unwrapNewTyCon_maybe _     = Nothing++unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched)+unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co,+                                                           nt_etad_rhs = (tvs,rhs) }})+                           = Just (tvs, rhs, co)+unwrapNewTyConEtad_maybe _ = Nothing++isProductTyCon :: TyCon -> Bool+-- True of datatypes or newtypes that have+--   one, non-existential, data constructor+-- See Note [Product types]+isProductTyCon tc@(AlgTyCon {})+  = case algTcRhs tc of+      TupleTyCon {} -> True+      DataTyCon{ data_cons = [data_con] }+                    -> null (dataConExTyCoVars data_con)+      NewTyCon {}   -> True+      _             -> False+isProductTyCon _ = False++isDataProductTyCon_maybe :: TyCon -> Maybe DataCon+-- True of datatypes (not newtypes) with+--   one, vanilla, data constructor+-- See Note [Product types]+isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs })+  = case rhs of+       DataTyCon { data_cons = [con] }+         | null (dataConExTyCoVars con)  -- non-existential+         -> Just con+       TupleTyCon { data_con = con }+         -> Just con+       _ -> Nothing+isDataProductTyCon_maybe _ = Nothing++isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon]+isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs })+  = case rhs of+      DataTyCon { data_cons = cons }+        | cons `lengthExceeds` 1+        , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this?+        -> Just cons+      SumTyCon { data_cons = cons }+        | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this?+        -> Just cons+      _ -> Nothing+isDataSumTyCon_maybe _ = Nothing++{- Note [Product types]+~~~~~~~~~~~~~~~~~~~~~~~+A product type is+ * A data type (not a newtype)+ * With one, boxed data constructor+ * That binds no existential type variables++The main point is that product types are amenable to unboxing for+  * Strict function calls; we can transform+        f (D a b) = e+    to+        fw a b = e+    via the worker/wrapper transformation.  (Question: couldn't this+    work for existentials too?)++  * CPR for function results; we can transform+        f x y = let ... in D a b+    to+        fw x y = let ... in (# a, b #)++Note that the data constructor /can/ have evidence arguments: equality+constraints, type classes etc.  So it can be GADT.  These evidence+arguments are simply value arguments, and should not get in the way.+-}+++-- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)?+isTypeSynonymTyCon :: TyCon -> Bool+isTypeSynonymTyCon (SynonymTyCon {}) = True+isTypeSynonymTyCon _                 = False++isTauTyCon :: TyCon -> Bool+isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau+isTauTyCon _                                    = True++isFamFreeTyCon :: TyCon -> Bool+isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free+isFamFreeTyCon (FamilyTyCon { famTcFlav = flav })         = isDataFamFlav flav+isFamFreeTyCon _                                          = True++-- As for newtypes, it is in some contexts important to distinguish between+-- closed synonyms and synonym families, as synonym families have no unique+-- right hand side to which a synonym family application can expand.+--++-- | True iff we can decompose (T a b c) into ((T a b) c)+--   I.e. is it injective and generative w.r.t nominal equality?+--   That is, if (T a b) ~N d e f, is it always the case that+--            (T ~N d), (a ~N e) and (b ~N f)?+-- Specifically NOT true of synonyms (open and otherwise)+--+-- It'd be unusual to call mustBeSaturated on a regular H98+-- type synonym, because you should probably have expanded it first+-- But regardless, it's not decomposable+mustBeSaturated :: TyCon -> Bool+mustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour++-- | Is this an algebraic 'TyCon' declared with the GADT syntax?+isGadtSyntaxTyCon :: TyCon -> Bool+isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res+isGadtSyntaxTyCon _                                    = False++-- | Is this an algebraic 'TyCon' which is just an enumeration of values?+isEnumerationTyCon :: TyCon -> Bool+-- See Note [Enumeration types] in GHC.Core.TyCon+isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs })+  = case rhs of+       DataTyCon { is_enum = res } -> res+       TupleTyCon {}               -> arity == 0+       _                           -> False+isEnumerationTyCon _ = False++-- | Is this a 'TyCon', synonym or otherwise, that defines a family?+isFamilyTyCon :: TyCon -> Bool+isFamilyTyCon (FamilyTyCon {}) = True+isFamilyTyCon _                = False++-- | Is this a 'TyCon', synonym or otherwise, that defines a family with+-- instances?+isOpenFamilyTyCon :: TyCon -> Bool+isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav })+  | OpenSynFamilyTyCon <- flav = True+  | DataFamilyTyCon {} <- flav = True+isOpenFamilyTyCon _            = False++-- | Is this a synonym 'TyCon' that can have may have further instances appear?+isTypeFamilyTyCon :: TyCon -> Bool+isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav)+isTypeFamilyTyCon _                                  = False++-- | Is this a synonym 'TyCon' that can have may have further instances appear?+isDataFamilyTyCon :: TyCon -> Bool+isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav+isDataFamilyTyCon _                                  = False++-- | Is this an open type family TyCon?+isOpenTypeFamilyTyCon :: TyCon -> Bool+isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True+isOpenTypeFamilyTyCon _                                               = False++-- | Is this a non-empty closed type family? Returns 'Nothing' for+-- abstract or empty closed families.+isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched)+isClosedSynFamilyTyConWithAxiom_maybe+  (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb+isClosedSynFamilyTyConWithAxiom_maybe _               = Nothing++-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ is @tc@ is an+-- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is+-- injective), or 'NotInjective' otherwise.+tyConInjectivityInfo :: TyCon -> Injectivity+tyConInjectivityInfo tc+  | FamilyTyCon { famTcInj = inj } <- tc+  = inj+  | isInjectiveTyCon tc Nominal+  = Injective (replicate (tyConArity tc) True)+  | otherwise+  = NotInjective++isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily+isBuiltInSynFamTyCon_maybe+  (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops+isBuiltInSynFamTyCon_maybe _                          = Nothing++isDataFamFlav :: FamTyConFlav -> Bool+isDataFamFlav (DataFamilyTyCon {}) = True   -- Data family+isDataFamFlav _                    = False  -- Type synonym family++-- | Is this TyCon for an associated type?+isTyConAssoc :: TyCon -> Bool+isTyConAssoc = isJust . tyConAssoc_maybe++-- | Get the enclosing class TyCon (if there is one) for the given TyCon.+tyConAssoc_maybe :: TyCon -> Maybe TyCon+tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour++-- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour+tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon+tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent)     = mb_parent+tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent+tyConFlavourAssoc_maybe _                                 = Nothing++-- The unit tycon didn't used to be classed as a tuple tycon+-- but I thought that was silly so I've undone it+-- If it can't be for some reason, it should be a AlgTyCon+isTupleTyCon :: TyCon -> Bool+-- ^ Does this 'TyCon' represent a tuple?+--+-- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to+-- 'isTupleTyCon', because they are built as 'AlgTyCons'.  However they+-- get spat into the interface file as tuple tycons, so I don't think+-- it matters.+isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True+isTupleTyCon _ = False++tyConTuple_maybe :: TyCon -> Maybe TupleSort+tyConTuple_maybe (AlgTyCon { algTcRhs = rhs })+  | TupleTyCon { tup_sort = sort} <- rhs = Just sort+tyConTuple_maybe _                       = Nothing++-- | Is this the 'TyCon' for an unboxed tuple?+isUnboxedTupleTyCon :: TyCon -> Bool+isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs })+  | TupleTyCon { tup_sort = sort } <- rhs+  = not (isBoxed (tupleSortBoxity sort))+isUnboxedTupleTyCon _ = False++-- | Is this the 'TyCon' for a boxed tuple?+isBoxedTupleTyCon :: TyCon -> Bool+isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs })+  | TupleTyCon { tup_sort = sort } <- rhs+  = isBoxed (tupleSortBoxity sort)+isBoxedTupleTyCon _ = False++-- | Is this the 'TyCon' for an unboxed sum?+isUnboxedSumTyCon :: TyCon -> Bool+isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs })+  | SumTyCon {} <- rhs+  = True+isUnboxedSumTyCon _ = False++-- | Is this the 'TyCon' for a /promoted/ tuple?+isPromotedTupleTyCon :: TyCon -> Bool+isPromotedTupleTyCon tyCon+  | Just dataCon <- isPromotedDataCon_maybe tyCon+  , isTupleTyCon (dataConTyCon dataCon) = True+  | otherwise                           = False++-- | Is this a PromotedDataCon?+isPromotedDataCon :: TyCon -> Bool+isPromotedDataCon (PromotedDataCon {}) = True+isPromotedDataCon _                    = False++-- | Retrieves the promoted DataCon if this is a PromotedDataCon;+isPromotedDataCon_maybe :: TyCon -> Maybe DataCon+isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc+isPromotedDataCon_maybe _ = Nothing++-- | Is this tycon really meant for use at the kind level? That is,+-- should it be permitted without -XDataKinds?+isKindTyCon :: TyCon -> Bool+isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys++-- | These TyCons should be allowed at the kind level, even without+-- -XDataKinds.+kindTyConKeys :: UniqSet Unique+kindTyConKeys = unionManyUniqSets+  ( mkUniqSet [ liftedTypeKindTyConKey, constraintKindTyConKey, tYPETyConKey ]+  : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon+                                          , vecCountTyCon, vecElemTyCon ] )+  where+    tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc)++isLiftedTypeKindTyConName :: Name -> Bool+isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey)++-- | Identifies implicit tycons that, in particular, do not go into interface+-- files (because they are implicitly reconstructed when the interface is+-- read).+--+-- Note that:+--+-- * Associated families are implicit, as they are re-constructed from+--   the class declaration in which they reside, and+--+-- * Family instances are /not/ implicit as they represent the instance body+--   (similar to a @dfun@ does that for a class instance).+--+-- * Tuples are implicit iff they have a wired-in name+--   (namely: boxed and unboxed tuples are wired-in and implicit,+--            but constraint tuples are not)+isImplicitTyCon :: TyCon -> Bool+isImplicitTyCon (FunTyCon {})        = True+isImplicitTyCon (PrimTyCon {})       = True+isImplicitTyCon (PromotedDataCon {}) = True+isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name })+  | TupleTyCon {} <- rhs             = isWiredInName name+  | SumTyCon {} <- rhs               = True+  | otherwise                        = False+isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent+isImplicitTyCon (SynonymTyCon {})    = False+isImplicitTyCon (TcTyCon {})         = False++tyConCType_maybe :: TyCon -> Maybe CType+tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc+tyConCType_maybe _ = Nothing++-- | Is this a TcTyCon? (That is, one only used during type-checking?)+isTcTyCon :: TyCon -> Bool+isTcTyCon (TcTyCon {}) = True+isTcTyCon _            = False++setTcTyConKind :: TyCon -> Kind -> TyCon+-- Update the Kind of a TcTyCon+-- The new kind is always a zonked version of its previous+-- kind, so we don't need to update any other fields.+-- See Note [The Purely Kinded Invariant] in TcHsType+setTcTyConKind tc@(TcTyCon {}) kind = tc { tyConKind = kind }+setTcTyConKind tc              _    = pprPanic "setTcTyConKind" (ppr tc)++-- | Could this TyCon ever be levity-polymorphic when fully applied?+-- True is safe. False means we're sure. Does only a quick check+-- based on the TyCon's category.+-- Precondition: The fully-applied TyCon has kind (TYPE blah)+isTcLevPoly :: TyCon -> Bool+isTcLevPoly FunTyCon{}           = False+isTcLevPoly (AlgTyCon { algTcParent = parent, algTcRhs = rhs })+  | UnboxedAlgTyCon _ <- parent+  = True+  | NewTyCon { nt_lev_poly = lev_poly } <- rhs+  = lev_poly -- Newtypes can be levity polymorphic with UnliftedNewtypes (#17360)+  | otherwise+  = False+isTcLevPoly SynonymTyCon{}       = True+isTcLevPoly FamilyTyCon{}        = True+isTcLevPoly PrimTyCon{}          = False+isTcLevPoly TcTyCon{}            = False+isTcLevPoly tc@PromotedDataCon{} = pprPanic "isTcLevPoly datacon" (ppr tc)++{-+-----------------------------------------------+--      Expand type-constructor applications+-----------------------------------------------+-}++expandSynTyCon_maybe+        :: TyCon+        -> [tyco]                 -- ^ Arguments to 'TyCon'+        -> Maybe ([(TyVar,tyco)],+                  Type,+                  [tyco])         -- ^ Returns a 'TyVar' substitution, the body+                                  -- type of the synonym (not yet substituted)+                                  -- and any arguments remaining from the+                                  -- application++-- ^ Expand a type synonym application, if any+expandSynTyCon_maybe tc tys+  | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc+  = case tys `listLengthCmp` arity of+        GT -> Just (tvs `zip` tys, rhs, drop arity tys)+        EQ -> Just (tvs `zip` tys, rhs, [])+        LT -> Nothing+   | otherwise+   = Nothing++----------------++-- | Check if the tycon actually refers to a proper `data` or `newtype`+--  with user defined constructors rather than one from a class or other+--  construction.++-- NB: This is only used in TcRnExports.checkPatSynParent to determine if an+-- exported tycon can have a pattern synonym bundled with it, e.g.,+-- module Foo (TyCon(.., PatSyn)) where+isTyConWithSrcDataCons :: TyCon -> Bool+isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) =+  case rhs of+    DataTyCon {}  -> isSrcParent+    NewTyCon {}   -> isSrcParent+    TupleTyCon {} -> isSrcParent+    _ -> False+  where+    isSrcParent = isNoParent parent+isTyConWithSrcDataCons (FamilyTyCon { famTcFlav = DataFamilyTyCon {} })+                         = True -- #14058+isTyConWithSrcDataCons _ = False+++-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no+-- constructors could be found+tyConDataCons :: TyCon -> [DataCon]+-- It's convenient for tyConDataCons to return the+-- empty list for type synonyms etc+tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` []++-- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon'+-- is the sort that can have any constructors (note: this does not include+-- abstract algebraic types)+tyConDataCons_maybe :: TyCon -> Maybe [DataCon]+tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs})+  = case rhs of+       DataTyCon { data_cons = cons } -> Just cons+       NewTyCon { data_con = con }    -> Just [con]+       TupleTyCon { data_con = con }  -> Just [con]+       SumTyCon { data_cons = cons }  -> Just cons+       _                              -> Nothing+tyConDataCons_maybe _ = Nothing++-- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@+-- type with one alternative, a tuple type or a @newtype@ then that constructor+-- is returned. If the 'TyCon' has more than one constructor, or represents a+-- primitive or function type constructor then @Nothing@ is returned. In any+-- other case, the function panics+tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon+tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs })+  = case rhs of+      DataTyCon { data_cons = [c] } -> Just c+      TupleTyCon { data_con = c }   -> Just c+      NewTyCon { data_con = c }     -> Just c+      _                             -> Nothing+tyConSingleDataCon_maybe _           = Nothing++tyConSingleDataCon :: TyCon -> DataCon+tyConSingleDataCon tc+  = case tyConSingleDataCon_maybe tc of+      Just c  -> c+      Nothing -> pprPanic "tyConDataCon" (ppr tc)++tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon+-- Returns (Just con) for single-constructor+-- *algebraic* data types *not* newtypes+tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs })+  = case rhs of+      DataTyCon { data_cons = [c] } -> Just c+      TupleTyCon { data_con = c }   -> Just c+      _                             -> Nothing+tyConSingleAlgDataCon_maybe _        = Nothing++-- | Determine the number of value constructors a 'TyCon' has. Panics if the+-- 'TyCon' is not algebraic or a tuple+tyConFamilySize  :: TyCon -> Int+tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs })+  = case rhs of+      DataTyCon { data_cons_size = size } -> size+      NewTyCon {}                    -> 1+      TupleTyCon {}                  -> 1+      SumTyCon { data_cons_size = size }  -> size+      _                              -> pprPanic "tyConFamilySize 1" (ppr tc)+tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc)++-- | Extract an 'AlgTyConRhs' with information about data constructors from an+-- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon'+algTyConRhs :: TyCon -> AlgTyConRhs+algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs+algTyConRhs other = pprPanic "algTyConRhs" (ppr other)++-- | Extract type variable naming the result of injective type family+tyConFamilyResVar_maybe :: TyCon -> Maybe Name+tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res+tyConFamilyResVar_maybe _                                 = Nothing++-- | Get the list of roles for the type parameters of a TyCon+tyConRoles :: TyCon -> [Role]+-- See also Note [TyCon Role signatures]+tyConRoles tc+  = case tc of+    { FunTyCon {}                         -> [Nominal, Nominal, Representational, Representational]+    ; AlgTyCon { tcRoles = roles }        -> roles+    ; SynonymTyCon { tcRoles = roles }    -> roles+    ; FamilyTyCon {}                      -> const_role Nominal+    ; PrimTyCon { tcRoles = roles }       -> roles+    ; PromotedDataCon { tcRoles = roles } -> roles+    ; TcTyCon {}                          -> const_role Nominal+    }+  where+    const_role r = replicate (tyConArity tc) r++-- | Extract the bound type variables and type expansion of a type synonym+-- 'TyCon'. Panics if the 'TyCon' is not a synonym+newTyConRhs :: TyCon -> ([TyVar], Type)+newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }})+    = (tvs, rhs)+newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon)++-- | The number of type parameters that need to be passed to a newtype to+-- resolve it. May be less than in the definition if it can be eta-contracted.+newTyConEtadArity :: TyCon -> Int+newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }})+        = length (fst tvs_rhs)+newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon)++-- | Extract the bound type variables and type expansion of an eta-contracted+-- type synonym 'TyCon'.  Panics if the 'TyCon' is not a synonym+newTyConEtadRhs :: TyCon -> ([TyVar], Type)+newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs+newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon)++-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to+-- construct something with the @newtype@s type from its representation type+-- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns+-- @Nothing@+newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched)+newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co+newTyConCo_maybe _                                               = Nothing++newTyConCo :: TyCon -> CoAxiom Unbranched+newTyConCo tc = case newTyConCo_maybe tc of+                 Just co -> co+                 Nothing -> pprPanic "newTyConCo" (ppr tc)++newTyConDataCon_maybe :: TyCon -> Maybe DataCon+newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con+newTyConDataCon_maybe _ = Nothing++-- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context+-- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration+-- @data Eq a => T a ...@+tyConStupidTheta :: TyCon -> [PredType]+tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid+tyConStupidTheta (FunTyCon {}) = []+tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon)++-- | Extract the 'TyVar's bound by a vanilla type synonym+-- and the corresponding (unsubstituted) right hand side.+synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type)+synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty})+  = Just (tyvars, ty)+synTyConDefn_maybe _ = Nothing++-- | Extract the information pertaining to the right hand side of a type synonym+-- (@type@) declaration.+synTyConRhs_maybe :: TyCon -> Maybe Type+synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs+synTyConRhs_maybe _                               = Nothing++-- | Extract the flavour of a type family (with all the extra information that+-- it carries)+famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav+famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav+famTyConFlav_maybe _                                = Nothing++-- | Is this 'TyCon' that for a class instance?+isClassTyCon :: TyCon -> Bool+isClassTyCon (AlgTyCon {algTcParent = ClassTyCon {}}) = True+isClassTyCon _                                        = False++-- | If this 'TyCon' is that for a class instance, return the class it is for.+-- Otherwise returns @Nothing@+tyConClass_maybe :: TyCon -> Maybe Class+tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas _}) = Just clas+tyConClass_maybe _                                            = Nothing++-- | Return the associated types of the 'TyCon', if any+tyConATs :: TyCon -> [TyCon]+tyConATs (AlgTyCon {algTcParent = ClassTyCon clas _}) = classATs clas+tyConATs _                                            = []++----------------------------------------------------------------------------+-- | Is this 'TyCon' that for a data family instance?+isFamInstTyCon :: TyCon -> Bool+isFamInstTyCon (AlgTyCon {algTcParent = DataFamInstTyCon {} })+  = True+isFamInstTyCon _ = False++tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched)+tyConFamInstSig_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax f ts })+  = Just (f, ts, ax)+tyConFamInstSig_maybe _ = Nothing++-- | If this 'TyCon' is that of a data family instance, return the family in question+-- and the instance types. Otherwise, return @Nothing@+tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])+tyConFamInst_maybe (AlgTyCon {algTcParent = DataFamInstTyCon _ f ts })+  = Just (f, ts)+tyConFamInst_maybe _ = Nothing++-- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which+-- represents a coercion identifying the representation type with the type+-- instance family.  Otherwise, return @Nothing@+tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched)+tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ })+  = Just ax+tyConFamilyCoercion_maybe _ = Nothing++-- | Extract any 'RuntimeRepInfo' from this TyCon+tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo+tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri+tyConRuntimeRepInfo _                                         = NoRRI+  -- could panic in that second case. But Douglas Adams told me not to.++{-+Note [Constructor tag allocation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When typechecking we need to allocate constructor tags to constructors.+They are allocated based on the position in the data_cons field of TyCon,+with the first constructor getting fIRST_TAG.++We used to pay linear cost per constructor, with each constructor looking up+its relative index in the constructor list. That was quadratic and prohibitive+for large data types with more than 10k constructors.++The current strategy is to build a NameEnv with a mapping from constructor's+Name to ConTag and pass it down to buildDataCon for efficient lookup.++Relevant ticket: #14657+-}++mkTyConTagMap :: TyCon -> NameEnv ConTag+mkTyConTagMap tycon =+  mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..]+  -- See Note [Constructor tag allocation]++{-+************************************************************************+*                                                                      *+\subsection[TyCon-instances]{Instance declarations for @TyCon@}+*                                                                      *+************************************************************************++@TyCon@s are compared by comparing their @Unique@s.+-}++instance Eq TyCon where+    a == b = getUnique a == getUnique b+    a /= b = getUnique a /= getUnique b++instance Uniquable TyCon where+    getUnique tc = tyConUnique tc++instance Outputable TyCon where+  -- At the moment a promoted TyCon has the same Name as its+  -- corresponding TyCon, so we add the quote to distinguish it here+  ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc+    where+      pp_tc = getPprStyle $ \sty -> if ((debugStyle sty || dumpStyle sty) && isTcTyCon tc)+                                    then text "[tc]"+                                    else empty++-- | Paints a picture of what a 'TyCon' represents, in broad strokes.+-- This is used towards more informative error messages.+data TyConFlavour+  = ClassFlavour+  | TupleFlavour Boxity+  | SumFlavour+  | DataTypeFlavour+  | NewtypeFlavour+  | AbstractTypeFlavour+  | DataFamilyFlavour (Maybe TyCon)     -- Just tc <=> (tc == associated class)+  | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class)+  | ClosedTypeFamilyFlavour+  | TypeSynonymFlavour+  | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'.+  | PromotedDataConFlavour+  deriving Eq++instance Outputable TyConFlavour where+  ppr = text . go+    where+      go ClassFlavour = "class"+      go (TupleFlavour boxed) | isBoxed boxed = "tuple"+                              | otherwise     = "unboxed tuple"+      go SumFlavour              = "unboxed sum"+      go DataTypeFlavour         = "data type"+      go NewtypeFlavour          = "newtype"+      go AbstractTypeFlavour     = "abstract type"+      go (DataFamilyFlavour (Just _))  = "associated data family"+      go (DataFamilyFlavour Nothing)   = "data family"+      go (OpenTypeFamilyFlavour (Just _)) = "associated type family"+      go (OpenTypeFamilyFlavour Nothing)  = "type family"+      go ClosedTypeFamilyFlavour = "type family"+      go TypeSynonymFlavour      = "type synonym"+      go BuiltInTypeFlavour      = "built-in type"+      go PromotedDataConFlavour  = "promoted data constructor"++tyConFlavour :: TyCon -> TyConFlavour+tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs })+  | ClassTyCon _ _ <- parent = ClassFlavour+  | otherwise = case rhs of+                  TupleTyCon { tup_sort = sort }+                                     -> TupleFlavour (tupleSortBoxity sort)+                  SumTyCon {}        -> SumFlavour+                  DataTyCon {}       -> DataTypeFlavour+                  NewTyCon {}        -> NewtypeFlavour+                  AbstractTyCon {}   -> AbstractTypeFlavour+tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent })+  = case flav of+      DataFamilyTyCon{}            -> DataFamilyFlavour parent+      OpenSynFamilyTyCon           -> OpenTypeFamilyFlavour parent+      ClosedSynFamilyTyCon{}       -> ClosedTypeFamilyFlavour+      AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour+      BuiltInSynFamTyCon{}         -> ClosedTypeFamilyFlavour+tyConFlavour (SynonymTyCon {})    = TypeSynonymFlavour+tyConFlavour (FunTyCon {})        = BuiltInTypeFlavour+tyConFlavour (PrimTyCon {})       = BuiltInTypeFlavour+tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour+tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav++-- | Can this flavour of 'TyCon' appear unsaturated?+tcFlavourMustBeSaturated :: TyConFlavour -> Bool+tcFlavourMustBeSaturated ClassFlavour            = False+tcFlavourMustBeSaturated DataTypeFlavour         = False+tcFlavourMustBeSaturated NewtypeFlavour          = False+tcFlavourMustBeSaturated DataFamilyFlavour{}     = False+tcFlavourMustBeSaturated TupleFlavour{}          = False+tcFlavourMustBeSaturated SumFlavour              = False+tcFlavourMustBeSaturated AbstractTypeFlavour     = False+tcFlavourMustBeSaturated BuiltInTypeFlavour      = False+tcFlavourMustBeSaturated PromotedDataConFlavour  = False+tcFlavourMustBeSaturated TypeSynonymFlavour      = True+tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True+tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True++-- | Is this flavour of 'TyCon' an open type family or a data family?+tcFlavourIsOpen :: TyConFlavour -> Bool+tcFlavourIsOpen DataFamilyFlavour{}     = True+tcFlavourIsOpen OpenTypeFamilyFlavour{} = True+tcFlavourIsOpen ClosedTypeFamilyFlavour = False+tcFlavourIsOpen ClassFlavour            = False+tcFlavourIsOpen DataTypeFlavour         = False+tcFlavourIsOpen NewtypeFlavour          = False+tcFlavourIsOpen TupleFlavour{}          = False+tcFlavourIsOpen SumFlavour              = False+tcFlavourIsOpen AbstractTypeFlavour     = False+tcFlavourIsOpen BuiltInTypeFlavour      = False+tcFlavourIsOpen PromotedDataConFlavour  = False+tcFlavourIsOpen TypeSynonymFlavour      = False++pprPromotionQuote :: TyCon -> SDoc+-- Promoted data constructors already have a tick in their OccName+pprPromotionQuote tc+  = case tc of+      PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types+      _                  -> empty++instance NamedThing TyCon where+    getName = tyConName++instance Data.Data TyCon where+    -- don't traverse?+    toConstr _   = abstractConstr "TyCon"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "TyCon"++instance Binary Injectivity where+    put_ bh NotInjective   = putByte bh 0+    put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs++    get bh = do { h <- getByte bh+                ; case h of+                    0 -> return NotInjective+                    _ -> do { xs <- get bh+                            ; return (Injective xs) } }++{-+************************************************************************+*                                                                      *+           Walking over recursive TyCons+*                                                                      *+************************************************************************++Note [Expanding newtypes and products]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When expanding a type to expose a data-type constructor, we need to be+careful about newtypes, lest we fall into an infinite loop. Here are+the key examples:++  newtype Id  x = MkId x+  newtype Fix f = MkFix (f (Fix f))+  newtype T     = MkT (T -> T)++  Type           Expansion+ --------------------------+  T              T -> T+  Fix Maybe      Maybe (Fix Maybe)+  Id (Id Int)    Int+  Fix Id         NO NO NO++Notice that+ * We can expand T, even though it's recursive.+ * We can expand Id (Id Int), even though the Id shows up+   twice at the outer level, because Id is non-recursive++So, when expanding, we keep track of when we've seen a recursive+newtype at outermost level; and bail out if we see it again.++We sometimes want to do the same for product types, so that the+strictness analyser doesn't unbox infinitely deeply.++More precisely, we keep a *count* of how many times we've seen it.+This is to account for+   data instance T (a,b) = MkT (T a) (T b)+Then (#10482) if we have a type like+        T (Int,(Int,(Int,(Int,Int))))+we can still unbox deeply enough during strictness analysis.+We have to treat T as potentially recursive, but it's still+good to be able to unwrap multiple layers.++The function that manages all this is checkRecTc.+-}++data RecTcChecker = RC !Int (NameEnv Int)+  -- The upper bound, and the number of times+  -- we have encountered each TyCon++-- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'.+initRecTc :: RecTcChecker+initRecTc = RC defaultRecTcMaxBound emptyNameEnv++-- | The default upper bound (100) for the number of times a 'RecTcChecker' is+-- allowed to encounter each 'TyCon'.+defaultRecTcMaxBound :: Int+defaultRecTcMaxBound = 100+-- Should we have a flag for this?++-- | Change the upper bound for the number of times a 'RecTcChecker' is allowed+-- to encounter each 'TyCon'.+setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker+setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts++checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker+-- Nothing      => Recursion detected+-- Just rec_tcs => Keep going+checkRecTc (RC bound rec_nts) tc+  = case lookupNameEnv rec_nts tc_name of+      Just n | n >= bound -> Nothing+             | otherwise  -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1)))+      Nothing             -> Just (RC bound (extendNameEnv rec_nts tc_name 1))+  where+    tc_name = tyConName tc++-- | Returns whether or not this 'TyCon' is definite, or a hole+-- that may be filled in at some later point.  See Note [Skolem abstract data]+tyConSkolem :: TyCon -> Bool+tyConSkolem = isHoleName . tyConName++-- Note [Skolem abstract data]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Skolem abstract data arises from data declarations in an hsig file.+--+-- The best analogy is to interpret the types declared in signature files as+-- elaborating to universally quantified type variables; e.g.,+--+--    unit p where+--        signature H where+--            data T+--            data S+--        module M where+--            import H+--            f :: (T ~ S) => a -> b+--            f x = x+--+-- elaborates as (with some fake structural types):+--+--    p :: forall t s. { f :: forall a b. t ~ s => a -> b }+--    p = { f = \x -> x } -- ill-typed+--+-- It is clear that inside p, t ~ s is not provable (and+-- if we tried to write a function to cast t to s, that+-- would not work), but if we call p @Int @Int, clearly Int ~ Int+-- is provable.  The skolem variables are all distinct from+-- one another, but we can't make assumptions like "f is+-- inaccessible", because the skolem variables will get+-- instantiated eventually!+--+-- Skolem abstractness can apply to "non-abstract" data as well):+--+--    unit p where+--        signature H1 where+--            data T = MkT+--        signature H2 where+--            data T = MkT+--        module M where+--            import qualified H1+--            import qualified H2+--            f :: (H1.T ~ H2.T) => a -> b+--            f x = x+--+-- This is why the test is on the original name of the TyCon,+-- not whether it is abstract or not.
+ compiler/GHC/Core/TyCon.hs-boot view
@@ -0,0 +1,9 @@+module GHC.Core.TyCon where++import GhcPrelude++data TyCon++isTupleTyCon        :: TyCon -> Bool+isUnboxedTupleTyCon :: TyCon -> Bool+isFunTyCon          :: TyCon -> Bool
+ compiler/GHC/Core/Type.hs view
@@ -0,0 +1,3241 @@+-- (c) The University of Glasgow 2006+-- (c) The GRASP/AQUA Project, Glasgow University, 1998+--+-- Type - public interface++{-# LANGUAGE CPP, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++-- | Main functions for manipulating types and type-related things+module GHC.Core.Type (+        -- Note some of this is just re-exports from TyCon..++        -- * Main data types representing Types+        -- $type_classification++        -- $representation_types+        TyThing(..), Type, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..),+        KindOrType, PredType, ThetaType,+        Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder,+        KnotTied,++        -- ** Constructing and deconstructing types+        mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe,+        getCastedTyVar_maybe, tyVarKind, varType,++        mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys,+        splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe,++        mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys,+        splitFunTy, splitFunTy_maybe,+        splitFunTys, funResultTy, funArgTy,++        mkTyConApp, mkTyConTy,+        tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,+        tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,+        splitTyConApp_maybe, splitTyConApp, tyConAppArgN,+        tcSplitTyConApp_maybe,+        splitListTyConApp_maybe,+        repSplitTyConApp_maybe,++        mkForAllTy, mkForAllTys, mkTyCoInvForAllTys,+        mkSpecForAllTy, mkSpecForAllTys,+        mkVisForAllTys, mkTyCoInvForAllTy,+        mkInvForAllTy, mkInvForAllTys,+        splitForAllTys, splitForAllTysSameVis,+        splitForAllVarBndrs,+        splitForAllTy_maybe, splitForAllTy,+        splitForAllTy_ty_maybe, splitForAllTy_co_maybe,+        splitPiTy_maybe, splitPiTy, splitPiTys,+        mkTyConBindersPreferAnon,+        mkPiTy, mkPiTys,+        mkLamType, mkLamTypes,+        piResultTy, piResultTys,+        applyTysX, dropForAlls,+        mkFamilyTyConApp,+        buildSynTyCon,++        mkNumLitTy, isNumLitTy,+        mkStrLitTy, isStrLitTy,+        isLitTy,++        isPredTy,++        getRuntimeRep_maybe, kindRep_maybe, kindRep,++        mkCastTy, mkCoercionTy, splitCastTy_maybe,+        discardCast,++        userTypeError_maybe, pprUserTypeErrorTy,++        coAxNthLHS,+        stripCoercionTy,++        splitPiTysInvisible, splitPiTysInvisibleN,+        invisibleTyBndrCount,+        filterOutInvisibleTypes, filterOutInferredTypes,+        partitionInvisibleTypes, partitionInvisibles,+        tyConArgFlags, appTyArgFlags,+        synTyConResKind,++        modifyJoinResTy, setJoinResTy,++        -- ** Analyzing types+        TyCoMapper(..), mapTyCo, mapTyCoX,+        TyCoFolder(..), foldTyCo,++        -- (Newtypes)+        newTyConInstRhs,++        -- ** Binders+        sameVis,+        mkTyCoVarBinder, mkTyCoVarBinders,+        mkTyVarBinders,+        mkAnonBinder,+        isAnonTyCoBinder,+        binderVar, binderVars, binderType, binderArgFlag,+        tyCoBinderType, tyCoBinderVar_maybe,+        tyBinderType,+        binderRelevantType_maybe,+        isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder,+        isInvisibleBinder, isNamedBinder,+        tyConBindersTyCoBinders,++        -- ** Common type constructors+        funTyCon,++        -- ** Predicates on types+        isTyVarTy, isFunTy, isCoercionTy,+        isCoercionTy_maybe, isForAllTy,+        isForAllTy_ty, isForAllTy_co,+        isPiTy, isTauTy, isFamFreeTy,+        isCoVarType,++        isValidJoinPointType,+        tyConAppNeedsKindSig,++        -- *** Levity and boxity+        isLiftedType_maybe,+        isLiftedTypeKind, isUnliftedTypeKind,+        isLiftedRuntimeRep, isUnliftedRuntimeRep,+        isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType,+        isAlgType, isDataFamilyAppType,+        isPrimitiveType, isStrictType,+        isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,+        dropRuntimeRepArgs,+        getRuntimeRep,++        -- * Main data types representing Kinds+        Kind,++        -- ** Finding the kind of a type+        typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly,+        tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind,+        tcIsRuntimeTypeKind,++        -- ** Common Kind+        liftedTypeKind,++        -- * Type free variables+        tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs,+        tyCoVarsOfType, tyCoVarsOfTypes,+        tyCoVarsOfTypeDSet,+        coVarsOfType,+        coVarsOfTypes,++        noFreeVarsOfType,+        splitVisVarsOfType, splitVisVarsOfTypes,+        expandTypeSynonyms,+        typeSize, occCheckExpand,++        -- ** Closing over kinds+        closeOverKindsDSet, closeOverKindsList,+        closeOverKinds,++        -- * Well-scoped lists of variables+        scopedSort, tyCoVarsOfTypeWellScoped,+        tyCoVarsOfTypesWellScoped,++        -- * Type comparison+        eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX,+        nonDetCmpTypesX, nonDetCmpTc,+        eqVarBndrs,++        -- * Forcing evaluation of types+        seqType, seqTypes,++        -- * Other views onto Types+        coreView, tcView,++        tyConsOfType,++        -- * Main type substitution data types+        TvSubstEnv,     -- Representation widely visible+        TCvSubst(..),    -- Representation visible to a few friends++        -- ** Manipulating type substitutions+        emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst,++        mkTCvSubst, zipTvSubst, mkTvSubstPrs,+        zipTCvSubst,+        notElemTCvSubst,+        getTvSubstEnv, setTvSubstEnv,+        zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs,+        extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet,+        extendTCvSubst, extendCvSubst,+        extendTvSubst, extendTvSubstBinderAndInScope,+        extendTvSubstList, extendTvSubstAndInScope,+        extendTCvSubstList,+        extendTvSubstWithClone,+        extendTCvSubstWithClone,+        isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv,+        isEmptyTCvSubst, unionTCvSubst,++        -- ** Performing substitution on types and kinds+        substTy, substTys, substTyWith, substTysWith, substTheta,+        substTyAddInScope,+        substTyUnchecked, substTysUnchecked, substThetaUnchecked,+        substTyWithUnchecked,+        substCoUnchecked, substCoWithUnchecked,+        substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,+        substVarBndr, substVarBndrs,+        cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,++        -- * Tidying type related things up for printing+        tidyType,      tidyTypes,+        tidyOpenType,  tidyOpenTypes,+        tidyOpenKind,+        tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars,+        tidyOpenTyCoVar, tidyOpenTyCoVars,+        tidyTyCoVarOcc,+        tidyTopType,+        tidyKind,+        tidyTyCoVarBinder, tidyTyCoVarBinders,++        -- * Kinds+        isConstraintKindCon,+        classifiesTypeWithValues,+        isKindLevPoly+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Types.Basic++-- We import the representation and primitive functions from GHC.Core.TyCo.Rep.+-- Many things are reexported, but not the representation!++import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.Tidy+import GHC.Core.TyCo.FVs++-- friends:+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Unique.Set++import GHC.Core.TyCon+import TysPrim+import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind+                                 , typeSymbolKind, liftedTypeKind+                                 , liftedTypeKindTyCon+                                 , constraintKind )+import GHC.Types.Name( Name )+import PrelNames+import GHC.Core.Coercion.Axiom+import {-# SOURCE #-} GHC.Core.Coercion+   ( mkNomReflCo, mkGReflCo, mkReflCo+   , mkTyConAppCo, mkAppCo, mkCoVarCo, mkAxiomRuleCo+   , mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo+   , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo+   , mkKindCo, mkSubCo, mkFunCo, mkAxiomInstCo+   , decomposePiCos, coercionKind, coercionLKind+   , coercionRKind, coercionType+   , isReflexiveCo, seqCo )++-- others+import Util+import FV+import Outputable+import FastString+import Pair+import ListSetOps+import GHC.Types.Unique ( nonDetCmpUnique )++import Maybes           ( orElse )+import Data.Maybe       ( isJust )+import Control.Monad    ( guard )++-- $type_classification+-- #type_classification#+--+-- Types are one of:+--+-- [Unboxed]            Iff its representation is other than a pointer+--                      Unboxed types are also unlifted.+--+-- [Lifted]             Iff it has bottom as an element.+--                      Closures always have lifted types: i.e. any+--                      let-bound identifier in Core must have a lifted+--                      type. Operationally, a lifted object is one that+--                      can be entered.+--                      Only lifted types may be unified with a type variable.+--+-- [Algebraic]          Iff it is a type with one or more constructors, whether+--                      declared with @data@ or @newtype@.+--                      An algebraic type is one that can be deconstructed+--                      with a case expression. This is /not/ the same as+--                      lifted types, because we also include unboxed+--                      tuples in this classification.+--+-- [Data]               Iff it is a type declared with @data@, or a boxed tuple.+--+-- [Primitive]          Iff it is a built-in type that can't be expressed in Haskell.+--+-- Currently, all primitive types are unlifted, but that's not necessarily+-- the case: for example, @Int@ could be primitive.+--+-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed+-- but unlifted (such as @ByteArray#@).  The only primitive types that we+-- classify as algebraic are the unboxed tuples.+--+-- Some examples of type classifications that may make this a bit clearer are:+--+-- @+-- Type          primitive       boxed           lifted          algebraic+-- -----------------------------------------------------------------------------+-- Int#          Yes             No              No              No+-- ByteArray#    Yes             Yes             No              No+-- (\# a, b \#)  Yes             No              No              Yes+-- (\# a | b \#) Yes             No              No              Yes+-- (  a, b  )    No              Yes             Yes             Yes+-- [a]           No              Yes             Yes             Yes+-- @++-- $representation_types+-- A /source type/ is a type that is a separate type as far as the type checker is+-- concerned, but which has a more low-level representation as far as Core-to-Core+-- passes and the rest of the back end is concerned.+--+-- You don't normally have to worry about this, as the utility functions in+-- this module will automatically convert a source into a representation type+-- if they are spotted, to the best of its abilities. If you don't want this+-- to happen, use the equivalent functions from the "TcType" module.++{-+************************************************************************+*                                                                      *+                Type representation+*                                                                      *+************************************************************************++Note [coreView vs tcView]+~~~~~~~~~~~~~~~~~~~~~~~~~+So far as the typechecker is concerned, 'Constraint' and 'TYPE+LiftedRep' are distinct kinds.++But in Core these two are treated as identical.++We implement this by making 'coreView' convert 'Constraint' to 'TYPE+LiftedRep' on the fly.  The function tcView (used in the type checker)+does not do this.++See also #11715, which tracks removing this inconsistency.++-}++-- | Gives the typechecker view of a type. This unwraps synonyms but+-- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into+-- TYPE LiftedRep. Returns Nothing if no unwrapping happens.+-- See also Note [coreView vs tcView]+{-# INLINE tcView #-}+tcView :: Type -> Maybe Type+tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys+  = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')+               -- The free vars of 'rhs' should all be bound by 'tenv', so it's+               -- ok to use 'substTy' here.+               -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.+               -- Its important to use mkAppTys, rather than (foldl AppTy),+               -- because the function part might well return a+               -- partially-applied type constructor; indeed, usually will!+tcView _ = Nothing++{-# INLINE coreView #-}+coreView :: Type -> Maybe Type+-- ^ This function Strips off the /top layer only/ of a type synonym+-- application (if any) its underlying representation type.+-- Returns Nothing if there is nothing to look through.+-- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@.+--+-- By being non-recursive and inlined, this case analysis gets efficiently+-- joined onto the case analysis that the caller is already doing+coreView ty@(TyConApp tc tys)+  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys+  = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')+    -- This equation is exactly like tcView++  -- At the Core level, Constraint = Type+  -- See Note [coreView vs tcView]+  | isConstraintKindCon tc+  = ASSERT2( null tys, ppr ty )+    Just liftedTypeKind++coreView _ = Nothing++-----------------------------------------------+expandTypeSynonyms :: Type -> Type+-- ^ Expand out all type synonyms.  Actually, it'd suffice to expand out+-- just the ones that discard type variables (e.g.  type Funny a = Int)+-- But we don't know which those are currently, so we just expand all.+--+-- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type,+-- not in the kinds of any TyCon or TyVar mentioned in the type.+--+-- Keep this synchronized with 'synonymTyConsOfType'+expandTypeSynonyms ty+  = go (mkEmptyTCvSubst in_scope) ty+  where+    in_scope = mkInScopeSet (tyCoVarsOfType ty)++    go subst (TyConApp tc tys)+      | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys+      = let subst' = mkTvSubst in_scope (mkVarEnv tenv)+            -- Make a fresh substitution; rhs has nothing to+            -- do with anything that has happened so far+            -- NB: if you make changes here, be sure to build an+            --     /idempotent/ substitution, even in the nested case+            --        type T a b = a -> b+            --        type S x y = T y x+            -- (#11665)+        in  mkAppTys (go subst' rhs) tys'+      | otherwise+      = TyConApp tc expanded_tys+      where+        expanded_tys = (map (go subst) tys)++    go _     (LitTy l)     = LitTy l+    go subst (TyVarTy tv)  = substTyVar subst tv+    go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2)+    go subst ty@(FunTy _ arg res)+      = ty { ft_arg = go subst arg, ft_res = go subst res }+    go subst (ForAllTy (Bndr tv vis) t)+      = let (subst', tv') = substVarBndrUsing go subst tv in+        ForAllTy (Bndr tv' vis) (go subst' t)+    go subst (CastTy ty co)  = mkCastTy (go subst ty) (go_co subst co)+    go subst (CoercionTy co) = mkCoercionTy (go_co subst co)++    go_mco _     MRefl    = MRefl+    go_mco subst (MCo co) = MCo (go_co subst co)++    go_co subst (Refl ty)+      = mkNomReflCo (go subst ty)+    go_co subst (GRefl r ty mco)+      = mkGReflCo r (go subst ty) (go_mco subst mco)+       -- NB: coercions are always expanded upon creation+    go_co subst (TyConAppCo r tc args)+      = mkTyConAppCo r tc (map (go_co subst) args)+    go_co subst (AppCo co arg)+      = mkAppCo (go_co subst co) (go_co subst arg)+    go_co subst (ForAllCo tv kind_co co)+      = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in+        mkForAllCo tv' kind_co' (go_co subst' co)+    go_co subst (FunCo r co1 co2)+      = mkFunCo r (go_co subst co1) (go_co subst co2)+    go_co subst (CoVarCo cv)+      = substCoVar subst cv+    go_co subst (AxiomInstCo ax ind args)+      = mkAxiomInstCo ax ind (map (go_co subst) args)+    go_co subst (UnivCo p r t1 t2)+      = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2)+    go_co subst (SymCo co)+      = mkSymCo (go_co subst co)+    go_co subst (TransCo co1 co2)+      = mkTransCo (go_co subst co1) (go_co subst co2)+    go_co subst (NthCo r n co)+      = mkNthCo r n (go_co subst co)+    go_co subst (LRCo lr co)+      = mkLRCo lr (go_co subst co)+    go_co subst (InstCo co arg)+      = mkInstCo (go_co subst co) (go_co subst arg)+    go_co subst (KindCo co)+      = mkKindCo (go_co subst co)+    go_co subst (SubCo co)+      = mkSubCo (go_co subst co)+    go_co subst (AxiomRuleCo ax cs)+      = AxiomRuleCo ax (map (go_co subst) cs)+    go_co _ (HoleCo h)+      = pprPanic "expandTypeSynonyms hit a hole" (ppr h)++    go_prov subst (PhantomProv co)    = PhantomProv (go_co subst co)+    go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co)+    go_prov _     p@(PluginProv _)    = p++      -- the "False" and "const" are to accommodate the type of+      -- substForAllCoBndrUsing, which is general enough to+      -- handle coercion optimization (which sometimes swaps the+      -- order of a coercion)+    go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst+++-- | Extract the RuntimeRep classifier of a type from its kind. For example,+-- @kindRep * = LiftedRep@; Panics if this is not possible.+-- Treats * and Constraint as the same+kindRep :: HasDebugCallStack => Kind -> Type+kindRep k = case kindRep_maybe k of+              Just r  -> r+              Nothing -> pprPanic "kindRep" (ppr k)++-- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr.+-- For example, @kindRep_maybe * = Just LiftedRep@+-- Returns 'Nothing' if the kind is not of form (TYPE rr)+-- Treats * and Constraint as the same+kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type+kindRep_maybe kind+  | Just kind' <- coreView kind = kindRep_maybe kind'+  | TyConApp tc [arg] <- kind+  , tc `hasKey` tYPETyConKey    = Just arg+  | otherwise                   = Nothing++-- | This version considers Constraint to be the same as *. Returns True+-- if the argument is equivalent to Type/Constraint and False otherwise.+-- See Note [Kind Constraint and kind Type]+isLiftedTypeKind :: Kind -> Bool+isLiftedTypeKind kind+  = case kindRep_maybe kind of+      Just rep -> isLiftedRuntimeRep rep+      Nothing  -> False++isLiftedRuntimeRep :: Type -> Bool+-- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep+-- False of type variables (a :: RuntimeRep)+--   and of other reps e.g. (IntRep :: RuntimeRep)+isLiftedRuntimeRep rep+  | Just rep' <- coreView rep          = isLiftedRuntimeRep rep'+  | TyConApp rr_tc args <- rep+  , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True+  | otherwise                          = False++-- | Returns True if the kind classifies unlifted types and False otherwise.+-- Note that this returns False for levity-polymorphic kinds, which may+-- be specialized to a kind that classifies unlifted types.+isUnliftedTypeKind :: Kind -> Bool+isUnliftedTypeKind kind+  = case kindRep_maybe kind of+      Just rep -> isUnliftedRuntimeRep rep+      Nothing  -> False++isUnliftedRuntimeRep :: Type -> Bool+-- True of definitely-unlifted RuntimeReps+-- False of           (LiftedRep :: RuntimeRep)+--   and of variables (a :: RuntimeRep)+isUnliftedRuntimeRep rep+  | Just rep' <- coreView rep = isUnliftedRuntimeRep rep'+  | TyConApp rr_tc _ <- rep   -- NB: args might be non-empty+                              --     e.g. TupleRep [r1, .., rn]+  = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey)+        -- Avoid searching all the unlifted RuntimeRep type cons+        -- In the RuntimeRep data type, only LiftedRep is lifted+        -- But be careful of type families (F tys) :: RuntimeRep+  | otherwise {- Variables, applications -}+  = False++-- | Is this the type 'RuntimeRep'?+isRuntimeRepTy :: Type -> Bool+isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty'+isRuntimeRepTy (TyConApp tc args)+  | tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True+isRuntimeRepTy _ = False++-- | Is a tyvar of type 'RuntimeRep'?+isRuntimeRepVar :: TyVar -> Bool+isRuntimeRepVar = isRuntimeRepTy . tyVarKind+++{- *********************************************************************+*                                                                      *+               mapType+*                                                                      *+************************************************************************++These functions do a map-like operation over types, performing some operation+on all variables and binding sites. Primarily used for zonking.++Note [Efficiency for ForAllCo case of mapTyCoX]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As noted in Note [Forall coercions] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant.+It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches+the left-hand kind of the coercion. This is convenient lots of the time, but+not when mapping a function over a coercion.++The problem is that tcm_tybinder will affect the TyCoVar's kind and+mapCoercion will affect the Coercion, and we hope that the results will be+the same. Even if they are the same (which should generally happen with+correct algorithms), then there is an efficiency issue. In particular,+this problem seems to make what should be a linear algorithm into a potentially+exponential one. But it's only going to be bad in the case where there's+lots of foralls in the kinds of other foralls. Like this:++  forall a : (forall b : (forall c : ...). ...). ...++This construction seems unlikely. So we'll do the inefficient, easy way+for now.++Note [Specialising mappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+These INLINE pragmas are indispensable. mapTyCo and mapTyCoX are used+to implement zonking, and it's vital that they get specialised to the TcM+monad and the particular mapper in use.++Even specialising to the monad alone made a 20% allocation difference+in perf/compiler/T5030.++See Note [Specialising foldType] in TyCoRep for more details of this+idiom.+-}++-- | This describes how a "map" operation over a type/coercion should behave+data TyCoMapper env m+  = TyCoMapper+      { tcm_tyvar :: env -> TyVar -> m Type+      , tcm_covar :: env -> CoVar -> m Coercion+      , tcm_hole  :: env -> CoercionHole -> m Coercion+          -- ^ What to do with coercion holes.+          -- See Note [Coercion holes] in GHC.Core.TyCo.Rep.++      , tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar)+          -- ^ The returned env is used in the extended scope++      , tcm_tycon :: TyCon -> m TyCon+          -- ^ This is used only for TcTyCons+          -- a) To zonk TcTyCons+          -- b) To turn TcTyCons into TyCons.+          --    See Note [Type checking recursive type and class declarations]+          --    in TcTyClsDecls+      }++{-# INLINE mapTyCo #-}  -- See Note [Specialising mappers]+mapTyCo :: Monad m => TyCoMapper () m+         -> ( Type       -> m Type+            , [Type]     -> m [Type]+            , Coercion   -> m Coercion+            , [Coercion] -> m[Coercion])+mapTyCo mapper+  = case mapTyCoX mapper of+     (go_ty, go_tys, go_co, go_cos)+        -> (go_ty (), go_tys (), go_co (), go_cos ())++{-# INLINE mapTyCoX #-}  -- See Note [Specialising mappers]+mapTyCoX :: Monad m => TyCoMapper env m+         -> ( env -> Type       -> m Type+            , env -> [Type]     -> m [Type]+            , env -> Coercion   -> m Coercion+            , env -> [Coercion] -> m[Coercion])+mapTyCoX (TyCoMapper { tcm_tyvar = tyvar+                     , tcm_tycobinder = tycobinder+                     , tcm_tycon = tycon+                     , tcm_covar = covar+                     , tcm_hole = cohole })+  = (go_ty, go_tys, go_co, go_cos)+  where+    go_tys _   []       = return []+    go_tys env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys++    go_ty env (TyVarTy tv)    = tyvar env tv+    go_ty env (AppTy t1 t2)   = mkAppTy <$> go_ty env t1 <*> go_ty env t2+    go_ty _   ty@(LitTy {})   = return ty+    go_ty env (CastTy ty co)  = mkCastTy <$> go_ty env ty <*> go_co env co+    go_ty env (CoercionTy co) = CoercionTy <$> go_co env co++    go_ty env ty@(FunTy _ arg res)+      = do { arg' <- go_ty env arg; res' <- go_ty env res+           ; return (ty { ft_arg = arg', ft_res = res' }) }++    go_ty env ty@(TyConApp tc tys)+      | isTcTyCon tc+      = do { tc' <- tycon tc+           ; mkTyConApp tc' <$> go_tys env tys }++      -- Not a TcTyCon+      | null tys    -- Avoid allocation in this very+      = return ty   -- common case (E.g. Int, LiftedRep etc)++      | otherwise+      = mkTyConApp tc <$> go_tys env tys++    go_ty env (ForAllTy (Bndr tv vis) inner)+      = do { (env', tv') <- tycobinder env tv vis+           ; inner' <- go_ty env' inner+           ; return $ ForAllTy (Bndr tv' vis) inner' }++    go_cos _   []       = return []+    go_cos env (co:cos) = (:) <$> go_co env co <*> go_cos env cos++    go_mco _   MRefl    = return MRefl+    go_mco env (MCo co) = MCo <$> (go_co env co)++    go_co env (Refl ty)           = Refl <$> go_ty env ty+    go_co env (GRefl r ty mco)    = mkGReflCo r <$> go_ty env ty <*> go_mco env mco+    go_co env (AppCo c1 c2)       = mkAppCo <$> go_co env c1 <*> go_co env c2+    go_co env (FunCo r c1 c2)     = mkFunCo r <$> go_co env c1 <*> go_co env c2+    go_co env (CoVarCo cv)        = covar env cv+    go_co env (HoleCo hole)       = cohole env hole+    go_co env (UnivCo p r t1 t2)  = mkUnivCo <$> go_prov env p <*> pure r+                                    <*> go_ty env t1 <*> go_ty env t2+    go_co env (SymCo co)          = mkSymCo <$> go_co env co+    go_co env (TransCo c1 c2)     = mkTransCo <$> go_co env c1 <*> go_co env c2+    go_co env (AxiomRuleCo r cos) = AxiomRuleCo r <$> go_cos env cos+    go_co env (NthCo r i co)      = mkNthCo r i <$> go_co env co+    go_co env (LRCo lr co)        = mkLRCo lr <$> go_co env co+    go_co env (InstCo co arg)     = mkInstCo <$> go_co env co <*> go_co env arg+    go_co env (KindCo co)         = mkKindCo <$> go_co env co+    go_co env (SubCo co)          = mkSubCo <$> go_co env co+    go_co env (AxiomInstCo ax i cos) = mkAxiomInstCo ax i <$> go_cos env cos+    go_co env co@(TyConAppCo r tc cos)+      | isTcTyCon tc+      = do { tc' <- tycon tc+           ; mkTyConAppCo r tc' <$> go_cos env cos }++      -- Not a TcTyCon+      | null cos    -- Avoid allocation in this very+      = return co   -- common case (E.g. Int, LiftedRep etc)++      | otherwise+      = mkTyConAppCo r tc <$> go_cos env cos+    go_co env (ForAllCo tv kind_co co)+      = do { kind_co' <- go_co env kind_co+           ; (env', tv') <- tycobinder env tv Inferred+           ; co' <- go_co env' co+           ; return $ mkForAllCo tv' kind_co' co' }+        -- See Note [Efficiency for ForAllCo case of mapTyCoX]++    go_prov env (PhantomProv co)    = PhantomProv <$> go_co env co+    go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co+    go_prov _   p@(PluginProv _)    = return p+++{-+************************************************************************+*                                                                      *+\subsection{Constructor-specific functions}+*                                                                      *+************************************************************************+++---------------------------------------------------------------------+                                TyVarTy+                                ~~~~~~~+-}++-- | Attempts to obtain the type variable underlying a 'Type', and panics with the+-- given message if this is not a type variable type. See also 'getTyVar_maybe'+getTyVar :: String -> Type -> TyVar+getTyVar msg ty = case getTyVar_maybe ty of+                    Just tv -> tv+                    Nothing -> panic ("getTyVar: " ++ msg)++isTyVarTy :: Type -> Bool+isTyVarTy ty = isJust (getTyVar_maybe ty)++-- | Attempts to obtain the type variable underlying a 'Type'+getTyVar_maybe :: Type -> Maybe TyVar+getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty'+                  | otherwise               = repGetTyVar_maybe ty++-- | If the type is a tyvar, possibly under a cast, returns it, along+-- with the coercion. Thus, the co is :: kind tv ~N kind ty+getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN)+getCastedTyVar_maybe ty | Just ty' <- coreView ty = getCastedTyVar_maybe ty'+getCastedTyVar_maybe (CastTy (TyVarTy tv) co)     = Just (tv, co)+getCastedTyVar_maybe (TyVarTy tv)+  = Just (tv, mkReflCo Nominal (tyVarKind tv))+getCastedTyVar_maybe _                            = Nothing++-- | Attempts to obtain the type variable underlying a 'Type', without+-- any expansion+repGetTyVar_maybe :: Type -> Maybe TyVar+repGetTyVar_maybe (TyVarTy tv) = Just tv+repGetTyVar_maybe _            = Nothing++{-+---------------------------------------------------------------------+                                AppTy+                                ~~~~~+We need to be pretty careful with AppTy to make sure we obey the+invariant that a TyConApp is always visibly so.  mkAppTy maintains the+invariant: use it.++Note [Decomposing fat arrow c=>t]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Can we unify (a b) with (Eq a => ty)?   If we do so, we end up with+a partial application like ((=>) Eq a) which doesn't make sense in+source Haskell.  In contrast, we *can* unify (a b) with (t1 -> t2).+Here's an example (#9858) of how you might do it:+   i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep+   i p = typeRep p++   j = i (Proxy :: Proxy (Eq Int => Int))+The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes,+but suppose we want that.  But then in the call to 'i', we end+up decomposing (Eq Int => Int), and we definitely don't want that.++This really only applies to the type checker; in Core, '=>' and '->'+are the same, as are 'Constraint' and '*'.  But for now I've put+the test in repSplitAppTy_maybe, which applies throughout, because+the other calls to splitAppTy are in GHC.Core.Unify, which is also used by+the type checker (e.g. when matching type-function equations).++-}++-- | Applies a type to another, as in e.g. @k a@+mkAppTy :: Type -> Type -> Type+  -- See Note [Respecting definitional equality], invariant (EQ1).+mkAppTy (CastTy fun_ty co) arg_ty+  | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty]+  = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co++mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2])+mkAppTy ty1               ty2 = AppTy ty1 ty2+        -- Note that the TyConApp could be an+        -- under-saturated type synonym.  GHC allows that; e.g.+        --      type Foo k = k a -> k a+        --      type Id x = x+        --      foo :: Foo Id -> Foo Id+        --+        -- Here Id is partially applied in the type sig for Foo,+        -- but once the type synonyms are expanded all is well+        --+        -- Moreover in TcHsTypes.tcInferApps we build up a type+        --   (T t1 t2 t3) one argument at a type, thus forming+        --   (T t1), (T t1 t2), etc++mkAppTys :: Type -> [Type] -> Type+mkAppTys ty1                []   = ty1+mkAppTys (CastTy fun_ty co) arg_tys  -- much more efficient then nested mkAppTy+                                     -- Why do this? See (EQ1) of+                                     -- Note [Respecting definitional equality]+                                     -- in GHC.Core.TyCo.Rep+  = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers+  where+    (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys+    (args_to_cast, leftovers) = splitAtList arg_cos arg_tys+    casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos+mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2)+mkAppTys ty1                tys2 = foldl' AppTy ty1 tys2++-------------+splitAppTy_maybe :: Type -> Maybe (Type, Type)+-- ^ Attempt to take a type application apart, whether it is a+-- function, type constructor, or plain type application. Note+-- that type family applications are NEVER unsaturated by this!+splitAppTy_maybe ty | Just ty' <- coreView ty+                    = splitAppTy_maybe ty'+splitAppTy_maybe ty = repSplitAppTy_maybe ty++-------------+repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type)+-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that+-- any Core view stuff is already done+repSplitAppTy_maybe (FunTy _ ty1 ty2)+  = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2)+  where+    rep1 = getRuntimeRep ty1+    rep2 = getRuntimeRep ty2++repSplitAppTy_maybe (AppTy ty1 ty2)+  = Just (ty1, ty2)++repSplitAppTy_maybe (TyConApp tc tys)+  | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc+  , Just (tys', ty') <- snocView tys+  = Just (TyConApp tc tys', ty')    -- Never create unsaturated type family apps!++repSplitAppTy_maybe _other = Nothing++-- This one doesn't break apart (c => t).+-- See Note [Decomposing fat arrow c=>t]+-- Defined here to avoid module loops between Unify and TcType.+tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type)+-- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that+-- any coreView stuff is already done. Refuses to look through (c => t)+tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 })+  | InvisArg <- af+  = Nothing  -- See Note [Decomposing fat arrow c=>t]++  | otherwise+  = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2)+  where+    rep1 = getRuntimeRep ty1+    rep2 = getRuntimeRep ty2++tcRepSplitAppTy_maybe (AppTy ty1 ty2)    = Just (ty1, ty2)+tcRepSplitAppTy_maybe (TyConApp tc tys)+  | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc+  , Just (tys', ty') <- snocView tys+  = Just (TyConApp tc tys', ty')    -- Never create unsaturated type family apps!+tcRepSplitAppTy_maybe _other = Nothing++-------------+splitAppTy :: Type -> (Type, Type)+-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe',+-- and panics if this is not possible+splitAppTy ty = case splitAppTy_maybe ty of+                Just pr -> pr+                Nothing -> panic "splitAppTy"++-------------+splitAppTys :: Type -> (Type, [Type])+-- ^ Recursively splits a type as far as is possible, leaving a residual+-- type being applied to and the type arguments applied to it. Never fails,+-- even if that means returning an empty list of type applications.+splitAppTys ty = split ty ty []+  where+    split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args+    split _       (AppTy ty arg)        args = split ty ty (arg:args)+    split _       (TyConApp tc tc_args) args+      = let -- keep type families saturated+            n | mustBeSaturated tc = tyConArity tc+              | otherwise          = 0+            (tc_args1, tc_args2) = splitAt n tc_args+        in+        (TyConApp tc tc_args1, tc_args2 ++ args)+    split _   (FunTy _ ty1 ty2) args+      = ASSERT( null args )+        (TyConApp funTyCon [], [rep1, rep2, ty1, ty2])+      where+        rep1 = getRuntimeRep ty1+        rep2 = getRuntimeRep ty2++    split orig_ty _                     args  = (orig_ty, args)++-- | Like 'splitAppTys', but doesn't look through type synonyms+repSplitAppTys :: HasDebugCallStack => Type -> (Type, [Type])+repSplitAppTys ty = split ty []+  where+    split (AppTy ty arg) args = split ty (arg:args)+    split (TyConApp tc tc_args) args+      = let n | mustBeSaturated tc = tyConArity tc+              | otherwise          = 0+            (tc_args1, tc_args2) = splitAt n tc_args+        in+        (TyConApp tc tc_args1, tc_args2 ++ args)+    split (FunTy _ ty1 ty2) args+      = ASSERT( null args )+        (TyConApp funTyCon [], [rep1, rep2, ty1, ty2])+      where+        rep1 = getRuntimeRep ty1+        rep2 = getRuntimeRep ty2++    split ty args = (ty, args)++{-+                      LitTy+                      ~~~~~+-}++mkNumLitTy :: Integer -> Type+mkNumLitTy n = LitTy (NumTyLit n)++-- | Is this a numeric literal. We also look through type synonyms.+isNumLitTy :: Type -> Maybe Integer+isNumLitTy ty | Just ty1 <- coreView ty = isNumLitTy ty1+isNumLitTy (LitTy (NumTyLit n)) = Just n+isNumLitTy _                    = Nothing++mkStrLitTy :: FastString -> Type+mkStrLitTy s = LitTy (StrTyLit s)++-- | Is this a symbol literal. We also look through type synonyms.+isStrLitTy :: Type -> Maybe FastString+isStrLitTy ty | Just ty1 <- coreView ty = isStrLitTy ty1+isStrLitTy (LitTy (StrTyLit s)) = Just s+isStrLitTy _                    = Nothing++-- | Is this a type literal (symbol or numeric).+isLitTy :: Type -> Maybe TyLit+isLitTy ty | Just ty1 <- coreView ty = isLitTy ty1+isLitTy (LitTy l)                    = Just l+isLitTy _                            = Nothing++-- | Is this type a custom user error?+-- If so, give us the kind and the error message.+userTypeError_maybe :: Type -> Maybe Type+userTypeError_maybe t+  = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t+          -- There may be more than 2 arguments, if the type error is+          -- used as a type constructor (e.g. at kind `Type -> Type`).++       ; guard (tyConName tc == errorMessageTypeErrorFamName)+       ; return msg }++-- | Render a type corresponding to a user type error into a SDoc.+pprUserTypeErrorTy :: Type -> SDoc+pprUserTypeErrorTy ty =+  case splitTyConApp_maybe ty of++    -- Text "Something"+    Just (tc,[txt])+      | tyConName tc == typeErrorTextDataConName+      , Just str <- isStrLitTy txt -> ftext str++    -- ShowType t+    Just (tc,[_k,t])+      | tyConName tc == typeErrorShowTypeDataConName -> ppr t++    -- t1 :<>: t2+    Just (tc,[t1,t2])+      | tyConName tc == typeErrorAppendDataConName ->+        pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2++    -- t1 :$$: t2+    Just (tc,[t1,t2])+      | tyConName tc == typeErrorVAppendDataConName ->+        pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2++    -- An unevaluated type function+    _ -> ppr ty+++++{-+---------------------------------------------------------------------+                                FunTy+                                ~~~~~++Note [Representation of function types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Functions (e.g. Int -> Char) can be thought of as being applications+of funTyCon (known in Haskell surface syntax as (->)),++    (->) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)+                   (a :: TYPE r1) (b :: TYPE r2).+            a -> b -> Type++However, for efficiency's sake we represent saturated applications of (->)+with FunTy. For instance, the type,++    (->) r1 r2 a b++is equivalent to,++    FunTy (Anon a) b++Note how the RuntimeReps are implied in the FunTy representation. For this+reason we must be careful when recontructing the TyConApp representation (see,+for instance, splitTyConApp_maybe).++In the compiler we maintain the invariant that all saturated applications of+(->) are represented with FunTy.++See #11714.+-}++splitFunTy :: Type -> (Type, Type)+-- ^ Attempts to extract the argument and result types from a type, and+-- panics if that is not possible. See also 'splitFunTy_maybe'+splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty'+splitFunTy (FunTy _ arg res) = (arg, res)+splitFunTy other             = pprPanic "splitFunTy" (ppr other)++splitFunTy_maybe :: Type -> Maybe (Type, Type)+-- ^ Attempts to extract the argument and result types from a type+splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty'+splitFunTy_maybe (FunTy _ arg res) = Just (arg, res)+splitFunTy_maybe _                 = Nothing++splitFunTys :: Type -> ([Type], Type)+splitFunTys ty = split [] ty ty+  where+    split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty'+    split args _       (FunTy _ arg res) = split (arg:args) res res+    split args orig_ty _                 = (reverse args, orig_ty)++funResultTy :: Type -> Type+-- ^ Extract the function result type and panic if that is not possible+funResultTy ty | Just ty' <- coreView ty = funResultTy ty'+funResultTy (FunTy { ft_res = res }) = res+funResultTy ty                       = pprPanic "funResultTy" (ppr ty)++funArgTy :: Type -> Type+-- ^ Extract the function argument type and panic if that is not possible+funArgTy ty | Just ty' <- coreView ty = funArgTy ty'+funArgTy (FunTy { ft_arg = arg })    = arg+funArgTy ty                           = pprPanic "funArgTy" (ppr ty)++-- ^ Just like 'piResultTys' but for a single argument+-- Try not to iterate 'piResultTy', because it's inefficient to substitute+-- one variable at a time; instead use 'piResultTys"+piResultTy :: HasDebugCallStack => Type -> Type ->  Type+piResultTy ty arg = case piResultTy_maybe ty arg of+                      Just res -> res+                      Nothing  -> pprPanic "piResultTy" (ppr ty $$ ppr arg)++piResultTy_maybe :: Type -> Type -> Maybe Type+-- We don't need a 'tc' version, because+-- this function behaves the same for Type and Constraint+piResultTy_maybe ty arg+  | Just ty' <- coreView ty = piResultTy_maybe ty' arg++  | FunTy { ft_res = res } <- ty+  = Just res++  | ForAllTy (Bndr tv _) res <- ty+  = let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $+                      tyCoVarsOfTypes [arg,res]+    in Just (substTy (extendTCvSubst empty_subst tv arg) res)++  | otherwise+  = Nothing++-- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn)+--   where f :: f_ty+-- 'piResultTys' is interesting because:+--      1. 'f_ty' may have more for-alls than there are args+--      2. Less obviously, it may have fewer for-alls+-- For case 2. think of:+--   piResultTys (forall a.a) [forall b.b, Int]+-- This really can happen, but only (I think) in situations involving+-- undefined.  For example:+--       undefined :: forall a. a+-- Term: undefined @(forall b. b->b) @Int+-- This term should have type (Int -> Int), but notice that+-- there are more type args than foralls in 'undefined's type.++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint++-- This is a heavily used function (e.g. from typeKind),+-- so we pay attention to efficiency, especially in the special case+-- where there are no for-alls so we are just dropping arrows from+-- a function type/kind.+piResultTys :: HasDebugCallStack => Type -> [Type] -> Type+piResultTys ty [] = ty+piResultTys ty orig_args@(arg:args)+  | Just ty' <- coreView ty+  = piResultTys ty' orig_args++  | FunTy { ft_res = res } <- ty+  = piResultTys res args++  | ForAllTy (Bndr tv _) res <- ty+  = go (extendTCvSubst init_subst tv arg) res args++  | otherwise+  = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args)+  where+    init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args))++    go :: TCvSubst -> Type -> [Type] -> Type+    go subst ty [] = substTyUnchecked subst ty++    go subst ty all_args@(arg:args)+      | Just ty' <- coreView ty+      = go subst ty' all_args++      | FunTy { ft_res = res } <- ty+      = go subst res args++      | ForAllTy (Bndr tv _) res <- ty+      = go (extendTCvSubst subst tv arg) res args++      | not (isEmptyTCvSubst subst)  -- See Note [Care with kind instantiation]+      = go init_subst+          (substTy subst ty)+          all_args++      | otherwise+      = -- We have not run out of arguments, but the function doesn't+        -- have the right kind to apply to them; so panic.+        -- Without the explicit isEmptyVarEnv test, an ill-kinded type+        -- would give an infinite loop, which is very unhelpful+        -- c.f. #15473+        pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args)++applyTysX :: [TyVar] -> Type -> [Type] -> Type+-- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys+-- Assumes that (/\tvs. body_ty) is closed+applyTysX tvs body_ty arg_tys+  = ASSERT2( arg_tys `lengthAtLeast` n_tvs, pp_stuff )+    ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff )+    mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty)+             (drop n_tvs arg_tys)+  where+    pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys]+    n_tvs = length tvs++++{- Note [Care with kind instantiation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  T :: forall k. k+and we are finding the kind of+  T (forall b. b -> b) * Int+Then+  T (forall b. b->b) :: k[ k :-> forall b. b->b]+                     :: forall b. b -> b+So+  T (forall b. b->b) * :: (b -> b)[ b :-> *]+                       :: * -> *++In other words we must instantiate the forall!++Similarly (#15428)+   S :: forall k f. k -> f k+and we are finding the kind of+   S * (* ->) Int Bool+We have+   S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)]+              :: * -> * -> *+So again we must instantiate.++The same thing happens in GHC.CoreToIface.toIfaceAppArgsX.++--------------------------------------+Note [mkTyConApp and Type]++Whilst benchmarking it was observed in #17292 that GHC allocated a lot+of `TyConApp` constructors. Upon further inspection a large number of these+TyConApp constructors were all duplicates of `Type` applied to no arguments.++```+(From a sample of 100000 TyConApp closures)+0x45f3523    - 28732 - `Type`+0x420b840702 - 9629  - generic type constructors+0x42055b7e46 - 9596+0x420559b582 - 9511+0x420bb15a1e - 9509+0x420b86c6ba - 9501+0x42055bac1e - 9496+0x45e68fd    - 538 - `TYPE ...`+```++Therefore in `mkTyConApp` we have a special case for `Type` to ensure that+only one `TyConApp 'Type []` closure is allocated during the course of+compilation. In order to avoid a potentially expensive series of checks in+`mkTyConApp` only this egregious case is special cased at the moment.+++---------------------------------------------------------------------+                                TyConApp+                                ~~~~~~~~+-}++-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to+-- its arguments.  Applies its arguments to the constructor from left to right.+mkTyConApp :: TyCon -> [Type] -> Type+mkTyConApp tycon tys+  | isFunTyCon tycon+  , [_rep1,_rep2,ty1,ty2] <- tys+  -- The FunTyCon (->) is always a visible one+  = FunTy { ft_af = VisArg, ft_arg = ty1, ft_res = ty2 }+  -- Note [mkTyConApp and Type]+  | tycon == liftedTypeKindTyCon+  = ASSERT2( null tys, ppr tycon $$ ppr tys )+    liftedTypeKindTyConApp+  | otherwise+  = TyConApp tycon tys++-- This is a single, global definition of the type `Type`+-- Defined here so it is only allocated once.+-- See Note [mkTyConApp and Type]+liftedTypeKindTyConApp :: Type+liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon []++-- splitTyConApp "looks through" synonyms, because they don't+-- mean a distinct type, but all other type-constructor applications+-- including functions are returned as Just ..++-- | Retrieve the tycon heading this type, if there is one. Does /not/+-- look through synonyms.+tyConAppTyConPicky_maybe :: Type -> Maybe TyCon+tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc+tyConAppTyConPicky_maybe (FunTy {})      = Just funTyCon+tyConAppTyConPicky_maybe _               = Nothing+++-- | The same as @fst . splitTyConApp@+tyConAppTyCon_maybe :: Type -> Maybe TyCon+tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty'+tyConAppTyCon_maybe (TyConApp tc _) = Just tc+tyConAppTyCon_maybe (FunTy {})      = Just funTyCon+tyConAppTyCon_maybe _               = Nothing++tyConAppTyCon :: Type -> TyCon+tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty)++-- | The same as @snd . splitTyConApp@+tyConAppArgs_maybe :: Type -> Maybe [Type]+tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty'+tyConAppArgs_maybe (TyConApp _ tys) = Just tys+tyConAppArgs_maybe (FunTy _ arg res)+  | Just rep1 <- getRuntimeRep_maybe arg+  , Just rep2 <- getRuntimeRep_maybe res+  = Just [rep1, rep2, arg, res]+tyConAppArgs_maybe _  = Nothing++tyConAppArgs :: Type -> [Type]+tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)++tyConAppArgN :: Int -> Type -> Type+-- Executing Nth+tyConAppArgN n ty+  = case tyConAppArgs_maybe ty of+      Just tys -> tys `getNth` n+      Nothing  -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty)++-- | Attempts to tease a type apart into a type constructor and the application+-- of a number of arguments to that constructor. Panics if that is not possible.+-- See also 'splitTyConApp_maybe'+splitTyConApp :: Type -> (TyCon, [Type])+splitTyConApp ty = case splitTyConApp_maybe ty of+                   Just stuff -> stuff+                   Nothing    -> pprPanic "splitTyConApp" (ppr ty)++-- | Attempts to tease a type apart into a type constructor and the application+-- of a number of arguments to that constructor+splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])+splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty'+splitTyConApp_maybe ty                           = repSplitTyConApp_maybe ty++-- | Split a type constructor application into its type constructor and+-- applied types. Note that this may fail in the case of a 'FunTy' with an+-- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind+-- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your+-- type before using this function.+--+-- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'.+tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])+-- Defined here to avoid module loops between Unify and TcType.+tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'+tcSplitTyConApp_maybe ty                         = repSplitTyConApp_maybe ty++-------------------+repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])+-- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This+-- assumes the synonyms have already been dealt with.+--+-- Moreover, for a FunTy, it only succeeds if the argument types+-- have enough info to extract the runtime-rep arguments that+-- the funTyCon requires.  This will usually be true;+-- but may be temporarily false during canonicalization:+--     see Note [FunTy and decomposing tycon applications] in TcCanonical+--+repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)+repSplitTyConApp_maybe (FunTy _ arg res)+  | Just arg_rep <- getRuntimeRep_maybe arg+  , Just res_rep <- getRuntimeRep_maybe res+  = Just (funTyCon, [arg_rep, res_rep, arg, res])+repSplitTyConApp_maybe _ = Nothing++-------------------+-- | Attempts to tease a list type apart and gives the type of the elements if+-- successful (looks through type synonyms)+splitListTyConApp_maybe :: Type -> Maybe Type+splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of+  Just (tc,[e]) | tc == listTyCon -> Just e+  _other                          -> Nothing++newTyConInstRhs :: TyCon -> [Type] -> Type+-- ^ Unwrap one 'layer' of newtype on a type constructor and its+-- arguments, using an eta-reduced version of the @newtype@ if possible.+-- This requires tys to have at least @newTyConInstArity tycon@ elements.+newTyConInstRhs tycon tys+    = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs )+      applyTysX tvs rhs tys+  where+    (tvs, rhs) = newTyConEtadRhs tycon++{-+---------------------------------------------------------------------+                           CastTy+                           ~~~~~~+A casted type has its *kind* casted into something new.+-}++splitCastTy_maybe :: Type -> Maybe (Type, Coercion)+splitCastTy_maybe ty | Just ty' <- coreView ty = splitCastTy_maybe ty'+splitCastTy_maybe (CastTy ty co)               = Just (ty, co)+splitCastTy_maybe _                            = Nothing++-- | Make a 'CastTy'. The Coercion must be nominal. Checks the+-- Coercion for reflexivity, dropping it if it's reflexive.+-- See Note [Respecting definitional equality] in GHC.Core.TyCo.Rep+mkCastTy :: Type -> Coercion -> Type+mkCastTy ty co | isReflexiveCo co = ty  -- (EQ2) from the Note+-- NB: Do the slow check here. This is important to keep the splitXXX+-- functions working properly. Otherwise, we may end up with something+-- like (((->) |> something_reflexive_but_not_obviously_so) biz baz)+-- fails under splitFunTy_maybe. This happened with the cheaper check+-- in test dependent/should_compile/dynamic-paper.++mkCastTy (CastTy ty co1) co2+  -- (EQ3) from the Note+  = mkCastTy ty (co1 `mkTransCo` co2)+      -- call mkCastTy again for the reflexivity check++mkCastTy (ForAllTy (Bndr tv vis) inner_ty) co+  -- (EQ4) from the Note+  -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep.+  | isTyVar tv+  , let fvs = tyCoVarsOfCo co+  = -- have to make sure that pushing the co in doesn't capture the bound var!+    if tv `elemVarSet` fvs+    then let empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs)+             (subst, tv') = substVarBndr empty_subst tv+         in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mkCastTy` co)+    else ForAllTy (Bndr tv vis) (inner_ty `mkCastTy` co)++mkCastTy ty co = CastTy ty co++tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder]+-- Return the tyConBinders in TyCoBinder form+tyConBindersTyCoBinders = map to_tyb+  where+    to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis)+    to_tyb (Bndr tv (AnonTCB af))   = Anon af (varType tv)++-- | Drop the cast on a type, if any. If there is no+-- cast, just return the original type. This is rarely what+-- you want. The CastTy data constructor (in GHC.Core.TyCo.Rep) has the+-- invariant that another CastTy is not inside. See the+-- data constructor for a full description of this invariant.+-- Since CastTy cannot be nested, the result of discardCast+-- cannot be a CastTy.+discardCast :: Type -> Type+discardCast (CastTy ty _) = ASSERT(not (isCastTy ty)) ty+  where+  isCastTy CastTy{} = True+  isCastTy _        = False+discardCast ty            = ty+++{-+--------------------------------------------------------------------+                            CoercionTy+                            ~~~~~~~~~~+CoercionTy allows us to inject coercions into types. A CoercionTy+should appear only in the right-hand side of an application.+-}++mkCoercionTy :: Coercion -> Type+mkCoercionTy = CoercionTy++isCoercionTy :: Type -> Bool+isCoercionTy (CoercionTy _) = True+isCoercionTy _              = False++isCoercionTy_maybe :: Type -> Maybe Coercion+isCoercionTy_maybe (CoercionTy co) = Just co+isCoercionTy_maybe _               = Nothing++stripCoercionTy :: Type -> Coercion+stripCoercionTy (CoercionTy co) = co+stripCoercionTy ty              = pprPanic "stripCoercionTy" (ppr ty)++{-+---------------------------------------------------------------------+                                SynTy+                                ~~~~~++Notes on type synonyms+~~~~~~~~~~~~~~~~~~~~~~+The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try+to return type synonyms wherever possible. Thus++        type Foo a = a -> a++we want+        splitFunTys (a -> Foo a) = ([a], Foo a)+not                                ([a], a -> a)++The reason is that we then get better (shorter) type signatures in+interfaces.  Notably this plays a role in tcTySigs in TcBinds.hs.+++---------------------------------------------------------------------+                                ForAllTy+                                ~~~~~~~~+-}++-- | Make a dependent forall over an 'Inferred' variable+mkTyCoInvForAllTy :: TyCoVar -> Type -> Type+mkTyCoInvForAllTy tv ty+  | isCoVar tv+  , not (tv `elemVarSet` tyCoVarsOfType ty)+  = mkVisFunTy (varType tv) ty+  | otherwise+  = ForAllTy (Bndr tv Inferred) ty++-- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar+mkInvForAllTy :: TyVar -> Type -> Type+mkInvForAllTy tv ty = ASSERT( isTyVar tv )+                      ForAllTy (Bndr tv Inferred) ty++-- | Like 'mkForAllTys', but assumes all variables are dependent and+-- 'Inferred', a common case+mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type+mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs++-- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar+mkInvForAllTys :: [TyVar] -> Type -> Type+mkInvForAllTys tvs ty = foldr mkInvForAllTy ty tvs++-- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified',+-- a common case+mkSpecForAllTy :: TyVar -> Type -> Type+mkSpecForAllTy tv ty = ASSERT( isTyVar tv )+                       -- covar is always Inferred, so input should be tyvar+                       ForAllTy (Bndr tv Specified) ty++-- | Like 'mkForAllTys', but assumes all variables are dependent and+-- 'Specified', a common case+mkSpecForAllTys :: [TyVar] -> Type -> Type+mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs++-- | Like mkForAllTys, but assumes all variables are dependent and visible+mkVisForAllTys :: [TyVar] -> Type -> Type+mkVisForAllTys tvs = ASSERT( all isTyVar tvs )+                     -- covar is always Inferred, so all inputs should be tyvar+                     mkForAllTys [ Bndr tv Required | tv <- tvs ]++mkLamType  :: Var -> Type -> Type+-- ^ Makes a @(->)@ type or an implicit forall type, depending+-- on whether it is given a type variable or a term variable.+-- This is used, for example, when producing the type of a lambda.+-- Always uses Inferred binders.+mkLamTypes :: [Var] -> Type -> Type+-- ^ 'mkLamType' for multiple type or value arguments++mkLamType v body_ty+   | isTyVar v+   = ForAllTy (Bndr v Inferred) body_ty++   | isCoVar v+   , v `elemVarSet` tyCoVarsOfType body_ty+   = ForAllTy (Bndr v Required) body_ty++   | isPredTy arg_ty  -- See Note [mkLamType: dictionary arguments]+   = mkInvisFunTy arg_ty body_ty++   | otherwise+   = mkVisFunTy arg_ty body_ty+   where+     arg_ty = varType v++mkLamTypes vs ty = foldr mkLamType ty vs++{- Note [mkLamType: dictionary arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have (\ (d :: Ord a). blah), we want to give it type+           (Ord a => blah_ty)+with a fat arrow; that is, using mkInvisFunTy, not mkVisFunTy.++Why? After all, we are in Core, where (=>) and (->) behave the same.+Yes, but the /specialiser/ does treat dictionary arguments specially.+Suppose we do w/w on 'foo' in module A, thus (#11272, #6056)+   foo :: Ord a => Int -> blah+   foo a d x = case x of I# x' -> $wfoo @a d x'++   $wfoo :: Ord a => Int# -> blah++Now in module B we see (foo @Int dOrdInt).  The specialiser will+specialise this to $sfoo, where+   $sfoo :: Int -> blah+   $sfoo x = case x of I# x' -> $wfoo @Int dOrdInt x'++Now we /must/ also specialise $wfoo!  But it wasn't user-written,+and has a type built with mkLamTypes.++Conclusion: the easiest thing is to make mkLamType build+            (c => ty)+when the argument is a predicate type.  See GHC.Core.TyCo.Rep+Note [Types for coercions, predicates, and evidence]+-}++-- | Given a list of type-level vars and the free vars of a result kind,+-- makes TyCoBinders, preferring anonymous binders+-- if the variable is, in fact, not dependent.+-- e.g.    mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k)+-- We want (k:*) Named, (b:k) Anon, (c:k) Anon+--+-- All non-coercion binders are /visible/.+mkTyConBindersPreferAnon :: [TyVar]      -- ^ binders+                         -> TyCoVarSet   -- ^ free variables of result+                         -> [TyConBinder]+mkTyConBindersPreferAnon vars inner_tkvs = ASSERT( all isTyVar vars)+                                           fst (go vars)+  where+    go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars+    go [] = ([], inner_tkvs)+    go (v:vs) | v `elemVarSet` fvs+              = ( Bndr v (NamedTCB Required) : binders+                , fvs `delVarSet` v `unionVarSet` kind_vars )+              | otherwise+              = ( Bndr v (AnonTCB VisArg) : binders+                , fvs `unionVarSet` kind_vars )+      where+        (binders, fvs) = go vs+        kind_vars      = tyCoVarsOfType $ tyVarKind v++-- | Take a ForAllTy apart, returning the list of tycovars and the result type.+-- This always succeeds, even if it returns only an empty list. Note that the+-- result type returned may have free variables that were bound by a forall.+splitForAllTys :: Type -> ([TyCoVar], Type)+splitForAllTys ty = split ty ty []+  where+    split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs+    split _       (ForAllTy (Bndr tv _) ty)    tvs = split ty ty (tv:tvs)+    split orig_ty _                            tvs = (reverse tvs, orig_ty)++-- | Like 'splitForAllTys', but only splits a 'ForAllTy' if+-- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility+-- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided+-- as an argument to this function.+splitForAllTysSameVis :: ArgFlag -> Type -> ([TyCoVar], Type)+splitForAllTysSameVis supplied_argf ty = split ty ty []+  where+    split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs+    split _       (ForAllTy (Bndr tv argf) ty) tvs+      | argf `sameVis` supplied_argf               = split ty ty (tv:tvs)+    split orig_ty _                            tvs = (reverse tvs, orig_ty)++-- | Like splitForAllTys, but split only for tyvars.+-- This always succeeds, even if it returns only an empty list. Note that the+-- result type returned may have free variables that were bound by a forall.+splitTyVarForAllTys :: Type -> ([TyVar], Type)+splitTyVarForAllTys ty = split ty ty []+  where+    split orig_ty ty tvs | Just ty' <- coreView ty     = split orig_ty ty' tvs+    split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs)+    split orig_ty _                   tvs              = (reverse tvs, orig_ty)++-- | Checks whether this is a proper forall (with a named binder)+isForAllTy :: Type -> Bool+isForAllTy ty | Just ty' <- coreView ty = isForAllTy ty'+isForAllTy (ForAllTy {}) = True+isForAllTy _             = False++-- | Like `isForAllTy`, but returns True only if it is a tyvar binder+isForAllTy_ty :: Type -> Bool+isForAllTy_ty ty | Just ty' <- coreView ty = isForAllTy_ty ty'+isForAllTy_ty (ForAllTy (Bndr tv _) _) | isTyVar tv = True+isForAllTy_ty _             = False++-- | Like `isForAllTy`, but returns True only if it is a covar binder+isForAllTy_co :: Type -> Bool+isForAllTy_co ty | Just ty' <- coreView ty = isForAllTy_co ty'+isForAllTy_co (ForAllTy (Bndr tv _) _) | isCoVar tv = True+isForAllTy_co _             = False++-- | Is this a function or forall?+isPiTy :: Type -> Bool+isPiTy ty | Just ty' <- coreView ty = isPiTy ty'+isPiTy (ForAllTy {}) = True+isPiTy (FunTy {})    = True+isPiTy _             = False++-- | Is this a function?+isFunTy :: Type -> Bool+isFunTy ty | Just ty' <- coreView ty = isFunTy ty'+isFunTy (FunTy {}) = True+isFunTy _          = False++-- | Take a forall type apart, or panics if that is not possible.+splitForAllTy :: Type -> (TyCoVar, Type)+splitForAllTy ty+  | Just answer <- splitForAllTy_maybe ty = answer+  | otherwise                             = pprPanic "splitForAllTy" (ppr ty)++-- | Drops all ForAllTys+dropForAlls :: Type -> Type+dropForAlls ty = go ty+  where+    go ty | Just ty' <- coreView ty = go ty'+    go (ForAllTy _ res)            = go res+    go res                         = res++-- | Attempts to take a forall type apart, but only if it's a proper forall,+-- with a named binder+splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type)+splitForAllTy_maybe ty = go ty+  where+    go ty | Just ty' <- coreView ty = go ty'+    go (ForAllTy (Bndr tv _) ty)    = Just (tv, ty)+    go _                            = Nothing++-- | Like splitForAllTy_maybe, but only returns Just if it is a tyvar binder.+splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type)+splitForAllTy_ty_maybe ty = go ty+  where+    go ty | Just ty' <- coreView ty = go ty'+    go (ForAllTy (Bndr tv _) ty) | isTyVar tv = Just (tv, ty)+    go _                            = Nothing++-- | Like splitForAllTy_maybe, but only returns Just if it is a covar binder.+splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type)+splitForAllTy_co_maybe ty = go ty+  where+    go ty | Just ty' <- coreView ty = go ty'+    go (ForAllTy (Bndr tv _) ty) | isCoVar tv = Just (tv, ty)+    go _                            = Nothing++-- | Attempts to take a forall type apart; works with proper foralls and+-- functions+splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type)+splitPiTy_maybe ty = go ty+  where+    go ty | Just ty' <- coreView ty = go ty'+    go (ForAllTy bndr ty) = Just (Named bndr, ty)+    go (FunTy { ft_af = af, ft_arg = arg, ft_res = res})+                          = Just (Anon af arg, res)+    go _                  = Nothing++-- | Takes a forall type apart, or panics+splitPiTy :: Type -> (TyCoBinder, Type)+splitPiTy ty+  | Just answer <- splitPiTy_maybe ty = answer+  | otherwise                         = pprPanic "splitPiTy" (ppr ty)++-- | Split off all TyCoBinders to a type, splitting both proper foralls+-- and functions+splitPiTys :: Type -> ([TyCoBinder], Type)+splitPiTys ty = split ty ty []+  where+    split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs+    split _       (ForAllTy b res) bs = split res res (Named b  : bs)+    split _       (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) bs+                                      = split res res (Anon af arg : bs)+    split orig_ty _                bs = (reverse bs, orig_ty)++-- | Like 'splitPiTys' but split off only /named/ binders+--   and returns TyCoVarBinders rather than TyCoBinders+splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type)+splitForAllVarBndrs ty = split ty ty []+  where+    split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs+    split _       (ForAllTy b res) bs = split res res (b:bs)+    split orig_ty _                bs = (reverse bs, orig_ty)+{-# INLINE splitForAllVarBndrs #-}++invisibleTyBndrCount :: Type -> Int+-- Returns the number of leading invisible forall'd binders in the type+-- Includes invisible predicate arguments; e.g. for+--    e.g.  forall {k}. (k ~ *) => k -> k+-- returns 2 not 1+invisibleTyBndrCount ty = length (fst (splitPiTysInvisible ty))++-- Like splitPiTys, but returns only *invisible* binders, including constraints+-- Stops at the first visible binder+splitPiTysInvisible :: Type -> ([TyCoBinder], Type)+splitPiTysInvisible ty = split ty ty []+   where+    split orig_ty ty bs+      | Just ty' <- coreView ty  = split orig_ty ty' bs+    split _ (ForAllTy b res) bs+      | Bndr _ vis <- b+      , isInvisibleArgFlag vis   = split res res (Named b  : bs)+    split _ (FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res })  bs+                                 = split res res (Anon InvisArg arg : bs)+    split orig_ty _          bs  = (reverse bs, orig_ty)++splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type)+-- Same as splitPiTysInvisible, but stop when+--   - you have found 'n' TyCoBinders,+--   - or you run out of invisible binders+splitPiTysInvisibleN n ty = split n ty ty []+   where+    split n orig_ty ty bs+      | n == 0                  = (reverse bs, orig_ty)+      | Just ty' <- coreView ty = split n orig_ty ty' bs+      | ForAllTy b res <- ty+      , Bndr _ vis <- b+      , isInvisibleArgFlag vis  = split (n-1) res res (Named b  : bs)+      | FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res } <- ty+                                = split (n-1) res res (Anon InvisArg arg : bs)+      | otherwise               = (reverse bs, orig_ty)++-- | Given a 'TyCon' and a list of argument types, filter out any invisible+-- (i.e., 'Inferred' or 'Specified') arguments.+filterOutInvisibleTypes :: TyCon -> [Type] -> [Type]+filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys++-- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred'+-- arguments.+filterOutInferredTypes :: TyCon -> [Type] -> [Type]+filterOutInferredTypes tc tys =+  filterByList (map (/= Inferred) $ tyConArgFlags tc tys) tys++-- | Given a 'TyCon' and a list of argument types, partition the arguments+-- into:+--+-- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and+--+-- 2. 'Required' (i.e., visible) arguments+partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type])+partitionInvisibleTypes tc tys =+  partitionByList (map isInvisibleArgFlag $ tyConArgFlags tc tys) tys++-- | Given a list of things paired with their visibilities, partition the+-- things into (invisible things, visible things).+partitionInvisibles :: [(a, ArgFlag)] -> ([a], [a])+partitionInvisibles = partitionWith pick_invis+  where+    pick_invis :: (a, ArgFlag) -> Either a a+    pick_invis (thing, vis) | isInvisibleArgFlag vis = Left thing+                            | otherwise              = Right thing++-- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is+-- applied, determine each argument's visibility+-- ('Inferred', 'Specified', or 'Required').+--+-- Wrinkle: consider the following scenario:+--+-- > T :: forall k. k -> k+-- > tyConArgFlags T [forall m. m -> m -> m, S, R, Q]+--+-- After substituting, we get+--+-- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n+--+-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again,+-- and @Q@ is visible.+tyConArgFlags :: TyCon -> [Type] -> [ArgFlag]+tyConArgFlags tc = fun_kind_arg_flags (tyConKind tc)++-- | Given a 'Type' and a list of argument types to which the 'Type' is+-- applied, determine each argument's visibility+-- ('Inferred', 'Specified', or 'Required').+--+-- Most of the time, the arguments will be 'Required', but not always. Consider+-- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is+-- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely+-- this sort of higher-rank situation in which 'appTyArgFlags' comes in handy,+-- since @f Type Bool@ would be represented in Core using 'AppTy's.+-- (See also #15792).+appTyArgFlags :: Type -> [Type] -> [ArgFlag]+appTyArgFlags ty = fun_kind_arg_flags (typeKind ty)++-- | Given a function kind and a list of argument types (where each argument's+-- kind aligns with the corresponding position in the argument kind), determine+-- each argument's visibility ('Inferred', 'Specified', or 'Required').+fun_kind_arg_flags :: Kind -> [Type] -> [ArgFlag]+fun_kind_arg_flags = go emptyTCvSubst+  where+    go subst ki arg_tys+      | Just ki' <- coreView ki = go subst ki' arg_tys+    go _ _ [] = []+    go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys)+      = argf : go subst' res_ki arg_tys+      where+        subst' = extendTvSubst subst tv arg_ty+    go subst (TyVarTy tv) arg_tys+      | Just ki <- lookupTyVar subst tv = go subst ki arg_tys+    -- This FunTy case is important to handle kinds with nested foralls, such+    -- as this kind (inspired by #16518):+    --+    --   forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type+    --+    -- Here, we want to get the following ArgFlags:+    --+    -- [Inferred,   Specified, Required, Required, Specified, Required]+    -- forall {k1}. forall k2. k1 ->     k2 ->     forall k3. k3 ->     Type+    go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys)+      = argf : go subst res_ki arg_tys+      where+        argf = case af of+                 VisArg   -> Required+                 InvisArg -> Inferred+    go _ _ arg_tys = map (const Required) arg_tys+                        -- something is ill-kinded. But this can happen+                        -- when printing errors. Assume everything is Required.++-- @isTauTy@ tests if a type has no foralls+isTauTy :: Type -> Bool+isTauTy ty | Just ty' <- coreView ty = isTauTy ty'+isTauTy (TyVarTy _)           = True+isTauTy (LitTy {})            = True+isTauTy (TyConApp tc tys)     = all isTauTy tys && isTauTyCon tc+isTauTy (AppTy a b)           = isTauTy a && isTauTy b+isTauTy (FunTy _ a b)         = isTauTy a && isTauTy b+isTauTy (ForAllTy {})         = False+isTauTy (CastTy ty _)         = isTauTy ty+isTauTy (CoercionTy _)        = False  -- Not sure about this++{-+%************************************************************************+%*                                                                      *+   TyCoBinders+%*                                                                      *+%************************************************************************+-}++-- | Make an anonymous binder+mkAnonBinder :: AnonArgFlag -> Type -> TyCoBinder+mkAnonBinder = Anon++-- | Does this binder bind a variable that is /not/ erased? Returns+-- 'True' for anonymous binders.+isAnonTyCoBinder :: TyCoBinder -> Bool+isAnonTyCoBinder (Named {}) = False+isAnonTyCoBinder (Anon {})  = True++tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar+tyCoBinderVar_maybe (Named tv) = Just $ binderVar tv+tyCoBinderVar_maybe _          = Nothing++tyCoBinderType :: TyCoBinder -> Type+tyCoBinderType (Named tvb) = binderType tvb+tyCoBinderType (Anon _ ty) = ty++tyBinderType :: TyBinder -> Type+tyBinderType (Named (Bndr tv _))+  = ASSERT( isTyVar tv )+    tyVarKind tv+tyBinderType (Anon _ ty)   = ty++-- | Extract a relevant type, if there is one.+binderRelevantType_maybe :: TyCoBinder -> Maybe Type+binderRelevantType_maybe (Named {})  = Nothing+binderRelevantType_maybe (Anon _ ty) = Just ty++{-+************************************************************************+*                                                                      *+\subsection{Type families}+*                                                                      *+************************************************************************+-}++mkFamilyTyConApp :: TyCon -> [Type] -> Type+-- ^ Given a family instance TyCon and its arg types, return the+-- corresponding family type.  E.g:+--+-- > data family T a+-- > data instance T (Maybe b) = MkT b+--+-- Where the instance tycon is :RTL, so:+--+-- > mkFamilyTyConApp :RTL Int  =  T (Maybe Int)+mkFamilyTyConApp tc tys+  | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc+  , let tvs = tyConTyVars tc+        fam_subst = ASSERT2( tvs `equalLength` tys, ppr tc <+> ppr tys )+                    zipTvSubst tvs tys+  = mkTyConApp fam_tc (substTys fam_subst fam_tys)+  | otherwise+  = mkTyConApp tc tys++-- | Get the type on the LHS of a coercion induced by a type/data+-- family instance.+coAxNthLHS :: CoAxiom br -> Int -> Type+coAxNthLHS ax ind =+  mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind))++isFamFreeTy :: Type -> Bool+isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty'+isFamFreeTy (TyVarTy _)       = True+isFamFreeTy (LitTy {})        = True+isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc+isFamFreeTy (AppTy a b)       = isFamFreeTy a && isFamFreeTy b+isFamFreeTy (FunTy _ a b)     = isFamFreeTy a && isFamFreeTy b+isFamFreeTy (ForAllTy _ ty)   = isFamFreeTy ty+isFamFreeTy (CastTy ty _)     = isFamFreeTy ty+isFamFreeTy (CoercionTy _)    = False  -- Not sure about this++-- | Does this type classify a core (unlifted) Coercion?+-- At either role nominal or representational+--    (t1 ~# t2) or (t1 ~R# t2)+-- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep+isCoVarType :: Type -> Bool+  -- ToDo: should we check saturation?+isCoVarType ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey+  | otherwise+  = False++buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind   -- ^ /result/ kind+              -> [Role] -> KnotTied Type -> TyCon+-- This function is here beucase here is where we have+--   isFamFree and isTauTy+buildSynTyCon name binders res_kind roles rhs+  = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free+  where+    is_tau      = isTauTy rhs+    is_fam_free = isFamFreeTy rhs++{-+************************************************************************+*                                                                      *+\subsection{Liftedness}+*                                                                      *+************************************************************************+-}++-- | Returns Just True if this type is surely lifted, Just False+-- if it is surely unlifted, Nothing if we can't be sure (i.e., it is+-- levity polymorphic), and panics if the kind does not have the shape+-- TYPE r.+isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool+isLiftedType_maybe ty = go (getRuntimeRep ty)+  where+    go rr | Just rr' <- coreView rr = go rr'+          | isLiftedRuntimeRep rr  = Just True+          | TyConApp {} <- rr      = Just False  -- Everything else is unlifted+          | otherwise              = Nothing     -- levity polymorphic++-- | See "Type#type_classification" for what an unlifted type is.+-- Panics on levity polymorphic types; See 'mightBeUnliftedType' for+-- a more approximate predicate that behaves better in the presence of+-- levity polymorphism.+isUnliftedType :: HasDebugCallStack => Type -> Bool+        -- isUnliftedType returns True for forall'd unlifted types:+        --      x :: forall a. Int#+        -- I found bindings like these were getting floated to the top level.+        -- They are pretty bogus types, mind you.  It would be better never to+        -- construct them+isUnliftedType ty+  = not (isLiftedType_maybe ty `orElse`+         pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty)))++-- | Returns:+--+-- * 'False' if the type is /guaranteed/ lifted or+-- * 'True' if it is unlifted, OR we aren't sure (e.g. in a levity-polymorphic case)+mightBeUnliftedType :: Type -> Bool+mightBeUnliftedType ty+  = case isLiftedType_maybe ty of+      Just is_lifted -> not is_lifted+      Nothing -> True++-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep)+isRuntimeRepKindedTy :: Type -> Bool+isRuntimeRepKindedTy = isRuntimeRepTy . typeKind++-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g.+-- dropping 'LiftedRep arguments of unboxed tuple TyCon applications:+--+--   dropRuntimeRepArgs [ 'LiftedRep, 'IntRep+--                      , String, Int# ] == [String, Int#]+--+dropRuntimeRepArgs :: [Type] -> [Type]+dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy++-- | Extract the RuntimeRep classifier of a type. For instance,+-- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not+-- possible.+getRuntimeRep_maybe :: HasDebugCallStack+                    => Type -> Maybe Type+getRuntimeRep_maybe = kindRep_maybe . typeKind++-- | Extract the RuntimeRep classifier of a type. For instance,+-- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible.+getRuntimeRep :: HasDebugCallStack => Type -> Type+getRuntimeRep ty+  = case getRuntimeRep_maybe ty of+      Just r  -> r+      Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty))++isUnboxedTupleType :: Type -> Bool+isUnboxedTupleType ty+  = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey+  -- NB: Do not use typePrimRep, as that can't tell the difference between+  -- unboxed tuples and unboxed sums+++isUnboxedSumType :: Type -> Bool+isUnboxedSumType ty+  = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey++-- | See "Type#type_classification" for what an algebraic type is.+-- Should only be applied to /types/, as opposed to e.g. partially+-- saturated type constructors+isAlgType :: Type -> Bool+isAlgType ty+  = case splitTyConApp_maybe ty of+      Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )+                            isAlgTyCon tc+      _other             -> False++-- | Check whether a type is a data family type+isDataFamilyAppType :: Type -> Bool+isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of+                           Just tc -> isDataFamilyTyCon tc+                           _       -> False++-- | Computes whether an argument (or let right hand side) should+-- be computed strictly or lazily, based only on its type.+-- Currently, it's just 'isUnliftedType'. Panics on levity-polymorphic types.+isStrictType :: HasDebugCallStack => Type -> Bool+isStrictType = isUnliftedType++isPrimitiveType :: Type -> Bool+-- ^ Returns true of types that are opaque to Haskell.+isPrimitiveType ty = case splitTyConApp_maybe ty of+                        Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )+                                              isPrimTyCon tc+                        _                  -> False++{-+************************************************************************+*                                                                      *+\subsection{Join points}+*                                                                      *+************************************************************************+-}++-- | Determine whether a type could be the type of a join point of given total+-- arity, according to the polymorphism rule. A join point cannot be polymorphic+-- in its return type, since given+--   join j @a @b x y z = e1 in e2,+-- the types of e1 and e2 must be the same, and a and b are not in scope for e2.+-- (See Note [The polymorphism rule of join points] in GHC.Core.) Returns False+-- also if the type simply doesn't have enough arguments.+--+-- Note that we need to know how many arguments (type *and* value) the putative+-- join point takes; for instance, if+--   j :: forall a. a -> Int+-- then j could be a binary join point returning an Int, but it could *not* be a+-- unary join point returning a -> Int.+--+-- TODO: See Note [Excess polymorphism and join points]+isValidJoinPointType :: JoinArity -> Type -> Bool+isValidJoinPointType arity ty+  = valid_under emptyVarSet arity ty+  where+    valid_under tvs arity ty+      | arity == 0+      = isEmptyVarSet (tvs `intersectVarSet` tyCoVarsOfType ty)+      | Just (t, ty') <- splitForAllTy_maybe ty+      = valid_under (tvs `extendVarSet` t) (arity-1) ty'+      | Just (_, res_ty) <- splitFunTy_maybe ty+      = valid_under tvs (arity-1) res_ty+      | otherwise+      = False++{- Note [Excess polymorphism and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In principle, if a function would be a join point except that it fails+the polymorphism rule (see Note [The polymorphism rule of join points] in+GHC.Core), it can still be made a join point with some effort. This is because+all tail calls must return the same type (they return to the same context!), and+thus if the return type depends on an argument, that argument must always be the+same.++For instance, consider:++  let f :: forall a. a -> Char -> [a]+      f @a x c = ... f @a y 'a' ...+  in ... f @Int 1 'b' ... f @Int 2 'c' ...++(where the calls are tail calls). `f` fails the polymorphism rule because its+return type is [a], where [a] is bound. But since the type argument is always+'Int', we can rewrite it as:++  let f' :: Int -> Char -> [Int]+      f' x c = ... f' y 'a' ...+  in ... f' 1 'b' ... f 2 'c' ...++and now we can make f' a join point:++  join f' :: Int -> Char -> [Int]+       f' x c = ... jump f' y 'a' ...+  in ... jump f' 1 'b' ... jump f' 2 'c' ...++It's not clear that this comes up often, however. TODO: Measure how often and+add this analysis if necessary.  See #14620.+++************************************************************************+*                                                                      *+\subsection{Sequencing on types}+*                                                                      *+************************************************************************+-}++seqType :: Type -> ()+seqType (LitTy n)                   = n `seq` ()+seqType (TyVarTy tv)                = tv `seq` ()+seqType (AppTy t1 t2)               = seqType t1 `seq` seqType t2+seqType (FunTy _ t1 t2)             = seqType t1 `seq` seqType t2+seqType (TyConApp tc tys)           = tc `seq` seqTypes tys+seqType (ForAllTy (Bndr tv _) ty)   = seqType (varType tv) `seq` seqType ty+seqType (CastTy ty co)              = seqType ty `seq` seqCo co+seqType (CoercionTy co)             = seqCo co++seqTypes :: [Type] -> ()+seqTypes []       = ()+seqTypes (ty:tys) = seqType ty `seq` seqTypes tys++{-+************************************************************************+*                                                                      *+                Comparison for types+        (We don't use instances so that we know where it happens)+*                                                                      *+************************************************************************++Note [Equality on AppTys]+~~~~~~~~~~~~~~~~~~~~~~~~~+In our cast-ignoring equality, we want to say that the following two+are equal:++  (Maybe |> co) (Int |> co')   ~?       Maybe Int++But the left is an AppTy while the right is a TyConApp. The solution is+to use repSplitAppTy_maybe to break up the TyConApp into its pieces and+then continue. Easy to do, but also easy to forget to do.++-}++eqType :: Type -> Type -> Bool+-- ^ Type equality on source types. Does not look through @newtypes@ or+-- 'PredType's, but it does look through type synonyms.+-- This first checks that the kinds of the types are equal and then+-- checks whether the types are equal, ignoring casts and coercions.+-- (The kind check is a recursive call, but since all kinds have type+-- @Type@, there is no need to check the types of kinds.)+-- See also Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep.+eqType t1 t2 = isEqual $ nonDetCmpType t1 t2+  -- It's OK to use nonDetCmpType here and eqType is deterministic,+  -- nonDetCmpType does equality deterministically++-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'.+eqTypeX :: RnEnv2 -> Type -> Type -> Bool+eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2+  -- It's OK to use nonDetCmpType here and eqTypeX is deterministic,+  -- nonDetCmpTypeX does equality deterministically++-- | Type equality on lists of types, looking through type synonyms+-- but not newtypes.+eqTypes :: [Type] -> [Type] -> Bool+eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2+  -- It's OK to use nonDetCmpType here and eqTypes is deterministic,+  -- nonDetCmpTypes does equality deterministically++eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2+-- Check that the var lists are the same length+-- and have matching kinds; if so, extend the RnEnv2+-- Returns Nothing if they don't match+eqVarBndrs env [] []+ = Just env+eqVarBndrs env (tv1:tvs1) (tv2:tvs2)+ | eqTypeX env (varType tv1) (varType tv2)+ = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2+eqVarBndrs _ _ _= Nothing++-- Now here comes the real worker++{-+Note [nonDetCmpType nondeterminism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX+uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for+ordering leads to nondeterminism. We hit the same problem in the TyVarTy case,+comparing type variables is nondeterministic, note the call to nonDetCmpVar in+nonDetCmpTypeX.+See Note [Unique Determinism] for more details.+-}++nonDetCmpType :: Type -> Type -> Ordering+nonDetCmpType t1 t2+  -- we know k1 and k2 have the same kind, because they both have kind *.+  = nonDetCmpTypeX rn_env t1 t2+  where+    rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2]))++nonDetCmpTypes :: [Type] -> [Type] -> Ordering+nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2+  where+    rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2)))++-- | An ordering relation between two 'Type's (known below as @t1 :: k1@+-- and @t2 :: k2@)+data TypeOrdering = TLT  -- ^ @t1 < t2@+                  | TEQ  -- ^ @t1 ~ t2@ and there are no casts in either,+                         -- therefore we can conclude @k1 ~ k2@+                  | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so+                         -- they may differ in kind.+                  | TGT  -- ^ @t1 > t2@+                  deriving (Eq, Ord, Enum, Bounded)++nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering  -- Main workhorse+    -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep+nonDetCmpTypeX env orig_t1 orig_t2 =+    case go env orig_t1 orig_t2 of+      -- If there are casts then we also need to do a comparison of the kinds of+      -- the types being compared+      TEQX          -> toOrdering $ go env k1 k2+      ty_ordering   -> toOrdering ty_ordering+  where+    k1 = typeKind orig_t1+    k2 = typeKind orig_t2++    toOrdering :: TypeOrdering -> Ordering+    toOrdering TLT  = LT+    toOrdering TEQ  = EQ+    toOrdering TEQX = EQ+    toOrdering TGT  = GT++    liftOrdering :: Ordering -> TypeOrdering+    liftOrdering LT = TLT+    liftOrdering EQ = TEQ+    liftOrdering GT = TGT++    thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering+    thenCmpTy TEQ  rel  = rel+    thenCmpTy TEQX rel  = hasCast rel+    thenCmpTy rel  _    = rel++    hasCast :: TypeOrdering -> TypeOrdering+    hasCast TEQ = TEQX+    hasCast rel = rel++    -- Returns both the resulting ordering relation between the two types+    -- and whether either contains a cast.+    go :: RnEnv2 -> Type -> Type -> TypeOrdering+    go env t1 t2+      | Just t1' <- coreView t1 = go env t1' t2+      | Just t2' <- coreView t2 = go env t1 t2'++    go env (TyVarTy tv1)       (TyVarTy tv2)+      = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2+    go env (ForAllTy (Bndr tv1 _) t1) (ForAllTy (Bndr tv2 _) t2)+      = go env (varType tv1) (varType tv2)+        `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2+        -- See Note [Equality on AppTys]+    go env (AppTy s1 t1) ty2+      | Just (s2, t2) <- repSplitAppTy_maybe ty2+      = go env s1 s2 `thenCmpTy` go env t1 t2+    go env ty1 (AppTy s2 t2)+      | Just (s1, t1) <- repSplitAppTy_maybe ty1+      = go env s1 s2 `thenCmpTy` go env t1 t2+    go env (FunTy _ s1 t1) (FunTy _ s2 t2)+      = go env s1 s2 `thenCmpTy` go env t1 t2+    go env (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2+    go _   (LitTy l1)          (LitTy l2)          = liftOrdering (compare l1 l2)+    go env (CastTy t1 _)       t2                  = hasCast $ go env t1 t2+    go env t1                  (CastTy t2 _)       = hasCast $ go env t1 t2++    go _   (CoercionTy {})     (CoercionTy {})     = TEQ++        -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy+    go _ ty1 ty2+      = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2)+      where get_rank :: Type -> Int+            get_rank (CastTy {})+              = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2])+            get_rank (TyVarTy {})    = 0+            get_rank (CoercionTy {}) = 1+            get_rank (AppTy {})      = 3+            get_rank (LitTy {})      = 4+            get_rank (TyConApp {})   = 5+            get_rank (FunTy {})      = 6+            get_rank (ForAllTy {})   = 7++    gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering+    gos _   []         []         = TEQ+    gos _   []         _          = TLT+    gos _   _          []         = TGT+    gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2++-------------+nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering+nonDetCmpTypesX _   []        []        = EQ+nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2+                                          `thenCmp`+                                          nonDetCmpTypesX env tys1 tys2+nonDetCmpTypesX _   []        _         = LT+nonDetCmpTypesX _   _         []        = GT++-------------+-- | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as+-- recognized by Kind.isConstraintKindCon) which is considered a synonym for+-- 'Type' in Core.+-- See Note [Kind Constraint and kind Type] in Kind.+-- See Note [nonDetCmpType nondeterminism]+nonDetCmpTc :: TyCon -> TyCon -> Ordering+nonDetCmpTc tc1 tc2+  = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) )+    u1 `nonDetCmpUnique` u2+  where+    u1  = tyConUnique tc1+    u2  = tyConUnique tc2++{-+************************************************************************+*                                                                      *+        The kind of a type+*                                                                      *+************************************************************************++Note [typeKind vs tcTypeKind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have two functions to get the kind of a type++  * typeKind   ignores  the distinction between Constraint and *+  * tcTypeKind respects the distinction between Constraint and *++tcTypeKind is used by the type inference engine, for which Constraint+and * are different; after that we use typeKind.++See also Note [coreView vs tcView]++Note [Kinding rules for types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In typeKind we consider Constraint and (TYPE LiftedRep) to be identical.+We then have++         t1 : TYPE rep1+         t2 : TYPE rep2+   (FUN) ----------------+         t1 -> t2 : Type++         ty : TYPE rep+         `a` is not free in rep+(FORALL) -----------------------+         forall a. ty : TYPE rep++In tcTypeKind we consider Constraint and (TYPE LiftedRep) to be distinct:++          t1 : TYPE rep1+          t2 : TYPE rep2+    (FUN) ----------------+          t1 -> t2 : Type++          t1 : Constraint+          t2 : TYPE rep+  (PRED1) ----------------+          t1 => t2 : Type++          t1 : Constraint+          t2 : Constraint+  (PRED2) ---------------------+          t1 => t2 : Constraint++          ty : TYPE rep+          `a` is not free in rep+(FORALL1) -----------------------+          forall a. ty : TYPE rep++          ty : Constraint+(FORALL2) -------------------------+          forall a. ty : Constraint++Note that:+* The only way we distinguish '->' from '=>' is by the fact+  that the argument is a PredTy.  Both are FunTys++Note [Phantom type variables in kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  type K (r :: RuntimeRep) = Type   -- Note 'r' is unused+  data T r :: K r                   -- T :: forall r -> K r+  foo :: forall r. T r++The body of the forall in foo's type has kind (K r), and+normally it would make no sense to have+   forall r. (ty :: K r)+because the kind of the forall would escape the binding+of 'r'.  But in this case it's fine because (K r) exapands+to Type, so we expliclity /permit/ the type+   forall r. T r++To accommodate such a type, in typeKind (forall a.ty) we use+occCheckExpand to expand any type synonyms in the kind of 'ty'+to eliminate 'a'.  See kinding rule (FORALL) in+Note [Kinding rules for types]++And in TcValidity.checkEscapingKind, we use also use+occCheckExpand, for the same reason.+-}++-----------------------------+typeKind :: HasDebugCallStack => Type -> Kind+-- No need to expand synonyms+typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys+typeKind (LitTy l)         = typeLiteralKind l+typeKind (FunTy {})        = liftedTypeKind+typeKind (TyVarTy tyvar)   = tyVarKind tyvar+typeKind (CastTy _ty co)   = coercionRKind co+typeKind (CoercionTy co)   = coercionType co++typeKind (AppTy fun arg)+  = go fun [arg]+  where+    -- Accumulate the type arguments, so we can call piResultTys,+    -- rather than a succession of calls to piResultTy (which is+    -- asymptotically costly as the number of arguments increases)+    go (AppTy fun arg) args = go fun (arg:args)+    go fun             args = piResultTys (typeKind fun) args++typeKind ty@(ForAllTy {})+  = case occCheckExpand tvs body_kind of+      -- We must make sure tv does not occur in kind+      -- As it is already out of scope!+      -- See Note [Phantom type variables in kinds]+      Just k' -> k'+      Nothing -> pprPanic "typeKind"+                  (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind)+  where+    (tvs, body) = splitTyVarForAllTys ty+    body_kind   = typeKind body++---------------------------------------------+-- Utilities to be used in GHC.Core.Unify,+-- which uses "tc" functions+---------------------------------------------++tcTypeKind :: HasDebugCallStack => Type -> Kind+-- No need to expand synonyms+tcTypeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys+tcTypeKind (LitTy l)         = typeLiteralKind l+tcTypeKind (TyVarTy tyvar)   = tyVarKind tyvar+tcTypeKind (CastTy _ty co)   = coercionRKind co+tcTypeKind (CoercionTy co)   = coercionType co++tcTypeKind (FunTy { ft_af = af, ft_res = res })+  | InvisArg <- af+  , tcIsConstraintKind (tcTypeKind res)+  = constraintKind     -- Eq a => Ord a         :: Constraint+  | otherwise          -- Eq a => a -> a        :: TYPE LiftedRep+  = liftedTypeKind     -- Eq a => Array# Int    :: Type LiftedRep (not TYPE PtrRep)++tcTypeKind (AppTy fun arg)+  = go fun [arg]+  where+    -- Accumulate the type arguments, so we can call piResultTys,+    -- rather than a succession of calls to piResultTy (which is+    -- asymptotically costly as the number of arguments increases)+    go (AppTy fun arg) args = go fun (arg:args)+    go fun             args = piResultTys (tcTypeKind fun) args++tcTypeKind ty@(ForAllTy {})+  | tcIsConstraintKind body_kind+  = constraintKind++  | otherwise+  = case occCheckExpand tvs body_kind of+      -- We must make sure tv does not occur in kind+      -- As it is already out of scope!+      -- See Note [Phantom type variables in kinds]+      Just k' -> k'+      Nothing -> pprPanic "tcTypeKind"+                  (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind)+  where+    (tvs, body) = splitTyVarForAllTys ty+    body_kind = tcTypeKind body+++isPredTy :: HasDebugCallStack => Type -> Bool+-- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep+isPredTy ty = tcIsConstraintKind (tcTypeKind ty)++-- tcIsConstraintKind stuff only makes sense in the typechecker+-- After that Constraint = Type+-- See Note [coreView vs tcView]+-- Defined here because it is used in isPredTy and tcRepSplitAppTy_maybe (sigh)+tcIsConstraintKind :: Kind -> Bool+tcIsConstraintKind ty+  | Just (tc, args) <- tcSplitTyConApp_maybe ty    -- Note: tcSplit here+  , isConstraintKindCon tc+  = ASSERT2( null args, ppr ty ) True++  | otherwise+  = False++-- | Is this kind equivalent to @*@?+--+-- This considers 'Constraint' to be distinct from @*@. For a version that+-- treats them as the same type, see 'isLiftedTypeKind'.+tcIsLiftedTypeKind :: Kind -> Bool+tcIsLiftedTypeKind ty+  | Just (tc, [arg]) <- tcSplitTyConApp_maybe ty    -- Note: tcSplit here+  , tc `hasKey` tYPETyConKey+  = isLiftedRuntimeRep arg+  | otherwise+  = False++-- | Is this kind equivalent to @TYPE r@ (for some unknown r)?+--+-- This considers 'Constraint' to be distinct from @*@.+tcIsRuntimeTypeKind :: Kind -> Bool+tcIsRuntimeTypeKind ty+  | Just (tc, _) <- tcSplitTyConApp_maybe ty    -- Note: tcSplit here+  , tc `hasKey` tYPETyConKey+  = True+  | otherwise+  = False++tcReturnsConstraintKind :: Kind -> Bool+-- True <=> the Kind ultimately returns a Constraint+--   E.g.  * -> Constraint+--         forall k. k -> Constraint+tcReturnsConstraintKind kind+  | Just kind' <- tcView kind = tcReturnsConstraintKind kind'+tcReturnsConstraintKind (ForAllTy _ ty)         = tcReturnsConstraintKind ty+tcReturnsConstraintKind (FunTy { ft_res = ty }) = tcReturnsConstraintKind ty+tcReturnsConstraintKind (TyConApp tc _)         = isConstraintKindCon tc+tcReturnsConstraintKind _                       = False++--------------------------+typeLiteralKind :: TyLit -> Kind+typeLiteralKind (NumTyLit {}) = typeNatKind+typeLiteralKind (StrTyLit {}) = typeSymbolKind++-- | Returns True if a type is levity polymorphic. Should be the same+-- as (isKindLevPoly . typeKind) but much faster.+-- Precondition: The type has kind (TYPE blah)+isTypeLevPoly :: Type -> Bool+isTypeLevPoly = go+  where+    go ty@(TyVarTy {})                           = check_kind ty+    go ty@(AppTy {})                             = check_kind ty+    go ty@(TyConApp tc _) | not (isTcLevPoly tc) = False+                          | otherwise            = check_kind ty+    go (ForAllTy _ ty)                           = go ty+    go (FunTy {})                                = False+    go (LitTy {})                                = False+    go ty@(CastTy {})                            = check_kind ty+    go ty@(CoercionTy {})                        = pprPanic "isTypeLevPoly co" (ppr ty)++    check_kind = isKindLevPoly . typeKind++-- | Looking past all pi-types, is the end result potentially levity polymorphic?+-- Example: True for (forall r (a :: TYPE r). String -> a)+-- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type)+resultIsLevPoly :: Type -> Bool+resultIsLevPoly = isTypeLevPoly . snd . splitPiTys+++{- **********************************************************************+*                                                                       *+           Occurs check expansion+%*                                                                      *+%********************************************************************* -}++{- Note [Occurs check expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid+of occurrences of tv outside type function arguments, if that is+possible; otherwise, it returns Nothing.++For example, suppose we have+  type F a b = [a]+Then+  occCheckExpand b (F Int b) = Just [Int]+but+  occCheckExpand a (F a Int) = Nothing++We don't promise to do the absolute minimum amount of expanding+necessary, but we try not to do expansions we don't need to.  We+prefer doing inner expansions first.  For example,+  type F a b = (a, Int, a, [a])+  type G b   = Char+We have+  occCheckExpand b (F (G b)) = Just (F Char)+even though we could also expand F to get rid of b.+-}++occCheckExpand :: [Var] -> Type -> Maybe Type+-- See Note [Occurs check expansion]+-- We may have needed to do some type synonym unfolding in order to+-- get rid of the variable (or forall), so we also return the unfolded+-- version of the type, which is guaranteed to be syntactically free+-- of the given type variable.  If the type is already syntactically+-- free of the variable, then the same type is returned.+occCheckExpand vs_to_avoid ty+  | null vs_to_avoid  -- Efficient shortcut+  = Just ty           -- Can happen, eg. GHC.Core.Utils.mkSingleAltCase++  | otherwise+  = go (mkVarSet vs_to_avoid, emptyVarEnv) ty+  where+    go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type+          -- The VarSet is the set of variables we are trying to avoid+          -- The VarEnv carries mappings necessary+          -- because of kind expansion+    go cxt@(as, env) (TyVarTy tv')+      | tv' `elemVarSet` as               = Nothing+      | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'')+      | otherwise                         = do { tv'' <- go_var cxt tv'+                                               ; return (mkTyVarTy tv'') }++    go _   ty@(LitTy {}) = return ty+    go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1+                                ; ty2' <- go cxt ty2+                                ; return (mkAppTy ty1' ty2') }+    go cxt ty@(FunTy _ ty1 ty2)+       = do { ty1' <- go cxt ty1+            ; ty2' <- go cxt ty2+            ; return (ty { ft_arg = ty1', ft_res = ty2' }) }+    go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty)+       = do { ki' <- go cxt (varType tv)+            ; let tv' = setVarType tv ki'+                  env' = extendVarEnv env tv tv'+                  as'  = as `delVarSet` tv+            ; body' <- go (as', env') body_ty+            ; return (ForAllTy (Bndr tv' vis) body') }++    -- For a type constructor application, first try expanding away the+    -- offending variable from the arguments.  If that doesn't work, next+    -- see if the type constructor is a type synonym, and if so, expand+    -- it and try again.+    go cxt ty@(TyConApp tc tys)+      = case mapM (go cxt) tys of+          Just tys' -> return (mkTyConApp tc tys')+          Nothing | Just ty' <- tcView ty -> go cxt ty'+                  | otherwise             -> Nothing+                      -- Failing that, try to expand a synonym++    go cxt (CastTy ty co) =  do { ty' <- go cxt ty+                                ; co' <- go_co cxt co+                                ; return (mkCastTy ty' co') }+    go cxt (CoercionTy co) = do { co' <- go_co cxt co+                                ; return (mkCoercionTy co') }++    ------------------+    go_var cxt v = do { k' <- go cxt (varType v)+                      ; return (setVarType v k') }+           -- Works for TyVar and CoVar+           -- See Note [Occurrence checking: look inside kinds]++    ------------------+    go_mco _   MRefl = return MRefl+    go_mco ctx (MCo co) = MCo <$> go_co ctx co++    ------------------+    go_co cxt (Refl ty)                 = do { ty' <- go cxt ty+                                             ; return (mkNomReflCo ty') }+    go_co cxt (GRefl r ty mco)          = do { mco' <- go_mco cxt mco+                                             ; ty' <- go cxt ty+                                             ; return (mkGReflCo r ty' mco') }+      -- Note: Coercions do not contain type synonyms+    go_co cxt (TyConAppCo r tc args)    = do { args' <- mapM (go_co cxt) args+                                             ; return (mkTyConAppCo r tc args') }+    go_co cxt (AppCo co arg)            = do { co' <- go_co cxt co+                                             ; arg' <- go_co cxt arg+                                             ; return (mkAppCo co' arg') }+    go_co cxt@(as, env) (ForAllCo tv kind_co body_co)+      = do { kind_co' <- go_co cxt kind_co+           ; let tv' = setVarType tv $+                       coercionLKind kind_co'+                 env' = extendVarEnv env tv tv'+                 as'  = as `delVarSet` tv+           ; body' <- go_co (as', env') body_co+           ; return (ForAllCo tv' kind_co' body') }+    go_co cxt (FunCo r co1 co2)         = do { co1' <- go_co cxt co1+                                             ; co2' <- go_co cxt co2+                                             ; return (mkFunCo r co1' co2') }+    go_co cxt@(as,env) (CoVarCo c)+      | c `elemVarSet` as               = Nothing+      | Just c' <- lookupVarEnv env c   = return (mkCoVarCo c')+      | otherwise                       = do { c' <- go_var cxt c+                                             ; return (mkCoVarCo c') }+    go_co cxt (HoleCo h)                = do { c' <- go_var cxt (ch_co_var h)+                                             ; return (HoleCo (h { ch_co_var = c' })) }+    go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args+                                             ; return (mkAxiomInstCo ax ind args') }+    go_co cxt (UnivCo p r ty1 ty2)      = do { p' <- go_prov cxt p+                                             ; ty1' <- go cxt ty1+                                             ; ty2' <- go cxt ty2+                                             ; return (mkUnivCo p' r ty1' ty2') }+    go_co cxt (SymCo co)                = do { co' <- go_co cxt co+                                             ; return (mkSymCo co') }+    go_co cxt (TransCo co1 co2)         = do { co1' <- go_co cxt co1+                                             ; co2' <- go_co cxt co2+                                             ; return (mkTransCo co1' co2') }+    go_co cxt (NthCo r n co)            = do { co' <- go_co cxt co+                                             ; return (mkNthCo r n co') }+    go_co cxt (LRCo lr co)              = do { co' <- go_co cxt co+                                             ; return (mkLRCo lr co') }+    go_co cxt (InstCo co arg)           = do { co' <- go_co cxt co+                                             ; arg' <- go_co cxt arg+                                             ; return (mkInstCo co' arg') }+    go_co cxt (KindCo co)               = do { co' <- go_co cxt co+                                             ; return (mkKindCo co') }+    go_co cxt (SubCo co)                = do { co' <- go_co cxt co+                                             ; return (mkSubCo co') }+    go_co cxt (AxiomRuleCo ax cs)       = do { cs' <- mapM (go_co cxt) cs+                                             ; return (mkAxiomRuleCo ax cs') }++    ------------------+    go_prov cxt (PhantomProv co)    = PhantomProv <$> go_co cxt co+    go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co+    go_prov _   p@(PluginProv _)    = return p+++{-+%************************************************************************+%*                                                                      *+        Miscellaneous functions+%*                                                                      *+%************************************************************************++-}+-- | All type constructors occurring in the type; looking through type+--   synonyms, but not newtypes.+--  When it finds a Class, it returns the class TyCon.+tyConsOfType :: Type -> UniqSet TyCon+tyConsOfType ty+  = go ty+  where+     go :: Type -> UniqSet TyCon  -- The UniqSet does duplicate elim+     go ty | Just ty' <- coreView ty = go ty'+     go (TyVarTy {})                = emptyUniqSet+     go (LitTy {})                  = emptyUniqSet+     go (TyConApp tc tys)           = go_tc tc `unionUniqSets` go_s tys+     go (AppTy a b)                 = go a `unionUniqSets` go b+     go (FunTy _ a b)               = go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon+     go (ForAllTy (Bndr tv _) ty)   = go ty `unionUniqSets` go (varType tv)+     go (CastTy ty co)              = go ty `unionUniqSets` go_co co+     go (CoercionTy co)             = go_co co++     go_co (Refl ty)               = go ty+     go_co (GRefl _ ty mco)        = go ty `unionUniqSets` go_mco mco+     go_co (TyConAppCo _ tc args)  = go_tc tc `unionUniqSets` go_cos args+     go_co (AppCo co arg)          = go_co co `unionUniqSets` go_co arg+     go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co+     go_co (FunCo _ co1 co2)       = go_co co1 `unionUniqSets` go_co co2+     go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args+     go_co (UnivCo p _ t1 t2)      = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2+     go_co (CoVarCo {})            = emptyUniqSet+     go_co (HoleCo {})             = emptyUniqSet+     go_co (SymCo co)              = go_co co+     go_co (TransCo co1 co2)       = go_co co1 `unionUniqSets` go_co co2+     go_co (NthCo _ _ co)          = go_co co+     go_co (LRCo _ co)             = go_co co+     go_co (InstCo co arg)         = go_co co `unionUniqSets` go_co arg+     go_co (KindCo co)             = go_co co+     go_co (SubCo co)              = go_co co+     go_co (AxiomRuleCo _ cs)      = go_cos cs++     go_mco MRefl    = emptyUniqSet+     go_mco (MCo co) = go_co co++     go_prov (PhantomProv co)    = go_co co+     go_prov (ProofIrrelProv co) = go_co co+     go_prov (PluginProv _)      = emptyUniqSet+        -- this last case can happen from the tyConsOfType used from+        -- checkTauTvUpdate++     go_s tys     = foldr (unionUniqSets . go)     emptyUniqSet tys+     go_cos cos   = foldr (unionUniqSets . go_co)  emptyUniqSet cos++     go_tc tc = unitUniqSet tc+     go_ax ax = go_tc $ coAxiomTyCon ax++-- | Find the result 'Kind' of a type synonym,+-- after applying it to its 'arity' number of type variables+-- Actually this function works fine on data types too,+-- but they'd always return '*', so we never need to ask+synTyConResKind :: TyCon -> Kind+synTyConResKind tycon = piResultTys (tyConKind tycon) (mkTyVarTys (tyConTyVars tycon))++-- | Retrieve the free variables in this type, splitting them based+-- on whether they are used visibly or invisibly. Invisible ones come+-- first.+splitVisVarsOfType :: Type -> Pair TyCoVarSet+splitVisVarsOfType orig_ty = Pair invis_vars vis_vars+  where+    Pair invis_vars1 vis_vars = go orig_ty+    invis_vars = invis_vars1 `minusVarSet` vis_vars++    go (TyVarTy tv)      = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv)+    go (AppTy t1 t2)     = go t1 `mappend` go t2+    go (TyConApp tc tys) = go_tc tc tys+    go (FunTy _ t1 t2)   = go t1 `mappend` go t2+    go (ForAllTy (Bndr tv _) ty)+      = ((`delVarSet` tv) <$> go ty) `mappend`+        (invisible (tyCoVarsOfType $ varType tv))+    go (LitTy {}) = mempty+    go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co)+    go (CoercionTy co) = invisible $ tyCoVarsOfCo co++    invisible vs = Pair vs emptyVarSet++    go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in+                   invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis++splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet+splitVisVarsOfTypes = foldMap splitVisVarsOfType++modifyJoinResTy :: Int            -- Number of binders to skip+                -> (Type -> Type) -- Function to apply to result type+                -> Type           -- Type of join point+                -> Type           -- New type+-- INVARIANT: If any of the first n binders are foralls, those tyvars cannot+-- appear in the original result type. See isValidJoinPointType.+modifyJoinResTy orig_ar f orig_ty+  = go orig_ar orig_ty+  where+    go 0 ty = f ty+    go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty+            = mkPiTy arg_bndr (go (n-1) res_ty)+            | otherwise+            = pprPanic "modifyJoinResTy" (ppr orig_ar <+> ppr orig_ty)++setJoinResTy :: Int  -- Number of binders to skip+             -> Type -- New result type+             -> Type -- Type of join point+             -> Type -- New type+-- INVARIANT: Same as for modifyJoinResTy+setJoinResTy ar new_res_ty ty+  = modifyJoinResTy ar (const new_res_ty) ty++{-+************************************************************************+*                                                                      *+        Functions over Kinds+*                                                                      *+************************************************************************++Note [Kind Constraint and kind Type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The kind Constraint is the kind of classes and other type constraints.+The special thing about types of kind Constraint is that+ * They are displayed with double arrow:+     f :: Ord a => a -> a+ * They are implicitly instantiated at call sites; so the type inference+   engine inserts an extra argument of type (Ord a) at every call site+   to f.++However, once type inference is over, there is *no* distinction between+Constraint and Type. Indeed we can have coercions between the two. Consider+   class C a where+     op :: a -> a+For this single-method class we may generate a newtype, which in turn+generates an axiom witnessing+    C a ~ (a -> a)+so on the left we have Constraint, and on the right we have Type.+See #7451.++Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with+distinct uniques, they are treated as equal at all times except+during type inference.+-}++isConstraintKindCon :: TyCon -> Bool+isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey++-- | Tests whether the given kind (which should look like @TYPE x@)+-- is something other than a constructor tree (that is, constructors at every node).+-- E.g.  True of   TYPE k, TYPE (F Int)+--       False of  TYPE 'LiftedRep+isKindLevPoly :: Kind -> Bool+isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k )+                    -- the isLiftedTypeKind check is necessary b/c of Constraint+                  go k+  where+    go ty | Just ty' <- coreView ty = go ty'+    go TyVarTy{}         = True+    go AppTy{}           = True  -- it can't be a TyConApp+    go (TyConApp tc tys) = isFamilyTyCon tc || any go tys+    go ForAllTy{}        = True+    go (FunTy _ t1 t2)   = go t1 || go t2+    go LitTy{}           = False+    go CastTy{}          = True+    go CoercionTy{}      = True++    _is_type = classifiesTypeWithValues k++-----------------------------------------+--              Subkinding+-- The tc variants are used during type-checking, where ConstraintKind+-- is distinct from all other kinds+-- After type-checking (in core), Constraint and liftedTypeKind are+-- indistinguishable++-- | Does this classify a type allowed to have values? Responds True to things+-- like *, #, TYPE Lifted, TYPE v, Constraint.+classifiesTypeWithValues :: Kind -> Bool+-- ^ True of any sub-kind of OpenTypeKind+classifiesTypeWithValues k = isJust (kindRep_maybe k)++{-+%************************************************************************+%*                                                                      *+         Pretty-printing+%*                                                                      *+%************************************************************************++Most pretty-printing is either in GHC.Core.TyCo.Rep or GHC.Iface.Type.++-}++-- | Does a 'TyCon' (that is applied to some number of arguments) need to be+-- ascribed with an explicit kind signature to resolve ambiguity if rendered as+-- a source-syntax type?+-- (See @Note [When does a tycon application need an explicit kind signature?]@+-- for a full explanation of what this function checks for.)+tyConAppNeedsKindSig+  :: Bool  -- ^ Should specified binders count towards injective positions in+           --   the kind of the TyCon? (If you're using visible kind+           --   applications, then you want True here.+  -> TyCon+  -> Int   -- ^ The number of args the 'TyCon' is applied to.+  -> Bool  -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the+           --   number of arguments)+tyConAppNeedsKindSig spec_inj_pos tc n_args+  | LT <- listLengthCmp tc_binders n_args+  = False+  | otherwise+  = let (dropped_binders, remaining_binders)+          = splitAt n_args tc_binders+        result_kind  = mkTyConKind remaining_binders tc_res_kind+        result_vars  = tyCoVarsOfType result_kind+        dropped_vars = fvVarSet $+                       mapUnionFV injective_vars_of_binder dropped_binders++    in not (subVarSet result_vars dropped_vars)+  where+    tc_binders  = tyConBinders tc+    tc_res_kind = tyConResKind tc++    -- Returns the variables that would be fixed by knowing a TyConBinder. See+    -- Note [When does a tycon application need an explicit kind signature?]+    -- for a more detailed explanation of what this function does.+    injective_vars_of_binder :: TyConBinder -> FV+    injective_vars_of_binder (Bndr tv vis) =+      case vis of+        AnonTCB VisArg -> injectiveVarsOfType False -- conservative choice+                                              (varType tv)+        NamedTCB argf  | source_of_injectivity argf+                       -> unitFV tv `unionFV`+                          injectiveVarsOfType False (varType tv)+        _              -> emptyFV++    source_of_injectivity Required  = True+    source_of_injectivity Specified = spec_inj_pos+    source_of_injectivity Inferred  = False++{-+Note [When does a tycon application need an explicit kind signature?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are a couple of places in GHC where we convert Core Types into forms that+more closely resemble user-written syntax. These include:++1. Template Haskell Type reification (see, for instance, TcSplice.reify_tc_app)+2. Converting Types to LHsTypes (in GHC.Hs.Utils.typeToLHsType, or in Haddock)++This conversion presents a challenge: how do we ensure that the resulting type+has enough kind information so as not to be ambiguous? To better motivate this+question, consider the following Core type:++  -- Foo :: Type -> Type+  type Foo = Proxy Type++There is nothing ambiguous about the RHS of Foo in Core. But if we were to,+say, reify it into a TH Type, then it's tempting to just drop the invisible+Type argument and simply return `Proxy`. But now we've lost crucial kind+information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool`+or `Proxy Int` or something else! We've inadvertently introduced ambiguity.++Unlike in other situations in GHC, we can't just turn on+-fprint-explicit-kinds, as we need to produce something which has the same+structure as a source-syntax type. Moreover, we can't rely on visible kind+application, since the first kind argument to Proxy is inferred, not specified.+Our solution is to annotate certain tycons with their kinds whenever they+appear in applied form in order to resolve the ambiguity. For instance, we+would reify the RHS of Foo like so:++  type Foo = (Proxy :: Type -> Type)++We need to devise an algorithm that determines precisely which tycons need+these explicit kind signatures. We certainly don't want to annotate _every_+tycon with a kind signature, or else we might end up with horribly bloated+types like the following:++  (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type)++We only want to annotate tycons that absolutely require kind signatures in+order to resolve some sort of ambiguity, and nothing more.++Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type+require a kind signature? It might require it when we need to fill in any of+T's omitted arguments. By "omitted argument", we mean one that is dropped when+reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and+specified arguments (e.g., TH reification in TcSplice), and sometimes the+omitted arguments are only the inferred ones (e.g., in GHC.Hs.Utils.typeToLHsType,+which reifies specified arguments through visible kind application).+Regardless, the key idea is that _some_ arguments are going to be omitted after+reification, and the only mechanism we have at our disposal for filling them in+is through explicit kind signatures.++What do we mean by "fill in"? Let's consider this small example:++  T :: forall {k}. Type -> (k -> Type) -> k++Moreover, we have this application of T:++  T @{j} Int aty++When we reify this type, we omit the inferred argument @{j}. Is it fixed by the+other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then+we'll generate an equality constraint (kappa -> Type) and, assuming we can+solve it, that will fix `kappa`. (Here, `kappa` is the unification variable+that we instantiate `k` with.)++Therefore, for any application of a tycon T to some arguments, the Question We+Must Answer is:++* Given the first n arguments of T, do the kinds of the non-omitted arguments+  fill in the omitted arguments?++(This is still a bit hand-wavey, but we'll refine this question incrementally+as we explain more of the machinery underlying this process.)++Answering this question is precisely the role that the `injectiveVarsOfType`+and `injective_vars_of_binder` functions exist to serve. If an omitted argument+`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing+`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a+bit.)++More formally, if+`a` is in `injectiveVarsOfType ty`+and  S1(ty) ~ S2(ty),+then S1(a)  ~ S2(a),+where S1 and S2 are arbitrary substitutions.++For example, is `F` is a non-injective type family, then++  injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c}++Now that we know what this function does, here is a second attempt at the+Question We Must Answer:++* Given the first n arguments of T (ty_1 ... ty_n), consider the binders+  of T that are instantiated by non-omitted arguments. Do the injective+  variables of these binders fill in the remainder of T's kind?++Alright, we're getting closer. Next, we need to clarify what the injective+variables of a tycon binder are. This the role that the+`injective_vars_of_binder` function serves. Here is what this function does for+each form of tycon binder:++* Anonymous binders are injective positions. For example, in the promoted data+  constructor '(:):++    '(:) :: forall a. a -> [a] -> [a]++  The second and third tyvar binders (of kinds `a` and `[a]`) are both+  anonymous, so if we had '(:) 'True '[], then the kinds of 'True and+  '[] would contribute to the kind of '(:) 'True '[]. Therefore,+  injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}.+  (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.)+* Named binders:+  - Inferred binders are never injective positions. For example, in this data+    type:++      data Proxy a+      Proxy :: forall {k}. k -> Type++    If we had Proxy 'True, then the kind of 'True would not contribute to the+    kind of Proxy 'True. Therefore,+    injective_vars_of_binder(forall {k}. ...) = {}.+  - Required binders are injective positions. For example, in this data type:++      data Wurble k (a :: k) :: k+      Wurble :: forall k -> k -> k++  The first tyvar binder (of kind `forall k`) has required visibility, so if+  we had Wurble (Maybe a) Nothing, then the kind of Maybe a would+  contribute to the kind of Wurble (Maybe a) Nothing. Hence,+  injective_vars_of_binder(forall a -> ...) = {a}.+  - Specified binders /might/ be injective positions, depending on how you+    approach things. Continuing the '(:) example:++      '(:) :: forall a. a -> [a] -> [a]++    Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind+    of '(:) 'True '[], since it's not explicitly instantiated by the user. But+    if visible kind application is enabled, then this is possible, since the+    user can write '(:) @Bool 'True '[]. (In that case,+    injective_vars_of_binder(forall a. ...) = {a}.)++    There are some situations where using visible kind application is appropriate+    (e.g., GHC.Hs.Utils.typeToLHsType) and others where it is not (e.g., TH+    reification), so the `injective_vars_of_binder` function is parametrized by+    a Bool which decides if specified binders should be counted towards+    injective positions or not.++Now that we've defined injective_vars_of_binder, we can refine the Question We+Must Answer once more:++* Given the first n arguments of T (ty_1 ... ty_n), consider the binders+  of T that are instantiated by non-omitted arguments. For each such binder+  b_i, take the union of all injective_vars_of_binder(b_i). Is this set a+  superset of the free variables of the remainder of T's kind?++If the answer to this question is "no", then (T ty_1 ... ty_n) needs an+explicit kind signature, since T's kind has kind variables leftover that+aren't fixed by the non-omitted arguments.++One last sticking point: what does "the remainder of T's kind" mean? You might+be tempted to think that it corresponds to all of the arguments in the kind of+T that would normally be instantiated by omitted arguments. But this isn't+quite right, strictly speaking. Consider the following (silly) example:++  S :: forall {k}. Type -> Type++And suppose we have this application of S:++  S Int Bool++The Int argument would be omitted, and+injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which+might suggest that (S Bool) needs an explicit kind signature. But+(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature+only affects the /result/ of the application, not all of the individual+arguments. So adding a kind signature here won't make a difference. Therefore,+the fourth (and final) iteration of the Question We Must Answer is:++* Given the first n arguments of T (ty_1 ... ty_n), consider the binders+  of T that are instantiated by non-omitted arguments. For each such binder+  b_i, take the union of all injective_vars_of_binder(b_i). Is this set a+  superset of the free variables of the kind of (T ty_1 ... ty_n)?++Phew, that was a lot of work!++How can be sure that this is correct? That is, how can we be sure that in the+event that we leave off a kind annotation, that one could infer the kind of the+tycon application from its arguments? It's essentially a proof by induction: if+we can infer the kinds of every subtree of a type, then the whole tycon+application will have an inferrable kind--unless, of course, the remainder of+the tycon application's kind has uninstantiated kind variables.++What happens if T is oversaturated? That is, if T's kind has fewer than n+arguments, in the case that the concrete application instantiates a result+kind variable with an arrow kind? If we run out of arguments, we do not attach+a kind annotation. This should be a rare case, indeed. Here is an example:++   data T1 :: k1 -> k2 -> *+   data T2 :: k1 -> k2 -> *++   type family G (a :: k) :: k+   type instance G T1 = T2++   type instance F Char = (G T1 Bool :: (* -> *) -> *)   -- F from above++Here G's kind is (forall k. k -> k), and the desugared RHS of that last+instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to+the algorithm above, there are 3 arguments to G so we should peel off 3+arguments in G's kind. But G's kind has only two arguments. This is the+rare special case, and we choose not to annotate the application of G with+a kind signature. After all, we needn't do this, since that instance would+be reified as:++   type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool++So the kind of G isn't ambiguous anymore due to the explicit kind annotation+on its argument. See #8953 and test th/T8953.+-}
+ compiler/GHC/Core/Type.hs-boot view
@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleContexts #-}++module GHC.Core.Type where++import GhcPrelude+import GHC.Core.TyCon+import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Coercion )+import Util++isPredTy     :: HasDebugCallStack => Type -> Bool+isCoercionTy :: Type -> Bool++mkAppTy    :: Type -> Type -> Type+mkCastTy   :: Type -> Coercion -> Type+piResultTy :: HasDebugCallStack => Type -> Type -> Type++eqType :: Type -> Type -> Bool++coreView :: Type -> Maybe Type+tcView :: Type -> Maybe Type+isRuntimeRepTy :: Type -> Bool+isLiftedTypeKind :: Type -> Bool++splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])++partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type])
compiler/GHC/Core/Unfold.hs view
@@ -48,25 +48,25 @@  import GHC.Driver.Session import GHC.Core-import OccurAnal          ( occurAnalyseExpr_NoBinderSwap )+import GHC.Core.Op.OccurAnal ( occurAnalyseExpr_NoBinderSwap ) import GHC.Core.SimpleOpt-import GHC.Core.Arity     ( manifestArity )+import GHC.Core.Arity   ( manifestArity ) import GHC.Core.Utils-import Id-import Demand          ( isBottomingSig )-import DataCon-import Literal+import GHC.Types.Id+import GHC.Types.Demand ( isBottomingSig )+import GHC.Core.DataCon+import GHC.Types.Literal import PrimOp-import IdInfo-import BasicTypes       ( Arity, InlineSpec(..), inlinePragmaSpec )-import Type+import GHC.Types.Id.Info+import GHC.Types.Basic  ( Arity, InlineSpec(..), inlinePragmaSpec )+import GHC.Core.Type import PrelNames import TysPrim          ( realWorldStatePrimTy ) import Bag import Util import Outputable-import ForeignCall-import Name+import GHC.Types.ForeignCall+import GHC.Types.Name import ErrUtils  import qualified Data.ByteString as BS@@ -121,7 +121,7 @@                              , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })  mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding--- See Note [Worker-wrapper for INLINABLE functions] in WorkWrap+-- See Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Op.WorkWrap mkWorkerUnfolding dflags work_fn                   (CoreUnfolding { uf_src = src, uf_tmpl = tmpl                                  , uf_is_top = top_lvl })@@ -537,7 +537,7 @@ Note [Do not inline top-level bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The FloatOut pass has gone to some trouble to float out calls to 'error'-and similar friends.  See Note [Bottoming floats] in SetLevels.+and similar friends.  See Note [Bottoming floats] in GHC.Core.Op.SetLevels. Do not re-inline them!  But we *do* still inline if they are very small (the uncondInline stuff). @@ -590,7 +590,7 @@     unconditional-inline thing for *trivial* expressions.      NB: you might think that PostInlineUnconditionally would do this-    but it doesn't fire for top-level things; see SimplUtils+    but it doesn't fire for top-level things; see GHC.Core.Op.Simplify.Utils     Note [Top level and postInlineUnconditionally]  Note [Count coercion arguments in boring contexts]
+ compiler/GHC/Core/Unify.hs view
@@ -0,0 +1,1588 @@+-- (c) The University of Glasgow 2006++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}++module GHC.Core.Unify (+        tcMatchTy, tcMatchTyKi,+        tcMatchTys, tcMatchTyKis,+        tcMatchTyX, tcMatchTysX, tcMatchTyKisX,+        tcMatchTyX_BM, ruleMatchTyKiX,++        -- * Rough matching+        roughMatchTcs, instanceCantMatch,+        typesCantMatch,++        -- Side-effect free unification+        tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis,+        tcUnifyTysFG, tcUnifyTyWithTFs,+        BindFlag(..),+        UnifyResult, UnifyResultM(..),++        -- Matching a type against a lifted type (coercion)+        liftCoMatch+   ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name( Name )+import GHC.Core.Type     hiding ( getTvSubstEnv )+import GHC.Core.Coercion hiding ( getCvSubstEnv )+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.FVs   ( tyCoVarsOfCoList, tyCoFVsOfTypes )+import GHC.Core.TyCo.Subst ( mkTvSubst )+import FV( FV, fvVarSet, fvVarList )+import Util+import Pair+import Outputable+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set++import Control.Monad+import Control.Applicative hiding ( empty )+import qualified Control.Applicative++{-++Unification is much tricker than you might think.++1. The substitution we generate binds the *template type variables*+   which are given to us explicitly.++2. We want to match in the presence of foralls;+        e.g     (forall a. t1) ~ (forall b. t2)++   That is what the RnEnv2 is for; it does the alpha-renaming+   that makes it as if a and b were the same variable.+   Initialising the RnEnv2, so that it can generate a fresh+   binder when necessary, entails knowing the free variables of+   both types.++3. We must be careful not to bind a template type variable to a+   locally bound variable.  E.g.+        (forall a. x) ~ (forall b. b)+   where x is the template type variable.  Then we do not want to+   bind x to a/b!  This is a kind of occurs check.+   The necessary locals accumulate in the RnEnv2.++Note [tcMatchTy vs tcMatchTyKi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This module offers two variants of matching: with kinds and without.+The TyKi variant takes two types, of potentially different kinds,+and matches them. Along the way, it necessarily also matches their+kinds. The Ty variant instead assumes that the kinds are already+eqType and so skips matching up the kinds.++How do you choose between them?++1. If you know that the kinds of the two types are eqType, use+   the Ty variant. It is more efficient, as it does less work.++2. If the kinds of variables in the template type might mention type families,+   use the Ty variant (and do other work to make sure the kinds+   work out). These pure unification functions do a straightforward+   syntactic unification and do no complex reasoning about type+   families. Note that the types of the variables in instances can indeed+   mention type families, so instance lookup must use the Ty variant.++   (Nothing goes terribly wrong -- no panics -- if there might be type+   families in kinds in the TyKi variant. You just might get match+   failure even though a reducing a type family would lead to success.)++3. Otherwise, if you're sure that the variable kinds do not mention+   type families and you're not already sure that the kind of the template+   equals the kind of the target, then use the TyKi version.+-}++-- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1))+-- @s@ such that @s(t1)@ equals @t2@.+-- The returned substitution might bind coercion variables,+-- if the variable is an argument to a GADT constructor.+--+-- Precondition: typeKind ty1 `eqType` typeKind ty2+--+-- We don't pass in a set of "template variables" to be bound+-- by the match, because tcMatchTy (and similar functions) are+-- always used on top-level types, so we can bind any of the+-- free variables of the LHS.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTy :: Type -> Type -> Maybe TCvSubst+tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2]++tcMatchTyX_BM :: (TyVar -> BindFlag) -> TCvSubst+              -> Type -> Type -> Maybe TCvSubst+tcMatchTyX_BM bind_me subst ty1 ty2+  = tc_match_tys_x bind_me False subst [ty1] [ty2]++-- | Like 'tcMatchTy', but allows the kinds of the types to differ,+-- and thus matches them as well.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyKi :: Type -> Type -> Maybe TCvSubst+tcMatchTyKi ty1 ty2+  = tc_match_tys (const BindMe) True [ty1] [ty2]++-- | This is similar to 'tcMatchTy', but extends a substitution+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyX :: TCvSubst            -- ^ Substitution to extend+           -> Type                -- ^ Template+           -> Type                -- ^ Target+           -> Maybe TCvSubst+tcMatchTyX subst ty1 ty2+  = tc_match_tys_x (const BindMe) False subst [ty1] [ty2]++-- | Like 'tcMatchTy' but over a list of types.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTys :: [Type]         -- ^ Template+           -> [Type]         -- ^ Target+           -> Maybe TCvSubst -- ^ One-shot; in principle the template+                             -- variables could be free in the target+tcMatchTys tys1 tys2+  = tc_match_tys (const BindMe) False tys1 tys2++-- | Like 'tcMatchTyKi' but over a list of types.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyKis :: [Type]         -- ^ Template+             -> [Type]         -- ^ Target+             -> Maybe TCvSubst -- ^ One-shot substitution+tcMatchTyKis tys1 tys2+  = tc_match_tys (const BindMe) True tys1 tys2++-- | Like 'tcMatchTys', but extending a substitution+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTysX :: TCvSubst       -- ^ Substitution to extend+            -> [Type]         -- ^ Template+            -> [Type]         -- ^ Target+            -> Maybe TCvSubst -- ^ One-shot substitution+tcMatchTysX subst tys1 tys2+  = tc_match_tys_x (const BindMe) False subst tys1 tys2++-- | Like 'tcMatchTyKis', but extending a substitution+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyKisX :: TCvSubst        -- ^ Substitution to extend+              -> [Type]          -- ^ Template+              -> [Type]          -- ^ Target+              -> Maybe TCvSubst  -- ^ One-shot substitution+tcMatchTyKisX subst tys1 tys2+  = tc_match_tys_x (const BindMe) True subst tys1 tys2++-- | Same as tc_match_tys_x, but starts with an empty substitution+tc_match_tys :: (TyVar -> BindFlag)+               -> Bool          -- ^ match kinds?+               -> [Type]+               -> [Type]+               -> Maybe TCvSubst+tc_match_tys bind_me match_kis tys1 tys2+  = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) tys1 tys2+  where+    in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2)++-- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX'+tc_match_tys_x :: (TyVar -> BindFlag)+               -> Bool          -- ^ match kinds?+               -> TCvSubst+               -> [Type]+               -> [Type]+               -> Maybe TCvSubst+tc_match_tys_x bind_me match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2+  = case tc_unify_tys bind_me+                      False  -- Matching, not unifying+                      False  -- Not an injectivity check+                      match_kis+                      (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of+      Unifiable (tv_env', cv_env')+        -> Just $ TCvSubst in_scope tv_env' cv_env'+      _ -> Nothing++-- | This one is called from the expression matcher,+-- which already has a MatchEnv in hand+ruleMatchTyKiX+  :: TyCoVarSet          -- ^ template variables+  -> RnEnv2+  -> TvSubstEnv          -- ^ type substitution to extend+  -> Type                -- ^ Template+  -> Type                -- ^ Target+  -> Maybe TvSubstEnv+ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target+-- See Note [Kind coercions in Unify]+  = case tc_unify_tys (matchBindFun tmpl_tvs) False False+                      True -- <-- this means to match the kinds+                      rn_env tenv emptyCvSubstEnv [tmpl] [target] of+      Unifiable (tenv', _) -> Just tenv'+      _                    -> Nothing++matchBindFun :: TyCoVarSet -> TyVar -> BindFlag+matchBindFun tvs tv = if tv `elemVarSet` tvs then BindMe else Skolem+++{- *********************************************************************+*                                                                      *+                Rough matching+*                                                                      *+********************************************************************* -}++-- See Note [Rough match] field in GHC.Core.InstEnv++roughMatchTcs :: [Type] -> [Maybe Name]+roughMatchTcs tys = map rough tys+  where+    rough ty+      | Just (ty', _) <- splitCastTy_maybe ty   = rough ty'+      | Just (tc,_)   <- splitTyConApp_maybe ty = Just (tyConName tc)+      | otherwise                               = Nothing++instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool+-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot+-- possibly be instantiated to actual, nor vice versa;+-- False is non-committal+instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as+instanceCantMatch _         _         =  False  -- Safe++itemCantMatch :: Maybe Name -> Maybe Name -> Bool+itemCantMatch (Just t) (Just a) = t /= a+itemCantMatch _        _        = False+++{-+************************************************************************+*                                                                      *+                GADTs+*                                                                      *+************************************************************************++Note [Pruning dead case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider        data T a where+                   T1 :: T Int+                   T2 :: T a++                newtype X = MkX Int+                newtype Y = MkY Char++                type family F a+                type instance F Bool = Int++Now consider    case x of { T1 -> e1; T2 -> e2 }++The question before the house is this: if I know something about the type+of x, can I prune away the T1 alternative?++Suppose x::T Char.  It's impossible to construct a (T Char) using T1,+        Answer = YES we can prune the T1 branch (clearly)++Suppose x::T (F a), where 'a' is in scope.  Then 'a' might be instantiated+to 'Bool', in which case x::T Int, so+        ANSWER = NO (clearly)++We see here that we want precisely the apartness check implemented within+tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely+apart. Note that since we are simply dropping dead code, a conservative test+suffices.+-}++-- | Given a list of pairs of types, are any two members of a pair surely+-- apart, even after arbitrary type function evaluation and substitution?+typesCantMatch :: [(Type,Type)] -> Bool+-- See Note [Pruning dead case alternatives]+typesCantMatch prs = any (uncurry cant_match) prs+  where+    cant_match :: Type -> Type -> Bool+    cant_match t1 t2 = case tcUnifyTysFG (const BindMe) [t1] [t2] of+      SurelyApart -> True+      _           -> False++{-+************************************************************************+*                                                                      *+             Unification+*                                                                      *+************************************************************************++Note [Fine-grained unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" --+no substitution to finite types makes these match. But, a substitution to+*infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ].+Why do we care? Consider these two type family instances:++type instance F x x   = Int+type instance F [y] y = Bool++If we also have++type instance Looper = [Looper]++then the instances potentially overlap. The solution is to use unification+over infinite terms. This is possible (see [1] for lots of gory details), but+a full algorithm is a little more power than we need. Instead, we make a+conservative approximation and just omit the occurs check.++[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf++tcUnifyTys considers an occurs-check problem as the same as general unification+failure.++tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check+failure ("MaybeApart"), or general failure ("SurelyApart").++See also #8162.++It's worth noting that unification in the presence of infinite types is not+complete. This means that, sometimes, a closed type family does not reduce+when it should. See test case indexed-types/should_fail/Overlap15 for an+example.++Note [The substitution in MaybeApart]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why?+Because consider unifying these:++(a, a, Int) ~ (b, [b], Bool)++If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we+apply the subst we have so far and discover that we need [b |-> [b]]. Because+this fails the occurs check, we say that the types are MaybeApart (see above+Note [Fine-grained unification]). But, we can't stop there! Because if we+continue, we discover that Int is SurelyApart from Bool, and therefore the+types are apart. This has practical consequences for the ability for closed+type family applications to reduce. See test case+indexed-types/should_compile/Overlap14.++Note [Unification with skolems]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we discover that two types unify if and only if a skolem variable is+substituted, we can't properly unify the types. But, that skolem variable+may later be instantiated with a unifyable type. So, we return maybeApart+in these cases.+-}++-- | Simple unification of two types; all type variables are bindable+-- Precondition: the kinds are already equal+tcUnifyTy :: Type -> Type       -- All tyvars are bindable+          -> Maybe TCvSubst+                       -- A regular one-shot (idempotent) substitution+tcUnifyTy t1 t2 = tcUnifyTys (const BindMe) [t1] [t2]++-- | Like 'tcUnifyTy', but also unifies the kinds+tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst+tcUnifyTyKi t1 t2 = tcUnifyTyKis (const BindMe) [t1] [t2]++-- | Unify two types, treating type family applications as possibly unifying+-- with anything and looking through injective type family applications.+-- Precondition: kinds are the same+tcUnifyTyWithTFs :: Bool  -- ^ True <=> do two-way unification;+                          --   False <=> do one-way matching.+                          --   See end of sec 5.2 from the paper+                 -> Type -> Type -> Maybe TCvSubst+-- This algorithm is an implementation of the "Algorithm U" presented in+-- the paper "Injective type families for Haskell", Figures 2 and 3.+-- The code is incorporated with the standard unifier for convenience, but+-- its operation should match the specification in the paper.+tcUnifyTyWithTFs twoWay t1 t2+  = case tc_unify_tys (const BindMe) twoWay True False+                       rn_env emptyTvSubstEnv emptyCvSubstEnv+                       [t1] [t2] of+      Unifiable  (subst, _) -> Just $ maybe_fix subst+      MaybeApart (subst, _) -> Just $ maybe_fix subst+      -- we want to *succeed* in questionable cases. This is a+      -- pre-unification algorithm.+      SurelyApart      -> Nothing+  where+    in_scope = mkInScopeSet $ tyCoVarsOfTypes [t1, t2]+    rn_env   = mkRnEnv2 in_scope++    maybe_fix | twoWay    = niFixTCvSubst+              | otherwise = mkTvSubst in_scope -- when matching, don't confuse+                                               -- domain with range++-----------------+tcUnifyTys :: (TyCoVar -> BindFlag)+           -> [Type] -> [Type]+           -> Maybe TCvSubst+                                -- ^ A regular one-shot (idempotent) substitution+                                -- that unifies the erased types. See comments+                                -- for 'tcUnifyTysFG'++-- The two types may have common type variables, and indeed do so in the+-- second call to tcUnifyTys in FunDeps.checkClsFD+tcUnifyTys bind_fn tys1 tys2+  = case tcUnifyTysFG bind_fn tys1 tys2 of+      Unifiable result -> Just result+      _                -> Nothing++-- | Like 'tcUnifyTys' but also unifies the kinds+tcUnifyTyKis :: (TyCoVar -> BindFlag)+             -> [Type] -> [Type]+             -> Maybe TCvSubst+tcUnifyTyKis bind_fn tys1 tys2+  = case tcUnifyTyKisFG bind_fn tys1 tys2 of+      Unifiable result -> Just result+      _                -> Nothing++-- This type does double-duty. It is used in the UM (unifier monad) and to+-- return the final result. See Note [Fine-grained unification]+type UnifyResult = UnifyResultM TCvSubst+data UnifyResultM a = Unifiable a        -- the subst that unifies the types+                    | MaybeApart a       -- the subst has as much as we know+                                         -- it must be part of a most general unifier+                                         -- See Note [The substitution in MaybeApart]+                    | SurelyApart+                    deriving Functor++instance Applicative UnifyResultM where+  pure  = Unifiable+  (<*>) = ap++instance Monad UnifyResultM where++  SurelyApart  >>= _ = SurelyApart+  MaybeApart x >>= f = case f x of+                         Unifiable y -> MaybeApart y+                         other       -> other+  Unifiable x  >>= f = f x++instance Alternative UnifyResultM where+  empty = SurelyApart++  a@(Unifiable {})  <|> _                 = a+  _                 <|> b@(Unifiable {})  = b+  a@(MaybeApart {}) <|> _                 = a+  _                 <|> b@(MaybeApart {}) = b+  SurelyApart       <|> SurelyApart       = SurelyApart++instance MonadPlus UnifyResultM++-- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose+-- domain elements all respond 'BindMe' to @bind_tv@) such that+-- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned+-- Coercions. This version requires that the kinds of the types are the same,+-- if you unify left-to-right.+tcUnifyTysFG :: (TyVar -> BindFlag)+             -> [Type] -> [Type]+             -> UnifyResult+tcUnifyTysFG bind_fn tys1 tys2+  = tc_unify_tys_fg False bind_fn tys1 tys2++tcUnifyTyKisFG :: (TyVar -> BindFlag)+               -> [Type] -> [Type]+               -> UnifyResult+tcUnifyTyKisFG bind_fn tys1 tys2+  = tc_unify_tys_fg True bind_fn tys1 tys2++tc_unify_tys_fg :: Bool+                -> (TyVar -> BindFlag)+                -> [Type] -> [Type]+                -> UnifyResult+tc_unify_tys_fg match_kis bind_fn tys1 tys2+  = do { (env, _) <- tc_unify_tys bind_fn True False match_kis env+                                  emptyTvSubstEnv emptyCvSubstEnv+                                  tys1 tys2+       ; return $ niFixTCvSubst env }+  where+    vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2+    env  = mkRnEnv2 $ mkInScopeSet vars++-- | This function is actually the one to call the unifier -- a little+-- too general for outside clients, though.+tc_unify_tys :: (TyVar -> BindFlag)+             -> AmIUnifying -- ^ True <=> unify; False <=> match+             -> Bool        -- ^ True <=> doing an injectivity check+             -> Bool        -- ^ True <=> treat the kinds as well+             -> RnEnv2+             -> TvSubstEnv  -- ^ substitution to extend+             -> CvSubstEnv+             -> [Type] -> [Type]+             -> UnifyResultM (TvSubstEnv, CvSubstEnv)+-- NB: It's tempting to ASSERT here that, if we're not matching kinds, then+-- the kinds of the types should be the same. However, this doesn't work,+-- as the types may be a dependent telescope, where later types have kinds+-- that mention variables occurring earlier in the list of types. Here's an+-- example (from typecheck/should_fail/T12709):+--   template: [rep :: RuntimeRep,       a :: TYPE rep]+--   target:   [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep]+-- We can see that matching the first pair will make the kinds of the second+-- pair equal. Yet, we still don't need a separate pass to unify the kinds+-- of these types, so it's appropriate to use the Ty variant of unification.+-- See also Note [tcMatchTy vs tcMatchTyKi].+tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2+  = initUM tv_env cv_env $+    do { when match_kis $+         unify_tys env kis1 kis2+       ; unify_tys env tys1 tys2+       ; (,) <$> getTvSubstEnv <*> getCvSubstEnv }+  where+    env = UMEnv { um_bind_fun = bind_fn+                , um_skols    = emptyVarSet+                , um_unif     = unif+                , um_inj_tf   = inj_check+                , um_rn_env   = rn_env }++    kis1 = map typeKind tys1+    kis2 = map typeKind tys2++instance Outputable a => Outputable (UnifyResultM a) where+  ppr SurelyApart    = text "SurelyApart"+  ppr (Unifiable x)  = text "Unifiable" <+> ppr x+  ppr (MaybeApart x) = text "MaybeApart" <+> ppr x++{-+************************************************************************+*                                                                      *+                Non-idempotent substitution+*                                                                      *+************************************************************************++Note [Non-idempotent substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During unification we use a TvSubstEnv/CvSubstEnv pair that is+  (a) non-idempotent+  (b) loop-free; ie repeatedly applying it yields a fixed point++Note [Finding the substitution fixpoint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Finding the fixpoint of a non-idempotent substitution arising from a+unification is much trickier than it looks, because of kinds.  Consider+   T k (H k (f:k)) ~ T * (g:*)+If we unify, we get the substitution+   [ k -> *+   , g -> H k (f:k) ]+To make it idempotent we don't want to get just+   [ k -> *+   , g -> H * (f:k) ]+We also want to substitute inside f's kind, to get+   [ k -> *+   , g -> H k (f:*) ]+If we don't do this, we may apply the substitution to something,+and get an ill-formed type, i.e. one where typeKind will fail.+This happened, for example, in #9106.++It gets worse.  In #14164 we wanted to take the fixpoint of+this substitution+   [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6)+                        (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6))+   , a_aY6  :-> a_aXQ ]++We have to apply the substitution for a_aY6 two levels deep inside+the invocation of F!  We don't have a function that recursively+applies substitutions inside the kinds of variable occurrences (and+probably rightly so).++So, we work as follows:++ 1. Start with the current substitution (which we are+    trying to fixpoint+       [ xs :-> F a (z :: a) (rest :: G a (z :: a))+       , a  :-> b ]++ 2. Take all the free vars of the range of the substitution:+       {a, z, rest, b}+    NB: the free variable finder closes over+    the kinds of variable occurrences++ 3. If none are in the domain of the substitution, stop.+    We have found a fixpoint.++ 4. Remove the variables that are bound by the substitution, leaving+       {z, rest, b}++ 5. Do a topo-sort to put them in dependency order:+       [ b :: *, z :: a, rest :: G a z ]++ 6. Apply the substitution left-to-right to the kinds of these+    tyvars, extending it each time with a new binding, so we+    finish up with+       [ xs   :-> ..as before..+       , a    :-> b+       , b    :-> b    :: *+       , z    :-> z    :: b+       , rest :-> rest :: G b (z :: b) ]+    Note that rest now has the right kind++ 7. Apply this extended substitution (once) to the range of+    the /original/ substitution.  (Note that we do the+    extended substitution would go on forever if you tried+    to find its fixpoint, because it maps z to z.)++ 8. And go back to step 1++In Step 6 we use the free vars from Step 2 as the initial+in-scope set, because all of those variables appear in the+range of the substitution, so they must all be in the in-scope+set.  But NB that the type substitution engine does not look up+variables in the in-scope set; it is used only to ensure no+shadowing.+-}++niFixTCvSubst :: TvSubstEnv -> TCvSubst+-- Find the idempotent fixed point of the non-idempotent substitution+-- This is surprisingly tricky:+--   see Note [Finding the substitution fixpoint]+-- ToDo: use laziness instead of iteration?+niFixTCvSubst tenv+  | not_fixpoint = niFixTCvSubst (mapVarEnv (substTy subst) tenv)+  | otherwise    = subst+  where+    range_fvs :: FV+    range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv)+          -- It's OK to use nonDetEltsUFM here because the+          -- order of range_fvs, range_tvs is immaterial++    range_tvs :: [TyVar]+    range_tvs = fvVarList range_fvs++    not_fixpoint  = any in_domain range_tvs+    in_domain tv  = tv `elemVarEnv` tenv++    free_tvs = scopedSort (filterOut in_domain range_tvs)++    -- See Note [Finding the substitution fixpoint], Step 6+    init_in_scope = mkInScopeSet (fvVarSet range_fvs)+    subst = foldl' add_free_tv+                  (mkTvSubst init_in_scope tenv)+                  free_tvs++    add_free_tv :: TCvSubst -> TyVar -> TCvSubst+    add_free_tv subst tv+      = extendTvSubst subst tv (mkTyVarTy tv')+     where+        tv' = updateTyVarKind (substTy subst) tv++niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet+-- Apply the non-idempotent substitution to a set of type variables,+-- remembering that the substitution isn't necessarily idempotent+-- This is used in the occurs check, before extending the substitution+niSubstTvSet tsubst tvs+  = nonDetFoldUniqSet (unionVarSet . get) emptyVarSet tvs+  -- It's OK to nonDetFoldUFM here because we immediately forget the+  -- ordering by creating a set.+  where+    get tv+      | Just ty <- lookupVarEnv tsubst tv+      = niSubstTvSet tsubst (tyCoVarsOfType ty)++      | otherwise+      = unitVarSet tv++{-+************************************************************************+*                                                                      *+                unify_ty: the main workhorse+*                                                                      *+************************************************************************++Note [Specification of unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The pure unifier, unify_ty, defined in this module, tries to work out+a substitution to make two types say True to eqType. NB: eqType is+itself not purely syntactic; it accounts for CastTys;+see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep++Unlike the "impure unifiers" in the typechecker (the eager unifier in+TcUnify, and the constraint solver itself in TcCanonical), the pure+unifier It does /not/ work up to ~.++The algorithm implemented here is rather delicate, and we depend on it+to uphold certain properties. This is a summary of these required+properties. Any reference to "flattening" refers to the flattening+algorithm in GHC.Core.FamInstEnv (See Note [Flattening] in GHC.Core.FamInstEnv), not+the flattening algorithm in the solver.++Notation:+ θ,φ    substitutions+ ξ    type-function-free types+ τ,σ  other types+ τ♭   type τ, flattened++ ≡    eqType++(U1) Soundness.+     If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂).+     θ is a most general unifier for τ₁ and τ₂.++(U2) Completeness.+     If (unify ξ₁ ξ₂) = SurelyApart,+     then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂).++These two properties are stated as Property 11 in the "Closed Type Families"+paper (POPL'14). Below, this paper is called [CTF].++(U3) Apartness under substitution.+     If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart,+     for any θ. (Property 12 from [CTF])++(U4) Apart types do not unify.+     If (unify ξ τ♭) = SurelyApart, then there exists no θ+     such that θ(ξ) = θ(τ). (Property 13 from [CTF])++THEOREM. Completeness w.r.t ~+    If (unify τ₁♭ τ₂♭) = SurelyApart,+    then there exists no proof that (τ₁ ~ τ₂).++PROOF. See appendix of [CTF].+++The unification algorithm is used for type family injectivity, as described+in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run+in this mode, it has the following properties.++(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even+     after arbitrary type family reductions. Note that σ and τ are+     not flattened here.++(I2) If (unify σ τ) = MaybeApart θ, and if some+     φ exists such that φ(σ) ~ φ(τ), then φ extends θ.+++Furthermore, the RULES matching algorithm requires this property,+but only when using this algorithm for matching:++(M1) If (match σ τ) succeeds with θ, then all matchable tyvars+     in σ are bound in θ.++     Property M1 means that we must extend the substitution with,+     say (a ↦ a) when appropriate during matching.+     See also Note [Self-substitution when matching].++(M2) Completeness of matching.+     If θ(σ) = τ, then (match σ τ) = Unifiable φ,+     where θ is an extension of φ.++Sadly, property M2 and I2 conflict. Consider++type family F1 a b where+  F1 Int    Bool   = Char+  F1 Double String = Char++Consider now two matching problems:++P1. match (F1 a Bool) (F1 Int Bool)+P2. match (F1 a Bool) (F1 Double String)++In case P1, we must find (a ↦ Int) to satisfy M2.+In case P2, we must /not/ find (a ↦ Double), in order to satisfy I2. (Note+that the correct mapping for I2 is (a ↦ Int). There is no way to discover+this, but we mustn't map a to anything else!)++We thus must parameterize the algorithm over whether it's being used+for an injectivity check (refrain from looking at non-injective arguments+to type families) or not (do indeed look at those arguments).  This is+implemented  by the uf_inj_tf field of UmEnv.++(It's all a question of whether or not to include equation (7) from Fig. 2+of [ITF].)++This extra parameter is a bit fiddly, perhaps, but seemingly less so than+having two separate, almost-identical algorithms.++Note [Self-substitution when matching]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What should happen when we're *matching* (not unifying) a1 with a1? We+should get a substitution [a1 |-> a1]. A successful match should map all+the template variables (except ones that disappear when expanding synonyms).+But when unifying, we don't want to do this, because we'll then fall into+a loop.++This arrangement affects the code in three places:+ - If we're matching a refined template variable, don't recur. Instead, just+   check for equality. That is, if we know [a |-> Maybe a] and are matching+   (a ~? Maybe Int), we want to just fail.++ - Skip the occurs check when matching. This comes up in two places, because+   matching against variables is handled separately from matching against+   full-on types.++Note that this arrangement was provoked by a real failure, where the same+unique ended up in the template as in the target. (It was a rule firing when+compiling Data.List.NonEmpty.)++Note [Matching coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++   type family F a++   data G a where+     MkG :: F a ~ Bool => G a++   type family Foo (x :: G a) :: F a+   type instance Foo MkG = False++We would like that to be accepted. For that to work, we need to introduce+a coercion variable on the left and then use it on the right. Accordingly,+at use sites of Foo, we need to be able to use matching to figure out the+value for the coercion. (See the desugared version:++   axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c)++) We never want this action to happen during *unification* though, when+all bets are off.++Note [Kind coercions in Unify]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We wish to match/unify while ignoring casts. But, we can't just ignore+them completely, or we'll end up with ill-kinded substitutions. For example,+say we're matching `a` with `ty |> co`. If we just drop the cast, we'll+return [a |-> ty], but `a` and `ty` might have different kinds. We can't+just match/unify their kinds, either, because this might gratuitously+fail. After all, `co` is the witness that the kinds are the same -- they+may look nothing alike.++So, we pass a kind coercion to the match/unify worker. This coercion witnesses+the equality between the substed kind of the left-hand type and the substed+kind of the right-hand type. Note that we do not unify kinds at the leaves+(as we did previously). We thus have++INVARIANT: In the call+    unify_ty ty1 ty2 kco+it must be that subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)), where+`subst` is the ambient substitution in the UM monad.++To get this coercion, we first have to match/unify+the kinds before looking at the types. Happily, we need look only one level+up, as all kinds are guaranteed to have kind *.++When we're working with type applications (either TyConApp or AppTy) we+need to worry about establishing INVARIANT, as the kinds of the function+& arguments aren't (necessarily) included in the kind of the result.+When unifying two TyConApps, this is easy, because the two TyCons are+the same. Their kinds are thus the same. As long as we unify left-to-right,+we'll be sure to unify types' kinds before the types themselves. (For example,+think about Proxy :: forall k. k -> *. Unifying the first args matches up+the kinds of the second args.)++For AppTy, we must unify the kinds of the functions, but once these are+unified, we can continue unifying arguments without worrying further about+kinds.++The interface to this module includes both "...Ty" functions and+"...TyKi" functions. The former assume that INVARIANT is already+established, either because the kinds are the same or because the+list of types being passed in are the well-typed arguments to some+type constructor (see two paragraphs above). The latter take a separate+pre-pass over the kinds to establish INVARIANT. Sometimes, it's important+not to take the second pass, as it caused #12442.++We thought, at one point, that this was all unnecessary: why should+casts be in types in the first place? But they are sometimes. In+dependent/should_compile/KindEqualities2, we see, for example the+constraint Num (Int |> (blah ; sym blah)).  We naturally want to find+a dictionary for that constraint, which requires dealing with+coercions in this manner.++Note [Matching in the presence of casts (1)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When matching, it is crucial that no variables from the template+end up in the range of the matching substitution (obviously!).+When unifying, that's not a constraint; instead we take the fixpoint+of the substitution at the end.++So what should we do with this, when matching?+   unify_ty (tmpl |> co) tgt kco++Previously, wrongly, we pushed 'co' in the (horrid) accumulating+'kco' argument like this:+   unify_ty (tmpl |> co) tgt kco+     = unify_ty tmpl tgt (kco ; co)++But that is obviously wrong because 'co' (from the template) ends+up in 'kco', which in turn ends up in the range of the substitution.++This all came up in #13910.  Because we match tycon arguments+left-to-right, the ambient substitution will already have a matching+substitution for any kinds; so there is an easy fix: just apply+the substitution-so-far to the coercion from the LHS.++Note that++* When matching, the first arg of unify_ty is always the template;+  we never swap round.++* The above argument is distressingly indirect. We seek a+  better way.++* One better way is to ensure that type patterns (the template+  in the matching process) have no casts.  See #14119.++Note [Matching in the presence of casts (2)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is another wrinkle (#17395).  Suppose (T :: forall k. k -> Type)+and we are matching+   tcMatchTy (T k (a::k))  (T j (b::j))++Then we'll match k :-> j, as expected. But then in unify_tys+we invoke+   unify_tys env (a::k) (b::j) (Refl j)++Although we have unified k and j, it's very important that we put+(Refl j), /not/ (Refl k) as the fourth argument to unify_tys.+If we put (Refl k) we'd end up with the substitution+  a :-> b |> Refl k+which is bogus because one of the template variables, k,+appears in the range of the substitution.  Eek.++Similar care is needed in unify_ty_app.+++Note [Polykinded tycon applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose  T :: forall k. Type -> K+and we are unifying+  ty1:  T @Type         Int       :: Type+  ty2:  T @(Type->Type) Int Int   :: Type++These two TyConApps have the same TyCon at the front but they+(legitimately) have different numbers of arguments.  They+are surelyApart, so we can report that without looking any+further (see #15704).+-}++-------------- unify_ty: the main workhorse -----------++type AmIUnifying = Bool   -- True  <=> Unifying+                          -- False <=> Matching++unify_ty :: UMEnv+         -> Type -> Type  -- Types to be unified and a co+         -> CoercionN     -- A coercion between their kinds+                          -- See Note [Kind coercions in Unify]+         -> UM ()+-- See Note [Specification of unification]+-- Respects newtypes, PredTypes++unify_ty env ty1 ty2 kco+    -- TODO: More commentary needed here+  | Just ty1' <- tcView ty1   = unify_ty env ty1' ty2 kco+  | Just ty2' <- tcView ty2   = unify_ty env ty1 ty2' kco+  | CastTy ty1' co <- ty1     = if um_unif env+                                then unify_ty env ty1' ty2 (co `mkTransCo` kco)+                                else -- See Note [Matching in the presence of casts (1)]+                                     do { subst <- getSubst env+                                        ; let co' = substCo subst co+                                        ; unify_ty env ty1' ty2 (co' `mkTransCo` kco) }+  | CastTy ty2' co <- ty2     = unify_ty env ty1 ty2' (kco `mkTransCo` mkSymCo co)++unify_ty env (TyVarTy tv1) ty2 kco+  = uVar env tv1 ty2 kco+unify_ty env ty1 (TyVarTy tv2) kco+  | um_unif env  -- If unifying, can swap args+  = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco)++unify_ty env ty1 ty2 _kco+  | Just (tc1, tys1) <- mb_tc_app1+  , Just (tc2, tys2) <- mb_tc_app2+  , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2)+  = if isInjectiveTyCon tc1 Nominal+    then unify_tys env tys1 tys2+    else do { let inj | isTypeFamilyTyCon tc1+                      = case tyConInjectivityInfo tc1 of+                               NotInjective -> repeat False+                               Injective bs -> bs+                      | otherwise+                      = repeat False++                  (inj_tys1, noninj_tys1) = partitionByList inj tys1+                  (inj_tys2, noninj_tys2) = partitionByList inj tys2++            ; unify_tys env inj_tys1 inj_tys2+            ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]+              don'tBeSoSure $ unify_tys env noninj_tys1 noninj_tys2 }++  | Just (tc1, _) <- mb_tc_app1+  , not (isGenerativeTyCon tc1 Nominal)+    -- E.g.   unify_ty (F ty1) b  =  MaybeApart+    --        because the (F ty1) behaves like a variable+    --        NB: if unifying, we have already dealt+    --            with the 'ty2 = variable' case+  = maybeApart++  | Just (tc2, _) <- mb_tc_app2+  , not (isGenerativeTyCon tc2 Nominal)+  , um_unif env+    -- E.g.   unify_ty [a] (F ty2) =  MaybeApart, when unifying (only)+    --        because the (F ty2) behaves like a variable+    --        NB: we have already dealt with the 'ty1 = variable' case+  = maybeApart++  where+    mb_tc_app1 = tcSplitTyConApp_maybe ty1+    mb_tc_app2 = tcSplitTyConApp_maybe ty2++        -- Applications need a bit of care!+        -- They can match FunTy and TyConApp, so use splitAppTy_maybe+        -- NB: we've already dealt with type variables,+        -- so if one type is an App the other one jolly well better be too+unify_ty env (AppTy ty1a ty1b) ty2 _kco+  | Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2+  = unify_ty_app env ty1a [ty1b] ty2a [ty2b]++unify_ty env ty1 (AppTy ty2a ty2b) _kco+  | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1+  = unify_ty_app env ty1a [ty1b] ty2a [ty2b]++unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return ()++unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco+  = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind)+       ; let env' = umRnBndr2 env tv1 tv2+       ; unify_ty env' ty1 ty2 kco }++-- See Note [Matching coercion variables]+unify_ty env (CoercionTy co1) (CoercionTy co2) kco+  = do { c_subst <- getCvSubstEnv+       ; case co1 of+           CoVarCo cv+             | not (um_unif env)+             , not (cv `elemVarEnv` c_subst)+             , BindMe <- tvBindFlag env cv+             -> do { checkRnEnv env (tyCoVarsOfCo co2)+                   ; let (co_l, co_r) = decomposeFunCo Nominal kco+                      -- cv :: t1 ~ t2+                      -- co2 :: s1 ~ s2+                      -- co_l :: t1 ~ s1+                      -- co_r :: t2 ~ s2+                   ; extendCvEnv cv (co_l `mkTransCo`+                                     co2 `mkTransCo`+                                     mkSymCo co_r) }+           _ -> return () }++unify_ty _ _ _ _ = surelyApart++unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM ()+unify_ty_app env ty1 ty1args ty2 ty2args+  | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1+  , Just (ty2', ty2a) <- repSplitAppTy_maybe ty2+  = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args)++  | otherwise+  = do { let ki1 = typeKind ty1+             ki2 = typeKind ty2+           -- See Note [Kind coercions in Unify]+       ; unify_ty  env ki1 ki2 (mkNomReflCo liftedTypeKind)+       ; unify_ty  env ty1 ty2 (mkNomReflCo ki2)+                 -- Very important: 'ki2' not 'ki1'+                 -- See Note [Matching in the presence of casts (2)]+       ; unify_tys env ty1args ty2args }++unify_tys :: UMEnv -> [Type] -> [Type] -> UM ()+unify_tys env orig_xs orig_ys+  = go orig_xs orig_ys+  where+    go []     []     = return ()+    go (x:xs) (y:ys)+      -- See Note [Kind coercions in Unify]+      = do { unify_ty env x y (mkNomReflCo $ typeKind y)+                 -- Very important: 'y' not 'x'+                 -- See Note [Matching in the presence of casts (2)]+           ; go xs ys }+    go _ _ = surelyApart+      -- Possibly different saturations of a polykinded tycon+      -- See Note [Polykinded tycon applications]++---------------------------------+uVar :: UMEnv+     -> InTyVar         -- Variable to be unified+     -> Type            -- with this Type+     -> Coercion        -- :: kind tv ~N kind ty+     -> UM ()++uVar env tv1 ty kco+ = do { -- Apply the ambient renaming+        let tv1' = umRnOccL env tv1++        -- Check to see whether tv1 is refined by the substitution+      ; subst <- getTvSubstEnv+      ; case (lookupVarEnv subst tv1') of+          Just ty' | um_unif env                -- Unifying, so call+                   -> unify_ty env ty' ty kco   -- back into unify+                   | otherwise+                   -> -- Matching, we don't want to just recur here.+                      -- this is because the range of the subst is the target+                      -- type, not the template type. So, just check for+                      -- normal type equality.+                      guard ((ty' `mkCastTy` kco) `eqType` ty)+          Nothing  -> uUnrefined env tv1' ty ty kco } -- No, continue++uUnrefined :: UMEnv+           -> OutTyVar          -- variable to be unified+           -> Type              -- with this Type+           -> Type              -- (version w/ expanded synonyms)+           -> Coercion          -- :: kind tv ~N kind ty+           -> UM ()++-- We know that tv1 isn't refined++uUnrefined env tv1' ty2 ty2' kco+  | Just ty2'' <- coreView ty2'+  = uUnrefined env tv1' ty2 ty2'' kco    -- Unwrap synonyms+                -- This is essential, in case we have+                --      type Foo a = a+                -- and then unify a ~ Foo a++  | TyVarTy tv2 <- ty2'+  = do { let tv2' = umRnOccR env tv2+       ; unless (tv1' == tv2' && um_unif env) $ do+           -- If we are unifying a ~ a, just return immediately+           -- Do not extend the substitution+           -- See Note [Self-substitution when matching]++          -- Check to see whether tv2 is refined+       { subst <- getTvSubstEnv+       ; case lookupVarEnv subst tv2 of+         {  Just ty' | um_unif env -> uUnrefined env tv1' ty' ty' kco+         ;  _ ->++    do {   -- So both are unrefined+           -- Bind one or the other, depending on which is bindable+       ; let b1  = tvBindFlag env tv1'+             b2  = tvBindFlag env tv2'+             ty1 = mkTyVarTy tv1'+       ; case (b1, b2) of+           (BindMe, _) -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco)+           (_, BindMe) | um_unif env+                       -> bindTv (umSwapRn env) tv2 (ty1 `mkCastTy` kco)++           _ | tv1' == tv2' -> return ()+             -- How could this happen? If we're only matching and if+             -- we're comparing forall-bound variables.++           _ -> maybeApart -- See Note [Unification with skolems]+  }}}}++uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable+  = case tvBindFlag env tv1' of+      Skolem -> maybeApart  -- See Note [Unification with skolems]+      BindMe -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco)++bindTv :: UMEnv -> OutTyVar -> Type -> UM ()+-- OK, so we want to extend the substitution with tv := ty+-- But first, we must do a couple of checks+bindTv env tv1 ty2+  = do  { let free_tvs2 = tyCoVarsOfType ty2++        -- Make sure tys mentions no local variables+        -- E.g.  (forall a. b) ~ (forall a. [a])+        -- We should not unify b := [a]!+        ; checkRnEnv env free_tvs2++        -- Occurs check, see Note [Fine-grained unification]+        -- Make sure you include 'kco' (which ty2 does) #14846+        ; occurs <- occursCheck env tv1 free_tvs2++        ; if occurs then maybeApart+                    else extendTvEnv tv1 ty2 }++occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool+occursCheck env tv free_tvs+  | um_unif env+  = do { tsubst <- getTvSubstEnv+       ; return (tv `elemVarSet` niSubstTvSet tsubst free_tvs) }++  | otherwise      -- Matching; no occurs check+  = return False   -- See Note [Self-substitution when matching]++{-+%************************************************************************+%*                                                                      *+                Binding decisions+*                                                                      *+************************************************************************+-}++data BindFlag+  = BindMe      -- A regular type variable++  | Skolem      -- This type variable is a skolem constant+                -- Don't bind it; it only matches itself+  deriving Eq++{-+************************************************************************+*                                                                      *+                Unification monad+*                                                                      *+************************************************************************+-}++data UMEnv+  = UMEnv { um_unif :: AmIUnifying++          , um_inj_tf :: Bool+            -- Checking for injectivity?+            -- See (end of) Note [Specification of unification]++          , um_rn_env :: RnEnv2+            -- Renaming InTyVars to OutTyVars; this eliminates+            -- shadowing, and lines up matching foralls on the left+            -- and right++          , um_skols :: TyVarSet+            -- OutTyVars bound by a forall in this unification;+            -- Do not bind these in the substitution!+            -- See the function tvBindFlag++          , um_bind_fun :: TyVar -> BindFlag+            -- User-supplied BindFlag function,+            -- for variables not in um_skols+          }++data UMState = UMState+                   { um_tv_env   :: TvSubstEnv+                   , um_cv_env   :: CvSubstEnv }++newtype UM a = UM { unUM :: UMState -> UnifyResultM (UMState, a) }+    deriving (Functor)++instance Applicative UM where+      pure a = UM (\s -> pure (s, a))+      (<*>)  = ap++instance Monad UM where+  m >>= k  = UM (\state ->+                  do { (state', v) <- unUM m state+                     ; unUM (k v) state' })++-- need this instance because of a use of 'guard' above+instance Alternative UM where+  empty     = UM (\_ -> Control.Applicative.empty)+  m1 <|> m2 = UM (\state ->+                  unUM m1 state <|>+                  unUM m2 state)++instance MonadPlus UM++instance MonadFail UM where+    fail _   = UM (\_ -> SurelyApart) -- failed pattern match++initUM :: TvSubstEnv  -- subst to extend+       -> CvSubstEnv+       -> UM a -> UnifyResultM a+initUM subst_env cv_subst_env um+  = case unUM um state of+      Unifiable (_, subst)  -> Unifiable subst+      MaybeApart (_, subst) -> MaybeApart subst+      SurelyApart           -> SurelyApart+  where+    state = UMState { um_tv_env = subst_env+                    , um_cv_env = cv_subst_env }++tvBindFlag :: UMEnv -> OutTyVar -> BindFlag+tvBindFlag env tv+  | tv `elemVarSet` um_skols env = Skolem+  | otherwise                    = um_bind_fun env tv++getTvSubstEnv :: UM TvSubstEnv+getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state)++getCvSubstEnv :: UM CvSubstEnv+getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state)++getSubst :: UMEnv -> UM TCvSubst+getSubst env = do { tv_env <- getTvSubstEnv+                  ; cv_env <- getCvSubstEnv+                  ; let in_scope = rnInScopeSet (um_rn_env env)+                  ; return (mkTCvSubst in_scope (tv_env, cv_env)) }++extendTvEnv :: TyVar -> Type -> UM ()+extendTvEnv tv ty = UM $ \state ->+  Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ())++extendCvEnv :: CoVar -> Coercion -> UM ()+extendCvEnv cv co = UM $ \state ->+  Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ())++umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv+umRnBndr2 env v1 v2+  = env { um_rn_env = rn_env', um_skols = um_skols env `extendVarSet` v' }+  where+    (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2++checkRnEnv :: UMEnv -> VarSet -> UM ()+checkRnEnv env varset+  | isEmptyVarSet skol_vars           = return ()+  | varset `disjointVarSet` skol_vars = return ()+  | otherwise                         = maybeApart+               -- ToDo: why MaybeApart?+               -- I think SurelyApart would be right+  where+    skol_vars = um_skols env+    -- NB: That isEmptyVarSet guard is a critical optimization;+    -- it means we don't have to calculate the free vars of+    -- the type, often saving quite a bit of allocation.++-- | Converts any SurelyApart to a MaybeApart+don'tBeSoSure :: UM () -> UM ()+don'tBeSoSure um = UM $ \ state ->+  case unUM um state of+    SurelyApart -> MaybeApart (state, ())+    other       -> other++umRnOccL :: UMEnv -> TyVar -> TyVar+umRnOccL env v = rnOccL (um_rn_env env) v++umRnOccR :: UMEnv -> TyVar -> TyVar+umRnOccR env v = rnOccR (um_rn_env env) v++umSwapRn :: UMEnv -> UMEnv+umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) }++maybeApart :: UM ()+maybeApart = UM (\state -> MaybeApart (state, ()))++surelyApart :: UM a+surelyApart = UM (\_ -> SurelyApart)++{-+%************************************************************************+%*                                                                      *+            Matching a (lifted) type against a coercion+%*                                                                      *+%************************************************************************++This section defines essentially an inverse to liftCoSubst. It is defined+here to avoid a dependency from Coercion on this module.++-}++data MatchEnv = ME { me_tmpls :: TyVarSet+                   , me_env   :: RnEnv2 }++-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'.  In particular, if+--   @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@,+--   where @==@ there means that the result of 'liftCoSubst' has the same+--   type as the original co; but may be different under the hood.+--   That is, it matches a type against a coercion of the same+--   "shape", and returns a lifting substitution which could have been+--   used to produce the given coercion from the given type.+--   Note that this function is incomplete -- it might return Nothing+--   when there does indeed exist a possible lifting context.+--+-- This function is incomplete in that it doesn't respect the equality+-- in `eqType`. That is, it's possible that this will succeed for t1 and+-- fail for t2, even when t1 `eqType` t2. That's because it depends on+-- there being a very similar structure between the type and the coercion.+-- This incompleteness shouldn't be all that surprising, especially because+-- it depends on the structure of the coercion, which is a silly thing to do.+--+-- The lifting context produced doesn't have to be exacting in the roles+-- of the mappings. This is because any use of the lifting context will+-- also require a desired role. Thus, this algorithm prefers mapping to+-- nominal coercions where it can do so.+liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext+liftCoMatch tmpls ty co+  = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co+       ; cenv2 <- ty_co_match menv cenv1       ty co+                              (mkNomReflCo co_lkind) (mkNomReflCo co_rkind)+       ; return (LC (mkEmptyTCvSubst in_scope) cenv2) }+  where+    menv     = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope }+    in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co)+    -- Like tcMatchTy, assume all the interesting variables+    -- in ty are in tmpls++    ki       = typeKind ty+    ki_co    = promoteCoercion co+    ki_ki_co = mkNomReflCo liftedTypeKind++    Pair co_lkind co_rkind = coercionKind ki_co++-- | 'ty_co_match' does all the actual work for 'liftCoMatch'.+ty_co_match :: MatchEnv   -- ^ ambient helpful info+            -> LiftCoEnv  -- ^ incoming subst+            -> Type       -- ^ ty, type to match+            -> Coercion   -- ^ co, coercion to match against+            -> Coercion   -- ^ :: kind of L type of substed ty ~N L kind of co+            -> Coercion   -- ^ :: kind of R type of substed ty ~N R kind of co+            -> Maybe LiftCoEnv+ty_co_match menv subst ty co lkco rkco+  | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco++  -- handle Refl case:+  | tyCoVarsOfType ty `isNotInDomainOf` subst+  , Just (ty', _) <- isReflCo_maybe co+  , ty `eqType` ty'+  = Just subst++  where+    isNotInDomainOf :: VarSet -> VarEnv a -> Bool+    isNotInDomainOf set env+      = noneSet (\v -> elemVarEnv v env) set++    noneSet :: (Var -> Bool) -> VarSet -> Bool+    noneSet f = allVarSet (not . f)++ty_co_match menv subst ty co lkco rkco+  | CastTy ty' co' <- ty+     -- See Note [Matching in the presence of casts (1)]+  = let empty_subst  = mkEmptyTCvSubst (rnInScopeSet (me_env menv))+        substed_co_l = substCo (liftEnvSubstLeft empty_subst subst)  co'+        substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co'+    in+    ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco)+                                  (substed_co_r `mkTransCo` rkco)++  | SymCo co' <- co+  = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco++  -- Match a type variable against a non-refl coercion+ty_co_match menv subst (TyVarTy tv1) co lkco rkco+  | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1+  = if eqCoercionX (nukeRnEnvL rn_env) co1' co+    then Just subst+    else Nothing       -- no match since tv1 matches two different coercions++  | tv1' `elemVarSet` me_tmpls menv           -- tv1' is a template var+  = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co)+    then Nothing      -- occurs check failed+    else Just $ extendVarEnv subst tv1' $+                castCoercionKindI co (mkSymCo lkco) (mkSymCo rkco)++  | otherwise+  = Nothing++  where+    rn_env = me_env menv+    tv1' = rnOccL rn_env tv1++  -- just look through SubCo's. We don't really care about roles here.+ty_co_match menv subst ty (SubCo co) lkco rkco+  = ty_co_match menv subst ty co lkco rkco++ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco+  | Just (co2, arg2) <- splitAppCo_maybe co     -- c.f. Unify.match on AppTy+  = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2]+ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco+  | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1+       -- yes, the one from Type, not TcType; this is for coercion optimization+  = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2]++ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco+  = ty_co_match_tc menv subst tc1 tys tc2 cos+ty_co_match menv subst (FunTy _ ty1 ty2) co _lkco _rkco+    -- Despite the fact that (->) is polymorphic in four type variables (two+    -- runtime rep and two types), we shouldn't need to explicitly unify the+    -- runtime reps here; unifying the types themselves should be sufficient.+    -- See Note [Representation of function types].+  | Just (tc, [_,_,co1,co2]) <- splitTyConAppCo_maybe co+  , tc == funTyCon+  = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co1,co2]+    in ty_co_match_args menv subst [ty1, ty2] [co1, co2] lkcos rkcos++ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1)+                       (ForAllCo tv2 kind_co2 co2)+                       lkco rkco+  | isTyVar tv1 && isTyVar tv2+  = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2+                               ki_ki_co ki_ki_co+       ; let rn_env0 = me_env menv+             rn_env1 = rnBndr2 rn_env0 tv1 tv2+             menv'   = menv { me_env = rn_env1 }+       ; ty_co_match menv' subst1 ty1 co2 lkco rkco }+  where+    ki_ki_co = mkNomReflCo liftedTypeKind++-- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1)+--                        (ForAllCo cv2 kind_co2 co2)+--                        lkco rkco+--   | isCoVar cv1 && isCoVar cv2+--   We seems not to have enough information for this case+--   1. Given:+--        cv1      :: (s1 :: k1) ~r (s2 :: k2)+--        kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2)+--        eta1      = mkNthCo role 2 (downgradeRole r Nominal kind_co2)+--                 :: s1' ~ t1+--        eta2      = mkNthCo role 3 (downgradeRole r Nominal kind_co2)+--                 :: s2' ~ t2+--      Wanted:+--        subst1 <- ty_co_match menv subst  s1 eta1 kco1 kco2+--        subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4+--      Question: How do we get kcoi?+--   2. Given:+--        lkco :: <*>    -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep+--        rkco :: <*>+--      Wanted:+--        ty_co_match menv' subst2 ty1 co2 lkco' rkco'+--      Question: How do we get lkco' and rkco'?++ty_co_match _ subst (CoercionTy {}) _ _ _+  = Just subst -- don't inspect coercions++ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco+  =  ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co)++ty_co_match menv subst ty co1 lkco rkco+  | Just (CastTy t co, r) <- isReflCo_maybe co1+  -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us+  -- t |> co ~ t ; <t> ; t ~ t |> co+  -- But transitive coercions are not helpful. Therefore we deal+  -- with it here: we do recursion on the smaller reflexive coercion,+  -- while propagating the correct kind coercions.+  = let kco' = mkSymCo co+    in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco')+                                                (rkco `mkTransCo` kco')+++ty_co_match menv subst ty co lkco rkco+  | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco+  | otherwise               = Nothing++ty_co_match_tc :: MatchEnv -> LiftCoEnv+               -> TyCon -> [Type]+               -> TyCon -> [Coercion]+               -> Maybe LiftCoEnv+ty_co_match_tc menv subst tc1 tys1 tc2 cos2+  = do { guard (tc1 == tc2)+       ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos }+  where+    Pair lkcos rkcos+      = traverse (fmap mkNomReflCo . coercionKind) cos2++ty_co_match_app :: MatchEnv -> LiftCoEnv+                -> Type -> [Type] -> Coercion -> [Coercion]+                -> Maybe LiftCoEnv+ty_co_match_app menv subst ty1 ty1args co2 co2args+  | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1+  , Just (co2', co2a) <- splitAppCo_maybe co2+  = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args)++  | otherwise+  = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co+       ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2+       ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco+       ; let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) co2args+       ; ty_co_match_args menv subst2 ty1args co2args lkcos rkcos }+  where+    ki1 = typeKind ty1+    ki2 = promoteCoercion co2+    ki_ki_co = mkNomReflCo liftedTypeKind++ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type]+                 -> [Coercion] -> [Coercion] -> [Coercion]+                 -> Maybe LiftCoEnv+ty_co_match_args _    subst []       []         _ _ = Just subst+ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos)+  = do { subst' <- ty_co_match menv subst ty arg lkco rkco+       ; ty_co_match_args menv subst' tys args lkcos rkcos }+ty_co_match_args _    _     _        _          _ _ = Nothing++pushRefl :: Coercion -> Maybe Coercion+pushRefl co =+  case (isReflCo_maybe co) of+    Just (AppTy ty1 ty2, Nominal)+      -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2))+    Just (FunTy _ ty1 ty2, r)+      | Just rep1 <- getRuntimeRep_maybe ty1+      , Just rep2 <- getRuntimeRep_maybe ty2+      ->  Just (TyConAppCo r funTyCon [ mkReflCo r rep1, mkReflCo r rep2+                                       , mkReflCo r ty1,  mkReflCo r ty2 ])+    Just (TyConApp tc tys, r)+      -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys))+    Just (ForAllTy (Bndr tv _) ty, r)+      -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty))+    -- NB: NoRefl variant. Otherwise, we get a loop!+    _ -> Nothing
compiler/GHC/Core/Utils.hs view
@@ -27,7 +27,7 @@         getIdFromTrivialExpr_maybe,         exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,         exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,-        exprIsBig, exprIsConLike,+        exprIsConLike,         isCheapApp, isExpandableApp,         exprIsTickedString, exprIsTickedString_maybe,         exprIsTopLevelBindable,@@ -63,35 +63,35 @@ #include "HsVersions.h"  import GhcPrelude+import GHC.Platform  import GHC.Core import PrelNames ( makeStaticName ) import GHC.Core.Ppr import GHC.Core.FVs( exprFreeVars )-import Var-import SrcLoc-import VarEnv-import VarSet-import Name-import Literal-import DataCon+import GHC.Types.Var+import GHC.Types.SrcLoc+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Literal+import GHC.Core.DataCon import PrimOp-import Id-import IdInfo+import GHC.Types.Id+import GHC.Types.Id.Info import PrelNames( absentErrorIdKey )-import Type-import Predicate-import TyCoRep( TyCoBinder(..), TyBinder )-import Coercion-import TyCon-import Unique+import GHC.Core.Type as Type+import GHC.Core.Predicate+import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder )+import GHC.Core.Coercion+import GHC.Core.TyCon+import GHC.Types.Unique import Outputable import TysPrim-import GHC.Driver.Session import FastString import Maybes import ListSetOps       ( minusList )-import BasicTypes       ( Arity, isConLike )+import GHC.Types.Basic     ( Arity, isConLike ) import Util import Pair import Data.ByteString     ( ByteString )@@ -100,7 +100,7 @@ import Data.Ord            ( comparing ) import OrdList import qualified Data.Set as Set-import UniqSet+import GHC.Types.Unique.Set  {- ************************************************************************@@ -162,7 +162,7 @@    go e@(Cast {})                  = check_type e    go (Tick _ e)                   = go e    go e@(Type {})                  = pprPanic "isExprLevPoly ty" (ppr e)-   go (Coercion {})                = False  -- this case can happen in SetLevels+   go (Coercion {})                = False  -- this case can happen in GHC.Core.Op.SetLevels     check_type = isTypeLevPoly . exprType  -- slow approach @@ -625,7 +625,7 @@ we generate (error "Inaccessible alternative").  Similar things can happen (augmented by GADTs) when the Simplifier-filters down the matching alternatives in Simplify.rebuildCase.+filters down the matching alternatives in GHC.Core.Op.Simplify.rebuildCase. -}  ---------------------------------@@ -817,9 +817,9 @@   C2 -> e0 ``` -It isn't obvious that refineDefaultAlt does this but if you look at its one-call site in SimplUtils then the `imposs_deflt_cons` argument is populated with-constructors which are matched elsewhere.+It isn't obvious that refineDefaultAlt does this but if you look at its one call+site in GHC.Core.Op.Simplify.Utils then the `imposs_deflt_cons` argument is+populated with constructors which are matched elsewhere.  -} @@ -864,11 +864,29 @@  and similarly in cascade for all the join points! -NB: it's important that all this is done in [InAlt], *before* we work-on the alternatives themselves, because Simplify.simplAlt may zap the-occurrence info on the binders in the alternatives, which in turn-defeats combineIdenticalAlts (see #7360).+Note [Combine identical alternatives: wrinkles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* It's important that we try to combine alternatives *before*+  simplifying them, rather than after. Reason: because+  Simplify.simplAlt may zap the occurrence info on the binders in the+  alternatives, which in turn defeats combineIdenticalAlts use of+  isDeadBinder (see #7360).++  You can see this in the call to combineIdenticalAlts in+  GHC.Core.Op.Simplify.Utils.prepareAlts.  Here the alternatives have type InAlt+  (the "In" meaning input) rather than OutAlt.++* combineIdenticalAlts does not work well for nullary constructors+      case x of y+         []    -> f []+         (_:_) -> f y+  Here we won't see that [] and y are the same.  Sigh! This problem+  is solved in CSE, in GHC.Core.Op.CSE.combineAlts, which does a better version+  of combineIdenticalAlts. But sadly it doesn't have the occurrence info we have+  here.+  See Note [Combine case alts: awkward corner] in GHC.Core.Op.CSE).+ Note [Care with impossible-constructors when combining alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have (#10538)@@ -1120,8 +1138,8 @@                 and then inlining of case join points -} -exprIsDupable :: DynFlags -> CoreExpr -> Bool-exprIsDupable dflags e+exprIsDupable :: Platform -> CoreExpr -> Bool+exprIsDupable platform e   = isJust (go dupAppSize e)   where     go :: Int -> CoreExpr -> Maybe Int@@ -1131,7 +1149,7 @@     go n (Tick _ e)    = go n e     go n (Cast e _)    = go n e     go n (App f a) | Just n' <- go n a = go n' f-    go n (Lit lit) | litIsDupable dflags lit = decrement n+    go n (Lit lit) | litIsDupable platform lit = decrement n     go _ _ = Nothing      decrement :: Int -> Maybe Int@@ -1314,7 +1332,7 @@  * True of constructor applications (K a b) -* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in BasicTypes.+* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic.   (NB: exprIsCheap might not be true of this)  * False of case-expressions.  If we have@@ -1658,10 +1676,10 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ exprOkForSpeculation accepts very special case expressions. Reason: (a ==# b) is ok-for-speculation, but the litEq rules-in PrelRules convert it (a ==# 3#) to+in GHC.Core.Op.ConstantFold convert it (a ==# 3#) to    case a of { DEFAULT -> 0#; 3# -> 1# } for excellent reasons described in-  PrelRules Note [The litEq rule: converting equality to case].+  GHC.Core.Op.ConstantFold Note [The litEq rule: converting equality to case]. So, annoyingly, we want that case expression to be ok-for-speculation too. Bother. @@ -1675,12 +1693,12 @@    Does the RHS of v satisfy the let/app invariant?  Previously we said   yes, on the grounds that y is evaluated.  But the binder-swap done-  by SetLevels would transform the inner alternative to+  by GHC.Core.Op.SetLevels would transform the inner alternative to      DEFAULT -> ... (let v::Int# = case x of { ... }                      in ...) ....   which does /not/ satisfy the let/app invariant, because x is   not evaluated. See Note [Binder-swap during float-out]-  in SetLevels.  To avoid this awkwardness it seems simpler+  in GHC.Core.Op.SetLevels.  To avoid this awkwardness it seems simpler   to stick to unlifted scrutinees where the issue does not   arise. @@ -1701,7 +1719,7 @@   ----- Historical note: #15696: ---------  Previously SetLevels used exprOkForSpeculation to guide+  Previously GHC.Core.Op.SetLevels used exprOkForSpeculation to guide   floating of single-alternative cases; it now uses exprIsHNF   Note [Floating single-alternative cases]. @@ -1711,8 +1729,8 @@             A -> ...             _ -> ...(case (case x of { B -> p; C -> p }) of                        I# r -> blah)...-  If SetLevels considers the inner nested case as-  ok-for-speculation it can do case-floating (in SetLevels).+  If GHC.Core.Op.SetLevels considers the inner nested case as+  ok-for-speculation it can do case-floating (in GHC.Core.Op.SetLevels).   So we'd float to:     case e of x { DEAFULT ->     case (case x of { B -> p; C -> p }) of I# r ->@@ -2046,7 +2064,7 @@ case in the RHS of the binding for 'v' is fine.  But only if we *know* that 'y' is evaluated. -c.f. add_evals in Simplify.simplAlt+c.f. add_evals in GHC.Core.Op.Simplify.simplAlt  ************************************************************************ *                                                                      *@@ -2058,45 +2076,30 @@ -- | A cheap equality test which bales out fast! --      If it returns @True@ the arguments are definitely equal, --      otherwise, they may or may not be equal.------ See also 'exprIsBig' cheapEqExpr :: Expr b -> Expr b -> Bool cheapEqExpr = cheapEqExpr' (const False)  -- | Cheap expression equality test, can ignore ticks by type. cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool-cheapEqExpr' ignoreTick = go_s-  where go_s = go `on` stripTicksTopE ignoreTick-        go (Var v1)   (Var v2)   = v1 == v2-        go (Lit lit1) (Lit lit2) = lit1 == lit2-        go (Type t1)  (Type t2)  = t1 `eqType` t2-        go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2+{-# INLINE cheapEqExpr' #-}+cheapEqExpr' ignoreTick e1 e2+  = go e1 e2+  where+    go (Var v1)   (Var v2)         = v1 == v2+    go (Lit lit1) (Lit lit2)       = lit1 == lit2+    go (Type t1)  (Type t2)        = t1 `eqType` t2+    go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2+    go (App f1 a1) (App f2 a2)     = f1 `go` f2 && a1 `go` a2+    go (Cast e1 t1) (Cast e2 t2)   = e1 `go` e2 && t1 `eqCoercion` t2 -        go (App f1 a1) (App f2 a2)-          = f1 `go_s` f2 && a1 `go_s` a2+    go (Tick t1 e1) e2 | ignoreTick t1 = go e1 e2+    go e1 (Tick t2 e2) | ignoreTick t2 = go e1 e2+    go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && e1 `go` e2 -        go (Cast e1 t1) (Cast e2 t2)-          = e1 `go_s` e2 && t1 `eqCoercion` t2+    go _ _ = False -        go (Tick t1 e1) (Tick t2 e2)-          = t1 == t2 && e1 `go_s` e2 -        go _ _ = False-        {-# INLINE go #-}-{-# INLINE cheapEqExpr' #-} -exprIsBig :: Expr b -> Bool--- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'-exprIsBig (Lit _)      = False-exprIsBig (Var _)      = False-exprIsBig (Type _)     = False-exprIsBig (Coercion _) = False-exprIsBig (Lam _ e)    = exprIsBig e-exprIsBig (App f a)    = exprIsBig f || exprIsBig a-exprIsBig (Cast e _)   = exprIsBig e    -- Hopefully coercions are not too big!-exprIsBig (Tick _ e)   = exprIsBig e-exprIsBig _            = True- eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool -- Compares for equality, modulo alpha eqExpr in_scope e1 e2@@ -2322,7 +2325,7 @@   says f=bottom, and replaces the (f `seq` True) with just   (f `cast` unsafe-co).  BUT, as thing stand, 'f' got arity 1, and it   *keeps* arity 1 (perhaps also wrongly).  So CorePrep eta-expands-  the definition again, so that it does not termninate after all.+  the definition again, so that it does not terminate after all.   Result: seg-fault because the boolean case actually gets a function value.   See #1947. @@ -2330,7 +2333,7 @@  * Note [Arity care]: we need to be careful if we just look at f's   arity. Currently (Dec07), f's arity is visible in its own RHS (see-  Note [Arity robustness] in SimplEnv) so we must *not* trust the+  Note [Arity robustness] in GHC.Core.Op.Simplify.Env) so we must *not* trust the   arity when checking that 'f' is a value.  Otherwise we will   eta-reduce       f = \x. f x
compiler/GHC/CoreToIface.hs view
@@ -48,30 +48,30 @@ import GhcPrelude  import GHC.Iface.Syntax-import DataCon-import Id-import IdInfo+import GHC.Core.DataCon+import GHC.Types.Id+import GHC.Types.Id.Info import GHC.Core-import TyCon hiding ( pprPromotionQuote )-import CoAxiom+import GHC.Core.TyCon hiding ( pprPromotionQuote )+import GHC.Core.Coercion.Axiom import TysPrim ( eqPrimTyCon, eqReprPrimTyCon ) import TysWiredIn ( heqTyCon )-import MkId ( noinlineIdName )+import GHC.Types.Id.Make ( noinlineIdName ) import PrelNames-import Name-import BasicTypes-import Type-import PatSyn+import GHC.Types.Name+import GHC.Types.Basic+import GHC.Core.Type+import GHC.Core.PatSyn import Outputable import FastString import Util-import Var-import VarEnv-import VarSet-import TyCoRep-import TyCoTidy ( tidyCo )-import Demand ( isTopSig )-import Cpr ( topCprSig )+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Tidy ( tidyCo )+import GHC.Types.Demand ( isTopSig )+import GHC.Types.Cpr ( topCprSig )  import Data.Maybe ( catMaybes ) @@ -345,12 +345,12 @@                  VisArg   -> Required                  InvisArg -> Inferred                    -- It's rare for a kind to have a constraint argument, but-                   -- it can happen. See Note [AnonTCB InvisArg] in TyCon.+                   -- it can happen. See Note [AnonTCB InvisArg] in GHC.Core.TyCon.      go env ty ts@(t1:ts1)       | not (isEmptyTCvSubst env)       = go (zapTCvSubst env) (substTy env ty) ts-        -- See Note [Care with kind instantiation] in Type.hs+        -- See Note [Care with kind instantiation] in GHC.Core.Type        | otherwise       = -- There's a kind error in the type we are trying to print
compiler/GHC/CoreToIface.hs-boot view
@@ -1,14 +1,14 @@ module GHC.CoreToIface where -import {-# SOURCE #-} TyCoRep ( Type, TyLit, Coercion )+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, TyLit, Coercion ) import {-# SOURCE #-} GHC.Iface.Type( IfaceType, IfaceTyCon, IfaceForAllBndr                                     , IfaceCoercion, IfaceTyLit, IfaceAppArgs )-import Var ( TyCoVarBinder )-import VarEnv ( TidyEnv )-import TyCon ( TyCon )-import VarSet( VarSet )+import GHC.Types.Var ( TyCoVarBinder )+import GHC.Types.Var.Env ( TidyEnv )+import GHC.Core.TyCon ( TyCon )+import GHC.Types.Var.Set( VarSet ) --- For TyCoRep+-- For GHC.Core.TyCo.Rep toIfaceTypeX :: VarSet -> Type -> IfaceType toIfaceTyLit :: TyLit -> IfaceTyLit toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr
compiler/GHC/Driver/Backpack/Syntax.hs view
@@ -20,9 +20,9 @@  import GHC.Driver.Phases import GHC.Hs-import SrcLoc+import GHC.Types.SrcLoc import Outputable-import Module+import GHC.Types.Module import UnitInfo  {-
compiler/GHC/Driver/CmdLine.hs view
@@ -32,7 +32,7 @@ import Outputable import Panic import Bag-import SrcLoc+import GHC.Types.SrcLoc import Json  import Data.Function
+ compiler/GHC/Driver/Flags.hs view
@@ -0,0 +1,524 @@+module GHC.Driver.Flags+   ( DumpFlag(..)+   , GeneralFlag(..)+   , WarningFlag(..)+   , WarnReason (..)+   , Language(..)+   , optimisationFlags+   )+where++import GhcPrelude+import Outputable+import EnumSet+import Json++-- | Debugging flags+data DumpFlag+-- See Note [Updating flag description in the User's Guide]++   -- debugging flags+   = Opt_D_dump_cmm+   | Opt_D_dump_cmm_from_stg+   | Opt_D_dump_cmm_raw+   | Opt_D_dump_cmm_verbose_by_proc+   -- All of the cmm subflags (there are a lot!) automatically+   -- enabled if you run -ddump-cmm-verbose-by-proc+   -- Each flag corresponds to exact stage of Cmm pipeline.+   | Opt_D_dump_cmm_verbose+   -- same as -ddump-cmm-verbose-by-proc but writes each stage+   -- to a separate file (if used with -ddump-to-file)+   | Opt_D_dump_cmm_cfg+   | Opt_D_dump_cmm_cbe+   | Opt_D_dump_cmm_switch+   | Opt_D_dump_cmm_proc+   | Opt_D_dump_cmm_sp+   | Opt_D_dump_cmm_sink+   | Opt_D_dump_cmm_caf+   | Opt_D_dump_cmm_procmap+   | Opt_D_dump_cmm_split+   | Opt_D_dump_cmm_info+   | Opt_D_dump_cmm_cps+   -- end cmm subflags+   | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout.+   | Opt_D_dump_asm+   | Opt_D_dump_asm_native+   | Opt_D_dump_asm_liveness+   | Opt_D_dump_asm_regalloc+   | Opt_D_dump_asm_regalloc_stages+   | Opt_D_dump_asm_conflicts+   | Opt_D_dump_asm_stats+   | Opt_D_dump_asm_expanded+   | Opt_D_dump_llvm+   | Opt_D_dump_core_stats+   | Opt_D_dump_deriv+   | Opt_D_dump_ds+   | Opt_D_dump_ds_preopt+   | Opt_D_dump_foreign+   | Opt_D_dump_inlinings+   | Opt_D_dump_rule_firings+   | Opt_D_dump_rule_rewrites+   | Opt_D_dump_simpl_trace+   | Opt_D_dump_occur_anal+   | Opt_D_dump_parsed+   | Opt_D_dump_parsed_ast+   | Opt_D_dump_rn+   | Opt_D_dump_rn_ast+   | Opt_D_dump_simpl+   | Opt_D_dump_simpl_iterations+   | Opt_D_dump_spec+   | Opt_D_dump_prep+   | Opt_D_dump_stg -- CoreToStg output+   | Opt_D_dump_stg_unarised -- STG after unarise+   | Opt_D_dump_stg_final -- STG after stg2stg+   | Opt_D_dump_call_arity+   | Opt_D_dump_exitify+   | Opt_D_dump_stranal+   | Opt_D_dump_str_signatures+   | Opt_D_dump_cpranal+   | Opt_D_dump_cpr_signatures+   | Opt_D_dump_tc+   | Opt_D_dump_tc_ast+   | Opt_D_dump_types+   | Opt_D_dump_rules+   | Opt_D_dump_cse+   | Opt_D_dump_worker_wrapper+   | Opt_D_dump_rn_trace+   | Opt_D_dump_rn_stats+   | Opt_D_dump_opt_cmm+   | Opt_D_dump_simpl_stats+   | Opt_D_dump_cs_trace -- Constraint solver in type checker+   | Opt_D_dump_tc_trace+   | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker+   | Opt_D_dump_if_trace+   | Opt_D_dump_vt_trace+   | Opt_D_dump_splices+   | Opt_D_th_dec_file+   | Opt_D_dump_BCOs+   | Opt_D_dump_ticked+   | Opt_D_dump_rtti+   | Opt_D_source_stats+   | Opt_D_verbose_stg2stg+   | Opt_D_dump_hi+   | Opt_D_dump_hi_diffs+   | Opt_D_dump_mod_cycles+   | Opt_D_dump_mod_map+   | Opt_D_dump_timings+   | Opt_D_dump_view_pattern_commoning+   | Opt_D_verbose_core2core+   | Opt_D_dump_debug+   | Opt_D_dump_json+   | Opt_D_ppr_debug+   | Opt_D_no_debug_output+   deriving (Eq, Show, Enum)++-- | Enumerates the simple on-or-off dynamic flags+data GeneralFlag+-- See Note [Updating flag description in the User's Guide]++   = Opt_DumpToFile                     -- ^ Append dump output to files instead of stdout.+   | Opt_D_faststring_stats+   | Opt_D_dump_minimal_imports+   | Opt_DoCoreLinting+   | Opt_DoStgLinting+   | Opt_DoCmmLinting+   | Opt_DoAsmLinting+   | Opt_DoAnnotationLinting+   | Opt_NoLlvmMangler                  -- hidden flag+   | Opt_FastLlvm                       -- hidden flag+   | Opt_NoTypeableBinds++   | Opt_WarnIsError                    -- -Werror; makes warnings fatal+   | Opt_ShowWarnGroups                 -- Show the group a warning belongs to+   | Opt_HideSourcePaths                -- Hide module source/object paths++   | Opt_PrintExplicitForalls+   | Opt_PrintExplicitKinds+   | Opt_PrintExplicitCoercions+   | Opt_PrintExplicitRuntimeReps+   | Opt_PrintEqualityRelations+   | Opt_PrintAxiomIncomps+   | Opt_PrintUnicodeSyntax+   | Opt_PrintExpandedSynonyms+   | Opt_PrintPotentialInstances+   | Opt_PrintTypecheckerElaboration++   -- optimisation opts+   | Opt_CallArity+   | Opt_Exitification+   | Opt_Strictness+   | Opt_LateDmdAnal                    -- #6087+   | Opt_KillAbsence+   | Opt_KillOneShot+   | Opt_FullLaziness+   | Opt_FloatIn+   | Opt_LateSpecialise+   | Opt_Specialise+   | Opt_SpecialiseAggressively+   | Opt_CrossModuleSpecialise+   | Opt_StaticArgumentTransformation+   | Opt_CSE+   | Opt_StgCSE+   | Opt_StgLiftLams+   | Opt_LiberateCase+   | Opt_SpecConstr+   | Opt_SpecConstrKeen+   | Opt_DoLambdaEtaExpansion+   | Opt_IgnoreAsserts+   | Opt_DoEtaReduction+   | Opt_CaseMerge+   | Opt_CaseFolding                    -- Constant folding through case-expressions+   | Opt_UnboxStrictFields+   | Opt_UnboxSmallStrictFields+   | Opt_DictsCheap+   | Opt_EnableRewriteRules             -- Apply rewrite rules during simplification+   | Opt_EnableThSpliceWarnings         -- Enable warnings for TH splices+   | Opt_RegsGraph                      -- do graph coloring register allocation+   | Opt_RegsIterative                  -- do iterative coalescing graph coloring register allocation+   | Opt_PedanticBottoms                -- Be picky about how we treat bottom+   | Opt_LlvmTBAA                       -- Use LLVM TBAA infrastructure for improving AA (hidden flag)+   | Opt_LlvmFillUndefWithGarbage       -- Testing for undef bugs (hidden flag)+   | Opt_IrrefutableTuples+   | Opt_CmmSink+   | Opt_CmmElimCommonBlocks+   | Opt_AsmShortcutting+   | Opt_OmitYields+   | Opt_FunToThunk               -- allow GHC.Core.Op.WorkWrap.Lib.mkWorkerArgs to remove all value lambdas+   | Opt_DictsStrict                     -- be strict in argument dictionaries+   | Opt_DmdTxDictSel              -- use a special demand transformer for dictionary selectors+   | Opt_Loopification                  -- See Note [Self-recursive tail calls]+   | Opt_CfgBlocklayout             -- ^ Use the cfg based block layout algorithm.+   | Opt_WeightlessBlocklayout         -- ^ Layout based on last instruction per block.+   | Opt_CprAnal+   | Opt_WorkerWrapper+   | Opt_SolveConstantDicts+   | Opt_AlignmentSanitisation+   | Opt_CatchBottoms+   | Opt_NumConstantFolding++   -- PreInlining is on by default. The option is there just to see how+   -- bad things get if you turn it off!+   | Opt_SimplPreInlining++   -- Interface files+   | Opt_IgnoreInterfacePragmas+   | Opt_OmitInterfacePragmas+   | Opt_ExposeAllUnfoldings+   | Opt_WriteInterface -- forces .hi files to be written even with -fno-code+   | Opt_WriteHie -- generate .hie files++   -- profiling opts+   | Opt_AutoSccsOnIndividualCafs+   | Opt_ProfCountEntries++   -- misc opts+   | Opt_Pp+   | Opt_ForceRecomp+   | Opt_IgnoreOptimChanges+   | Opt_IgnoreHpcChanges+   | Opt_ExcessPrecision+   | Opt_EagerBlackHoling+   | Opt_NoHsMain+   | Opt_SplitSections+   | Opt_StgStats+   | Opt_HideAllPackages+   | Opt_HideAllPluginPackages+   | Opt_PrintBindResult+   | Opt_Haddock+   | Opt_HaddockOptions+   | Opt_BreakOnException+   | Opt_BreakOnError+   | Opt_PrintEvldWithShow+   | Opt_PrintBindContents+   | Opt_GenManifest+   | Opt_EmbedManifest+   | Opt_SharedImplib+   | Opt_BuildingCabalPackage+   | Opt_IgnoreDotGhci+   | Opt_GhciSandbox+   | Opt_GhciHistory+   | Opt_GhciLeakCheck+   | Opt_ValidateHie+   | Opt_LocalGhciHistory+   | Opt_NoIt+   | Opt_HelpfulErrors+   | Opt_DeferTypeErrors+   | Opt_DeferTypedHoles+   | Opt_DeferOutOfScopeVariables+   | Opt_PIC                         -- ^ @-fPIC@+   | Opt_PIE                         -- ^ @-fPIE@+   | Opt_PICExecutable               -- ^ @-pie@+   | Opt_ExternalDynamicRefs+   | Opt_SccProfilingOn+   | Opt_Ticky+   | Opt_Ticky_Allocd+   | Opt_Ticky_LNE+   | Opt_Ticky_Dyn_Thunk+   | Opt_RPath+   | Opt_RelativeDynlibPaths+   | Opt_Hpc+   | Opt_FlatCache+   | Opt_ExternalInterpreter+   | Opt_OptimalApplicativeDo+   | Opt_VersionMacros+   | Opt_WholeArchiveHsLibs+   -- copy all libs into a single folder prior to linking binaries+   -- this should elivate the excessive command line limit restrictions+   -- on windows, by only requiring a single -L argument instead of+   -- one for each dependency.  At the time of this writing, gcc+   -- forwards all -L flags to the collect2 command without using a+   -- response file and as such breaking apart.+   | Opt_SingleLibFolder+   | Opt_KeepCAFs+   | Opt_KeepGoing+   | Opt_ByteCode++   -- output style opts+   | Opt_ErrorSpans -- Include full span info in error messages,+                    -- instead of just the start position.+   | Opt_DeferDiagnostics+   | Opt_DiagnosticsShowCaret -- Show snippets of offending code+   | Opt_PprCaseAsLet+   | Opt_PprShowTicks+   | Opt_ShowHoleConstraints+    -- Options relating to the display of valid hole fits+    -- when generating an error message for a typed hole+    -- See Note [Valid hole fits include] in TcHoleErrors.hs+   | Opt_ShowValidHoleFits+   | Opt_SortValidHoleFits+   | Opt_SortBySizeHoleFits+   | Opt_SortBySubsumHoleFits+   | Opt_AbstractRefHoleFits+   | Opt_UnclutterValidHoleFits+   | Opt_ShowTypeAppOfHoleFits+   | Opt_ShowTypeAppVarsOfHoleFits+   | Opt_ShowDocsOfHoleFits+   | Opt_ShowTypeOfHoleFits+   | Opt_ShowProvOfHoleFits+   | Opt_ShowMatchesOfHoleFits++   | Opt_ShowLoadedModules+   | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals]++   -- Suppress all coercions, them replacing with '...'+   | Opt_SuppressCoercions+   | Opt_SuppressVarKinds+   -- Suppress module id prefixes on variables.+   | Opt_SuppressModulePrefixes+   -- Suppress type applications.+   | Opt_SuppressTypeApplications+   -- Suppress info such as arity and unfoldings on identifiers.+   | Opt_SuppressIdInfo+   -- Suppress separate type signatures in core, but leave types on+   -- lambda bound vars+   | Opt_SuppressUnfoldings+   -- Suppress the details of even stable unfoldings+   | Opt_SuppressTypeSignatures+   -- Suppress unique ids on variables.+   -- Except for uniques, as some simplifier phases introduce new+   -- variables that have otherwise identical names.+   | Opt_SuppressUniques+   | Opt_SuppressStgExts+   | Opt_SuppressTicks     -- Replaces Opt_PprShowTicks+   | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps++   -- temporary flags+   | Opt_AutoLinkPackages+   | Opt_ImplicitImportQualified++   -- keeping stuff+   | Opt_KeepHscppFiles+   | Opt_KeepHiDiffs+   | Opt_KeepHcFiles+   | Opt_KeepSFiles+   | Opt_KeepTmpFiles+   | Opt_KeepRawTokenStream+   | Opt_KeepLlvmFiles+   | Opt_KeepHiFiles+   | Opt_KeepOFiles++   | Opt_BuildDynamicToo++   -- safe haskell flags+   | Opt_DistrustAllPackages+   | Opt_PackageTrust+   | Opt_PluginTrustworthy++   | Opt_G_NoStateHack+   | Opt_G_NoOptCoercion+   deriving (Eq, Show, Enum)++-- Check whether a flag should be considered an "optimisation flag"+-- for purposes of recompilation avoidance (see+-- Note [Ignoring some flag changes] in FlagChecker). Being listed here is+-- not a guarantee that the flag has no other effect. We could, and+-- perhaps should, separate out the flags that have some minor impact on+-- program semantics and/or error behavior (e.g., assertions), but+-- then we'd need to go to extra trouble (and an additional flag)+-- to allow users to ignore the optimisation level even though that+-- means ignoring some change.+optimisationFlags :: EnumSet GeneralFlag+optimisationFlags = EnumSet.fromList+   [ Opt_CallArity+   , Opt_Strictness+   , Opt_LateDmdAnal+   , Opt_KillAbsence+   , Opt_KillOneShot+   , Opt_FullLaziness+   , Opt_FloatIn+   , Opt_LateSpecialise+   , Opt_Specialise+   , Opt_SpecialiseAggressively+   , Opt_CrossModuleSpecialise+   , Opt_StaticArgumentTransformation+   , Opt_CSE+   , Opt_StgCSE+   , Opt_StgLiftLams+   , Opt_LiberateCase+   , Opt_SpecConstr+   , Opt_SpecConstrKeen+   , Opt_DoLambdaEtaExpansion+   , Opt_IgnoreAsserts+   , Opt_DoEtaReduction+   , Opt_CaseMerge+   , Opt_CaseFolding+   , Opt_UnboxStrictFields+   , Opt_UnboxSmallStrictFields+   , Opt_DictsCheap+   , Opt_EnableRewriteRules+   , Opt_RegsGraph+   , Opt_RegsIterative+   , Opt_PedanticBottoms+   , Opt_LlvmTBAA+   , Opt_LlvmFillUndefWithGarbage+   , Opt_IrrefutableTuples+   , Opt_CmmSink+   , Opt_CmmElimCommonBlocks+   , Opt_AsmShortcutting+   , Opt_OmitYields+   , Opt_FunToThunk+   , Opt_DictsStrict+   , Opt_DmdTxDictSel+   , Opt_Loopification+   , Opt_CfgBlocklayout+   , Opt_WeightlessBlocklayout+   , Opt_CprAnal+   , Opt_WorkerWrapper+   , Opt_SolveConstantDicts+   , Opt_CatchBottoms+   , Opt_IgnoreAsserts+   ]++data WarningFlag =+-- See Note [Updating flag description in the User's Guide]+     Opt_WarnDuplicateExports+   | Opt_WarnDuplicateConstraints+   | Opt_WarnRedundantConstraints+   | Opt_WarnHiShadows+   | Opt_WarnImplicitPrelude+   | Opt_WarnIncompletePatterns+   | Opt_WarnIncompleteUniPatterns+   | Opt_WarnIncompletePatternsRecUpd+   | Opt_WarnOverflowedLiterals+   | Opt_WarnEmptyEnumerations+   | Opt_WarnMissingFields+   | Opt_WarnMissingImportList+   | Opt_WarnMissingMethods+   | Opt_WarnMissingSignatures+   | Opt_WarnMissingLocalSignatures+   | Opt_WarnNameShadowing+   | Opt_WarnOverlappingPatterns+   | Opt_WarnTypeDefaults+   | Opt_WarnMonomorphism+   | Opt_WarnUnusedTopBinds+   | Opt_WarnUnusedLocalBinds+   | Opt_WarnUnusedPatternBinds+   | Opt_WarnUnusedImports+   | Opt_WarnUnusedMatches+   | Opt_WarnUnusedTypePatterns+   | Opt_WarnUnusedForalls+   | Opt_WarnUnusedRecordWildcards+   | Opt_WarnRedundantRecordWildcards+   | Opt_WarnWarningsDeprecations+   | Opt_WarnDeprecatedFlags+   | Opt_WarnMissingMonadFailInstances -- since 8.0, has no effect since 8.8+   | Opt_WarnSemigroup -- since 8.0+   | Opt_WarnDodgyExports+   | Opt_WarnDodgyImports+   | Opt_WarnOrphans+   | Opt_WarnAutoOrphans+   | Opt_WarnIdentities+   | Opt_WarnTabs+   | Opt_WarnUnrecognisedPragmas+   | Opt_WarnDodgyForeignImports+   | Opt_WarnUnusedDoBind+   | Opt_WarnWrongDoBind+   | Opt_WarnAlternativeLayoutRuleTransitional+   | Opt_WarnUnsafe+   | Opt_WarnSafe+   | Opt_WarnTrustworthySafe+   | Opt_WarnMissedSpecs+   | Opt_WarnAllMissedSpecs+   | Opt_WarnUnsupportedCallingConventions+   | Opt_WarnUnsupportedLlvmVersion+   | Opt_WarnMissedExtraSharedLib+   | Opt_WarnInlineRuleShadowing+   | Opt_WarnTypedHoles+   | Opt_WarnPartialTypeSignatures+   | Opt_WarnMissingExportedSignatures+   | Opt_WarnUntickedPromotedConstructors+   | Opt_WarnDerivingTypeable+   | Opt_WarnDeferredTypeErrors+   | Opt_WarnDeferredOutOfScopeVariables+   | Opt_WarnNonCanonicalMonadInstances   -- since 8.0+   | Opt_WarnNonCanonicalMonadFailInstances   -- since 8.0, removed 8.8+   | Opt_WarnNonCanonicalMonoidInstances  -- since 8.0+   | Opt_WarnMissingPatternSynonymSignatures -- since 8.0+   | Opt_WarnUnrecognisedWarningFlags     -- since 8.0+   | Opt_WarnSimplifiableClassConstraints -- Since 8.2+   | Opt_WarnCPPUndef                     -- Since 8.2+   | Opt_WarnUnbangedStrictPatterns       -- Since 8.2+   | Opt_WarnMissingHomeModules           -- Since 8.2+   | Opt_WarnPartialFields                -- Since 8.4+   | Opt_WarnMissingExportList+   | Opt_WarnInaccessibleCode+   | Opt_WarnStarIsType                   -- Since 8.6+   | Opt_WarnStarBinder                   -- Since 8.6+   | Opt_WarnImplicitKindVars             -- Since 8.6+   | Opt_WarnSpaceAfterBang+   | Opt_WarnMissingDerivingStrategies    -- Since 8.8+   | Opt_WarnPrepositiveQualifiedModule   -- Since TBD+   | Opt_WarnUnusedPackages               -- Since 8.10+   | Opt_WarnInferredSafeImports          -- Since 8.10+   | Opt_WarnMissingSafeHaskellMode       -- Since 8.10+   | Opt_WarnCompatUnqualifiedImports     -- Since 8.10+   | Opt_WarnDerivingDefaults+   deriving (Eq, Show, Enum)++-- | Used when outputting warnings: if a reason is given, it is+-- displayed. If a warning isn't controlled by a flag, this is made+-- explicit at the point of use.+data WarnReason+  = NoReason+  -- | Warning was enabled with the flag+  | Reason !WarningFlag+  -- | Warning was made an error because of -Werror or -Werror=WarningFlag+  | ErrReason !(Maybe WarningFlag)+  deriving Show++instance Outputable WarnReason where+  ppr = text . show++instance ToJson WarnReason where+  json NoReason = JSNull+  json (Reason wf) = JSString (show wf)+  json (ErrReason Nothing) = JSString "Opt_WarnIsError"+  json (ErrReason (Just wf)) = JSString (show wf)+++data Language = Haskell98 | Haskell2010+   deriving (Eq, Enum, Show)++instance Outputable Language where+    ppr = text . show+
compiler/GHC/Driver/Hooks.hs view
@@ -39,18 +39,18 @@ import OrdList import TcRnTypes import Bag-import RdrName-import Name-import Id+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.Id import GHC.Core import GHCi.RemoteTypes-import SrcLoc-import Type+import GHC.Types.SrcLoc+import GHC.Core.Type import System.Process-import BasicTypes-import Module-import TyCon-import CostCentre+import GHC.Types.Basic+import GHC.Types.Module+import GHC.Core.TyCon+import GHC.Types.CostCentre import GHC.Stg.Syntax import Stream import GHC.Cmm
compiler/GHC/Driver/Packages.hs view
@@ -47,6 +47,7 @@         getPackageFrameworkPath,         getPackageFrameworks,         getUnitInfoMap,+        getPackageState,         getPreloadPackagesAnd,          collectArchives,@@ -54,13 +55,15 @@         packageHsLibs, getLibs,          -- * Utils+        mkComponentId,+        updateComponentId,         unwireUnitId,         pprFlag,         pprPackages,         pprPackagesSimple,         pprModuleMap,         isIndefinite,-        isDllName+        isDynLinkName     ) where @@ -71,11 +74,12 @@ import GHC.PackageDb import UnitInfo import GHC.Driver.Session-import Name             ( Name, nameModule_maybe )-import UniqFM-import UniqDFM-import UniqSet-import Module+import GHC.Driver.Ways+import GHC.Types.Name       ( Name, nameModule_maybe )+import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM+import GHC.Types.Unique.Set+import GHC.Types.Module import Util import Panic import GHC.Platform@@ -407,21 +411,21 @@ -- | Find the indefinite package for a given 'ComponentId'. -- The way this works is just by fiat'ing that every indefinite package's -- unit key is precisely its component ID; and that they share uniques.-lookupComponentId :: DynFlags -> ComponentId -> Maybe UnitInfo-lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs+lookupComponentId :: PackageState -> ComponentId -> Maybe UnitInfo+lookupComponentId pkgstate (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs   where-    UnitInfoMap pkg_map = unitInfoMap (pkgState dflags)+    UnitInfoMap pkg_map = unitInfoMap pkgstate -}  -- | Find the package we know about with the given package name (e.g. @foo@), if any -- (NB: there might be a locally defined unit name which overrides this)-lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId-lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags))+lookupPackageName :: PackageState -> PackageName -> Maybe ComponentId+lookupPackageName pkgstate n = Map.lookup n (packageNameMap pkgstate)  -- | Search for packages with a given package ID (e.g. \"foo-0.1\")-searchPackageId :: DynFlags -> SourcePackageId -> [UnitInfo]-searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)-                               (listUnitInfoMap dflags)+searchPackageId :: PackageState -> SourcePackageId -> [UnitInfo]+searchPackageId pkgstate pid = filter ((pid ==) . sourcePackageId)+                               (listUnitInfoMap pkgstate)  -- | Extends the package configuration map with a list of package configs. extendUnitInfoMap@@ -441,15 +445,15 @@       Just config -> config       Nothing -> pprPanic "getPackageDetails" (ppr pid) -lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe UnitInfo-lookupInstalledPackage dflags uid = lookupInstalledPackage' (unitInfoMap (pkgState dflags)) uid+lookupInstalledPackage :: PackageState -> InstalledUnitId -> Maybe UnitInfo+lookupInstalledPackage pkgstate uid = lookupInstalledPackage' (unitInfoMap pkgstate) uid  lookupInstalledPackage' :: UnitInfoMap -> InstalledUnitId -> Maybe UnitInfo lookupInstalledPackage' (UnitInfoMap db _) uid = lookupUDFM db uid -getInstalledPackageDetails :: HasDebugCallStack => DynFlags -> InstalledUnitId -> UnitInfo-getInstalledPackageDetails dflags uid =-    case lookupInstalledPackage dflags uid of+getInstalledPackageDetails :: HasDebugCallStack => PackageState -> InstalledUnitId -> UnitInfo+getInstalledPackageDetails pkgstate uid =+    case lookupInstalledPackage pkgstate uid of       Just config -> config       Nothing -> pprPanic "getInstalledPackageDetails" (ppr uid) @@ -457,10 +461,10 @@ -- this function, although all packages in this map are "visible", this -- does not imply that the exposed-modules of the package are available -- (they may have been thinned or renamed).-listUnitInfoMap :: DynFlags -> [UnitInfo]-listUnitInfoMap dflags = eltsUDFM pkg_map+listUnitInfoMap :: PackageState -> [UnitInfo]+listUnitInfoMap pkgstate = eltsUDFM pkg_map   where-    UnitInfoMap pkg_map _ = unitInfoMap (pkgState dflags)+    UnitInfoMap pkg_map _ = unitInfoMap pkgstate  -- ---------------------------------------------------------------------------- -- Loading the package db files and building up the package state@@ -994,7 +998,7 @@ -- ----------------------------------------------------------------------------- -- Wired-in packages ----- See Note [Wired-in packages] in Module+-- See Note [Wired-in packages] in GHC.Types.Module  type WiredInUnitId = String type WiredPackagesMap = Map WiredUnitId WiredUnitId@@ -1014,7 +1018,7 @@ findWiredInPackages dflags prec_map pkgs vis_map = do   -- Now we must find our wired-in packages, and rename them to   -- their canonical names (eg. base-1.0 ==> base), as described-  -- in Note [Wired-in packages] in Module+  -- in Note [Wired-in packages] in GHC.Types.Module   let         matches :: UnitInfo -> WiredInUnitId -> Bool         pc `matches` pid@@ -1073,6 +1077,7 @@   mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_unitids   let         wired_in_pkgs = catMaybes mb_wired_in_pkgs+        pkgstate = pkgState dflags          -- this is old: we used to assume that if there were         -- multiple versions of wired-in packages installed that@@ -1101,7 +1106,7 @@                   = let fs = installedUnitIdFS (unDefUnitId wiredInUnitId)                     in pkg {                       unitId = fsToInstalledUnitId fs,-                      componentId = ComponentId fs+                      componentId = mkComponentId pkgstate fs                     }                   | otherwise                   = pkg@@ -1118,7 +1123,7 @@  -- Helper functions for rewiring Module and UnitId.  These -- rewrite UnitIds of modules in wired-in packages to the form known to the--- compiler, as described in Note [Wired-in packages] in Module.+-- compiler, as described in Note [Wired-in packages] in GHC.Types.Module. -- -- For instance, base-4.9.0.0 will be rewritten to just base, to match -- what appears in PrelNames.@@ -1839,22 +1844,22 @@   where         ways0 = ways dflags -        ways1 = filter (/= WayDyn) ways0+        ways1 = Set.filter (/= WayDyn) ways0         -- the name of a shared library is libHSfoo-ghc<version>.so         -- we leave out the _dyn, because it is superfluous          -- debug and profiled RTSs include support for -eventlog-        ways2 | WayDebug `elem` ways1 || WayProf `elem` ways1-              = filter (/= WayEventLog) ways1+        ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1+              = Set.filter (/= WayEventLog) ways1               | otherwise               = ways1 -        tag     = mkBuildTag (filter (not . wayRTSOnly) ways2)-        rts_tag = mkBuildTag ways2+        tag     = waysTag (Set.filter (not . wayRTSOnly) ways2)+        rts_tag = waysTag ways2          mkDynName x-         | WayDyn `notElem` ways dflags = x-         | "HS" `isPrefixOf` x          =+         | WayDyn `Set.notMember` ways dflags = x+         | "HS" `isPrefixOf` x                =               x ++ '-':programName dflags ++ projectVersion dflags            -- For non-Haskell libraries, we use the name "Cfoo". The .a            -- file is libCfoo.a, and the .so is libfoo.so. That way the@@ -2053,7 +2058,7 @@       pairs = zip pkgids (repeat Nothing)   in do   all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs)-  return (map (getInstalledPackageDetails dflags) all_pkgs)+  return (map (getInstalledPackageDetails state) all_pkgs)  -- Takes a list of packages, and returns the list with dependencies included, -- in reverse dependency order (a package appears before those it depends on).@@ -2106,27 +2111,52 @@  -- ----------------------------------------------------------------------------- -componentIdString :: DynFlags -> ComponentId -> Maybe String-componentIdString dflags cid = do-    conf <- lookupInstalledPackage dflags (componentIdToInstalledUnitId cid)-    return $-        case sourceLibName conf of-            Nothing -> sourcePackageIdString conf-            Just (PackageName libname) ->-                packageNameString conf-                    ++ "-" ++ showVersion (packageVersion conf)-                    ++ ":" ++ unpackFS libname+componentIdString :: ComponentId -> String+componentIdString (ComponentId  raw Nothing)        = unpackFS raw+componentIdString (ComponentId _raw (Just details)) =+   case componentName details of+     Nothing    -> componentSourcePkdId details+     Just cname -> componentPackageName details+                     ++ "-" ++ showVersion (componentPackageVersion details)+                     ++ ":" ++ cname -displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String-displayInstalledUnitId dflags uid =-    fmap sourcePackageIdString (lookupInstalledPackage dflags uid)+-- Cabal packages may contain several components (programs, libraries, etc.).+-- As far as GHC is concerned, installed package components ("units") are+-- identified by an opaque ComponentId string provided by Cabal. As the string+-- contains a hash, we don't want to display it to users so GHC queries the+-- database to retrieve some infos about the original source package (name,+-- version, component name).+--+-- Instead we want to display: packagename-version[:componentname]+--+-- Component name is only displayed if it isn't the default library+--+-- To do this we need to query the database (cached in DynFlags). We cache+-- these details in the ComponentId itself because we don't want to query+-- DynFlags each time we pretty-print the ComponentId+--+mkComponentId :: PackageState -> FastString -> ComponentId+mkComponentId pkgstate raw =+    case lookupInstalledPackage pkgstate (InstalledUnitId raw) of+      Nothing -> ComponentId raw Nothing -- we didn't find the unit at all+      Just c  -> ComponentId raw $ Just $ ComponentDetails+                                             (packageNameString c)+                                             (packageVersion c)+                                             ((unpackFS . unPackageName) <$> sourceLibName c)+                                             (sourcePackageIdString c) --- | Will the 'Name' come from a dynamically linked library?-isDllName :: DynFlags -> Module -> Name -> Bool--- Despite the "dll", I think this function just means that--- the symbol comes from another dynamically-linked package,--- and applies on all platforms, not just Windows-isDllName dflags this_mod name+-- | Update component ID details from the database+updateComponentId :: PackageState -> ComponentId -> ComponentId+updateComponentId pkgstate (ComponentId raw _) = mkComponentId pkgstate raw+++displayInstalledUnitId :: PackageState -> InstalledUnitId -> Maybe String+displayInstalledUnitId pkgstate uid =+    fmap sourcePackageIdString (lookupInstalledPackage pkgstate uid)++-- | Will the 'Name' come from a dynamically linked package?+isDynLinkName :: DynFlags -> Module -> Name -> Bool+isDynLinkName dflags this_mod name   | not (gopt Opt_ExternalDynamicRefs dflags) = False   | Just mod <- nameModule_maybe name     -- Issue #8696 - when GHC is dynamically linked, it will attempt@@ -2136,7 +2166,7 @@     -- intra-package linking, because we don't generate indirect     -- (dynamic) symbols for intra-package calls. This means that if a     -- module with an intra-package call is loaded without its-    -- dependencies, then GHC fails to link. This is the cause of #+    -- dependencies, then GHC fails to link.     --     -- In the mean time, always force dynamic indirections to be     -- generated: when the module name isn't the module being@@ -2161,18 +2191,18 @@ -- Displaying packages  -- | Show (very verbose) package info-pprPackages :: DynFlags -> SDoc+pprPackages :: PackageState -> SDoc pprPackages = pprPackagesWith pprUnitInfo -pprPackagesWith :: (UnitInfo -> SDoc) -> DynFlags -> SDoc-pprPackagesWith pprIPI dflags =-    vcat (intersperse (text "---") (map pprIPI (listUnitInfoMap dflags)))+pprPackagesWith :: (UnitInfo -> SDoc) -> PackageState -> SDoc+pprPackagesWith pprIPI pkgstate =+    vcat (intersperse (text "---") (map pprIPI (listUnitInfoMap pkgstate)))  -- | Show simplified package info. -- -- The idea is to only print package id, and any information that might -- be different from the package databases (exposure, trust)-pprPackagesSimple :: DynFlags -> SDoc+pprPackagesSimple :: PackageState -> SDoc pprPackagesSimple = pprPackagesWith pprIPI     where pprIPI ipi = let i = installedUnitIdFS (unitId ipi)                            e = if exposed ipi then text "E" else text " "@@ -2213,3 +2243,8 @@ -- in the @hs-boot@ loop-breaker. getUnitInfoMap :: DynFlags -> UnitInfoMap getUnitInfoMap = unitInfoMap . pkgState++-- | Retrieve the 'PackageState' from 'DynFlags'; used+-- in the @hs-boot@ loop-breaker.+getPackageState :: DynFlags -> PackageState+getPackageState = pkgState
compiler/GHC/Driver/Packages.hs-boot view
@@ -1,12 +1,15 @@ module GHC.Driver.Packages where import GhcPrelude+import FastString import {-# SOURCE #-} GHC.Driver.Session (DynFlags)-import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId)+import {-# SOURCE #-} GHC.Types.Module(ComponentId, UnitId, InstalledUnitId) data PackageState data UnitInfoMap data PackageDatabase emptyPackageState :: PackageState-componentIdString :: DynFlags -> ComponentId -> Maybe String-displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String+componentIdString :: ComponentId -> String+mkComponentId :: PackageState -> FastString -> ComponentId+displayInstalledUnitId :: PackageState -> InstalledUnitId -> Maybe String improveUnitId :: UnitInfoMap -> UnitId -> UnitId getUnitInfoMap :: DynFlags -> UnitInfoMap+getPackageState :: DynFlags -> PackageState
compiler/GHC/Driver/Phases.hs view
@@ -41,7 +41,6 @@  import GhcPrelude -import {-# SOURCE #-} GHC.Driver.Session import Outputable import GHC.Platform import System.FilePath@@ -198,15 +197,15 @@ possible for a ghc-api user to do so. So be careful when using the function happensBefore, and don't think that `not (a <= b)` implies `b < a`. -}-happensBefore :: DynFlags -> Phase -> Phase -> Bool-happensBefore dflags p1 p2 = p1 `happensBefore'` p2+happensBefore :: Platform -> Phase -> Phase -> Bool+happensBefore platform p1 p2 = p1 `happensBefore'` p2     where StopLn `happensBefore'` _ = False           x      `happensBefore'` y = after_x `eqPhase` y                                    || after_x `happensBefore'` y-              where after_x = nextPhase dflags x+              where after_x = nextPhase platform x -nextPhase :: DynFlags -> Phase -> Phase-nextPhase dflags p+nextPhase :: Platform -> Phase -> Phase+nextPhase platform p     -- A conservative approximation to the next phase, used in happensBefore     = case p of       Unlit sf   -> Cpp  sf@@ -226,7 +225,7 @@       HCc        -> As False       MergeForeign -> StopLn       StopLn     -> panic "nextPhase: nothing after StopLn"-    where maybeHCc = if platformUnregisterised (targetPlatform dflags)+    where maybeHCc = if platformUnregisterised platform                      then HCc                      else As False
compiler/GHC/Driver/Pipeline/Monad.hs view
@@ -18,7 +18,7 @@ import GHC.Driver.Session import GHC.Driver.Phases import GHC.Driver.Types-import Module+import GHC.Types.Module import FileCleanup (TempFileLifetime)  import Control.Monad
compiler/GHC/Driver/Plugins.hs view
@@ -49,7 +49,7 @@  import GhcPrelude -import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM )+import {-# SOURCE #-} GHC.Core.Op.Monad ( CoreToDo, CoreM ) import qualified TcRnTypes import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports  ) import TcHoleFitTypes ( HoleFitPluginR )@@ -58,7 +58,7 @@ import GHC.Driver.Types import GHC.Driver.Monad import GHC.Driver.Phases-import Module ( ModuleName, Module(moduleName))+import GHC.Types.Module ( ModuleName, Module(moduleName)) import Fingerprint import Data.List (sort) import Outputable (Outputable(..), text, (<+>))
compiler/GHC/Driver/Session.hs view
@@ -65,8 +65,7 @@         optimisationFlags,         setFlagsFromEnvFile, -        Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,-        wayGeneralFlags, wayUnsetGeneralFlags,+        addWay', updateWays,          thisPackage, thisComponentId, thisUnitIdInsts, @@ -163,8 +162,6 @@         addPluginModuleName,         defaultDynFlags,                -- Settings -> DynFlags         defaultWays,-        interpWays,-        interpreterProfiled, interpreterDynamic,         initDynFlags,                   -- DynFlags -> IO DynFlags         defaultFatalMessager,         defaultLogAction,@@ -202,16 +199,11 @@         -- * Compiler configuration suitable for display to the user         compilerInfo, -        rtsIsProfiled,-        dynamicGhc,- #include "GHCConstantsHaskellExports.hs"         bLOCK_SIZE_W,-        wORD_SIZE_IN_BITS,         wordAlignment,         tAG_MASK,         mAX_PTR_TAG,-        tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD,          unsafeGlobalDynFlags, setUnsafeGlobalDynFlags, @@ -242,7 +234,7 @@         initSDocContext,          -- * Make use of the Cmm CFG-        CfgWeights(..), backendMaintainsCfg+        CfgWeights(..)   ) where  #include "HsVersions.h"@@ -252,12 +244,14 @@ import GHC.Platform import GHC.UniqueSubdir (uniqueSubdir) import PlatformConstants-import Module+import GHC.Types.Module import {-# SOURCE #-} GHC.Driver.Plugins import {-# SOURCE #-} GHC.Driver.Hooks import {-# SOURCE #-} PrelNames ( mAIN )-import {-# SOURCE #-} GHC.Driver.Packages (PackageState, emptyPackageState, PackageDatabase)+import {-# SOURCE #-} GHC.Driver.Packages (PackageState, emptyPackageState, PackageDatabase, mkComponentId) import GHC.Driver.Phases ( Phase(..), phaseInputExt )+import GHC.Driver.Flags+import GHC.Driver.Ways import Config import CliOption import GHC.Driver.CmdLine hiding (WarnReason(..))@@ -270,8 +264,8 @@ import Maybes import MonadUtils import qualified Pretty-import SrcLoc-import BasicTypes       ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf )+import GHC.Types.SrcLoc+import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) import FastString import Fingerprint import FileSettings@@ -279,8 +273,6 @@ import Settings import ToolSettings -import Foreign.C        ( CInt(..) )-import System.IO.Unsafe ( unsafeDupablePerformIO ) import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn                                , getCaretDiagnostic, DumpAction, TraceAction                                , defaultDumpAction, defaultTraceAction )@@ -300,13 +292,11 @@ import Data.Ord import Data.Bits import Data.Char-import Data.Int import Data.List import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set-import Data.Word import System.FilePath import System.Directory import System.Environment (lookupEnv)@@ -401,413 +391,7 @@ -- ----------------------------------------------------------------------------- -- DynFlags -data DumpFlag--- See Note [Updating flag description in the User's Guide] -   -- debugging flags-   = Opt_D_dump_cmm-   | Opt_D_dump_cmm_from_stg-   | Opt_D_dump_cmm_raw-   | Opt_D_dump_cmm_verbose_by_proc-   -- All of the cmm subflags (there are a lot!) automatically-   -- enabled if you run -ddump-cmm-verbose-by-proc-   -- Each flag corresponds to exact stage of Cmm pipeline.-   | Opt_D_dump_cmm_verbose-   -- same as -ddump-cmm-verbose-by-proc but writes each stage-   -- to a separate file (if used with -ddump-to-file)-   | Opt_D_dump_cmm_cfg-   | Opt_D_dump_cmm_cbe-   | Opt_D_dump_cmm_switch-   | Opt_D_dump_cmm_proc-   | Opt_D_dump_cmm_sp-   | Opt_D_dump_cmm_sink-   | Opt_D_dump_cmm_caf-   | Opt_D_dump_cmm_procmap-   | Opt_D_dump_cmm_split-   | Opt_D_dump_cmm_info-   | Opt_D_dump_cmm_cps-   -- end cmm subflags-   | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout.-   | Opt_D_dump_asm-   | Opt_D_dump_asm_native-   | Opt_D_dump_asm_liveness-   | Opt_D_dump_asm_regalloc-   | Opt_D_dump_asm_regalloc_stages-   | Opt_D_dump_asm_conflicts-   | Opt_D_dump_asm_stats-   | Opt_D_dump_asm_expanded-   | Opt_D_dump_llvm-   | Opt_D_dump_core_stats-   | Opt_D_dump_deriv-   | Opt_D_dump_ds-   | Opt_D_dump_ds_preopt-   | Opt_D_dump_foreign-   | Opt_D_dump_inlinings-   | Opt_D_dump_rule_firings-   | Opt_D_dump_rule_rewrites-   | Opt_D_dump_simpl_trace-   | Opt_D_dump_occur_anal-   | Opt_D_dump_parsed-   | Opt_D_dump_parsed_ast-   | Opt_D_dump_rn-   | Opt_D_dump_rn_ast-   | Opt_D_dump_simpl-   | Opt_D_dump_simpl_iterations-   | Opt_D_dump_spec-   | Opt_D_dump_prep-   | Opt_D_dump_stg -- CoreToStg output-   | Opt_D_dump_stg_unarised -- STG after unarise-   | Opt_D_dump_stg_final -- STG after stg2stg-   | Opt_D_dump_call_arity-   | Opt_D_dump_exitify-   | Opt_D_dump_stranal-   | Opt_D_dump_str_signatures-   | Opt_D_dump_cpranal-   | Opt_D_dump_cpr_signatures-   | Opt_D_dump_tc-   | Opt_D_dump_tc_ast-   | Opt_D_dump_types-   | Opt_D_dump_rules-   | Opt_D_dump_cse-   | Opt_D_dump_worker_wrapper-   | Opt_D_dump_rn_trace-   | Opt_D_dump_rn_stats-   | Opt_D_dump_opt_cmm-   | Opt_D_dump_simpl_stats-   | Opt_D_dump_cs_trace -- Constraint solver in type checker-   | Opt_D_dump_tc_trace-   | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker-   | Opt_D_dump_if_trace-   | Opt_D_dump_vt_trace-   | Opt_D_dump_splices-   | Opt_D_th_dec_file-   | Opt_D_dump_BCOs-   | Opt_D_dump_ticked-   | Opt_D_dump_rtti-   | Opt_D_source_stats-   | Opt_D_verbose_stg2stg-   | Opt_D_dump_hi-   | Opt_D_dump_hi_diffs-   | Opt_D_dump_mod_cycles-   | Opt_D_dump_mod_map-   | Opt_D_dump_timings-   | Opt_D_dump_view_pattern_commoning-   | Opt_D_verbose_core2core-   | Opt_D_dump_debug-   | Opt_D_dump_json-   | Opt_D_ppr_debug-   | Opt_D_no_debug_output-   deriving (Eq, Show, Enum)----- | Enumerates the simple on-or-off dynamic flags-data GeneralFlag--- See Note [Updating flag description in the User's Guide]--   = Opt_DumpToFile                     -- ^ Append dump output to files instead of stdout.-   | Opt_D_faststring_stats-   | Opt_D_dump_minimal_imports-   | Opt_DoCoreLinting-   | Opt_DoStgLinting-   | Opt_DoCmmLinting-   | Opt_DoAsmLinting-   | Opt_DoAnnotationLinting-   | Opt_NoLlvmMangler                  -- hidden flag-   | Opt_FastLlvm                       -- hidden flag-   | Opt_NoTypeableBinds--   | Opt_WarnIsError                    -- -Werror; makes warnings fatal-   | Opt_ShowWarnGroups                 -- Show the group a warning belongs to-   | Opt_HideSourcePaths                -- Hide module source/object paths--   | Opt_PrintExplicitForalls-   | Opt_PrintExplicitKinds-   | Opt_PrintExplicitCoercions-   | Opt_PrintExplicitRuntimeReps-   | Opt_PrintEqualityRelations-   | Opt_PrintAxiomIncomps-   | Opt_PrintUnicodeSyntax-   | Opt_PrintExpandedSynonyms-   | Opt_PrintPotentialInstances-   | Opt_PrintTypecheckerElaboration--   -- optimisation opts-   | Opt_CallArity-   | Opt_Exitification-   | Opt_Strictness-   | Opt_LateDmdAnal                    -- #6087-   | Opt_KillAbsence-   | Opt_KillOneShot-   | Opt_FullLaziness-   | Opt_FloatIn-   | Opt_LateSpecialise-   | Opt_Specialise-   | Opt_SpecialiseAggressively-   | Opt_CrossModuleSpecialise-   | Opt_StaticArgumentTransformation-   | Opt_CSE-   | Opt_StgCSE-   | Opt_StgLiftLams-   | Opt_LiberateCase-   | Opt_SpecConstr-   | Opt_SpecConstrKeen-   | Opt_DoLambdaEtaExpansion-   | Opt_IgnoreAsserts-   | Opt_DoEtaReduction-   | Opt_CaseMerge-   | Opt_CaseFolding                    -- Constant folding through case-expressions-   | Opt_UnboxStrictFields-   | Opt_UnboxSmallStrictFields-   | Opt_DictsCheap-   | Opt_EnableRewriteRules             -- Apply rewrite rules during simplification-   | Opt_EnableThSpliceWarnings         -- Enable warnings for TH splices-   | Opt_RegsGraph                      -- do graph coloring register allocation-   | Opt_RegsIterative                  -- do iterative coalescing graph coloring register allocation-   | Opt_PedanticBottoms                -- Be picky about how we treat bottom-   | Opt_LlvmTBAA                       -- Use LLVM TBAA infrastructure for improving AA (hidden flag)-   | Opt_LlvmFillUndefWithGarbage       -- Testing for undef bugs (hidden flag)-   | Opt_IrrefutableTuples-   | Opt_CmmSink-   | Opt_CmmElimCommonBlocks-   | Opt_AsmShortcutting-   | Opt_OmitYields-   | Opt_FunToThunk               -- allow WwLib.mkWorkerArgs to remove all value lambdas-   | Opt_DictsStrict                     -- be strict in argument dictionaries-   | Opt_DmdTxDictSel              -- use a special demand transformer for dictionary selectors-   | Opt_Loopification                  -- See Note [Self-recursive tail calls]-   | Opt_CfgBlocklayout             -- ^ Use the cfg based block layout algorithm.-   | Opt_WeightlessBlocklayout         -- ^ Layout based on last instruction per block.-   | Opt_CprAnal-   | Opt_WorkerWrapper-   | Opt_SolveConstantDicts-   | Opt_AlignmentSanitisation-   | Opt_CatchBottoms-   | Opt_NumConstantFolding--   -- PreInlining is on by default. The option is there just to see how-   -- bad things get if you turn it off!-   | Opt_SimplPreInlining--   -- Interface files-   | Opt_IgnoreInterfacePragmas-   | Opt_OmitInterfacePragmas-   | Opt_ExposeAllUnfoldings-   | Opt_WriteInterface -- forces .hi files to be written even with -fno-code-   | Opt_WriteHie -- generate .hie files--   -- profiling opts-   | Opt_AutoSccsOnIndividualCafs-   | Opt_ProfCountEntries--   -- misc opts-   | Opt_Pp-   | Opt_ForceRecomp-   | Opt_IgnoreOptimChanges-   | Opt_IgnoreHpcChanges-   | Opt_ExcessPrecision-   | Opt_EagerBlackHoling-   | Opt_NoHsMain-   | Opt_SplitSections-   | Opt_StgStats-   | Opt_HideAllPackages-   | Opt_HideAllPluginPackages-   | Opt_PrintBindResult-   | Opt_Haddock-   | Opt_HaddockOptions-   | Opt_BreakOnException-   | Opt_BreakOnError-   | Opt_PrintEvldWithShow-   | Opt_PrintBindContents-   | Opt_GenManifest-   | Opt_EmbedManifest-   | Opt_SharedImplib-   | Opt_BuildingCabalPackage-   | Opt_IgnoreDotGhci-   | Opt_GhciSandbox-   | Opt_GhciHistory-   | Opt_GhciLeakCheck-   | Opt_ValidateHie-   | Opt_LocalGhciHistory-   | Opt_NoIt-   | Opt_HelpfulErrors-   | Opt_DeferTypeErrors-   | Opt_DeferTypedHoles-   | Opt_DeferOutOfScopeVariables-   | Opt_PIC                         -- ^ @-fPIC@-   | Opt_PIE                         -- ^ @-fPIE@-   | Opt_PICExecutable               -- ^ @-pie@-   | Opt_ExternalDynamicRefs-   | Opt_SccProfilingOn-   | Opt_Ticky-   | Opt_Ticky_Allocd-   | Opt_Ticky_LNE-   | Opt_Ticky_Dyn_Thunk-   | Opt_RPath-   | Opt_RelativeDynlibPaths-   | Opt_Hpc-   | Opt_FlatCache-   | Opt_ExternalInterpreter-   | Opt_OptimalApplicativeDo-   | Opt_VersionMacros-   | Opt_WholeArchiveHsLibs-   -- copy all libs into a single folder prior to linking binaries-   -- this should elivate the excessive command line limit restrictions-   -- on windows, by only requiring a single -L argument instead of-   -- one for each dependency.  At the time of this writing, gcc-   -- forwards all -L flags to the collect2 command without using a-   -- response file and as such breaking apart.-   | Opt_SingleLibFolder-   | Opt_KeepCAFs-   | Opt_KeepGoing-   | Opt_ByteCode--   -- output style opts-   | Opt_ErrorSpans -- Include full span info in error messages,-                    -- instead of just the start position.-   | Opt_DeferDiagnostics-   | Opt_DiagnosticsShowCaret -- Show snippets of offending code-   | Opt_PprCaseAsLet-   | Opt_PprShowTicks-   | Opt_ShowHoleConstraints-    -- Options relating to the display of valid hole fits-    -- when generating an error message for a typed hole-    -- See Note [Valid hole fits include] in TcHoleErrors.hs-   | Opt_ShowValidHoleFits-   | Opt_SortValidHoleFits-   | Opt_SortBySizeHoleFits-   | Opt_SortBySubsumHoleFits-   | Opt_AbstractRefHoleFits-   | Opt_UnclutterValidHoleFits-   | Opt_ShowTypeAppOfHoleFits-   | Opt_ShowTypeAppVarsOfHoleFits-   | Opt_ShowDocsOfHoleFits-   | Opt_ShowTypeOfHoleFits-   | Opt_ShowProvOfHoleFits-   | Opt_ShowMatchesOfHoleFits--   | Opt_ShowLoadedModules-   | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals]--   -- Suppress all coercions, them replacing with '...'-   | Opt_SuppressCoercions-   | Opt_SuppressVarKinds-   -- Suppress module id prefixes on variables.-   | Opt_SuppressModulePrefixes-   -- Suppress type applications.-   | Opt_SuppressTypeApplications-   -- Suppress info such as arity and unfoldings on identifiers.-   | Opt_SuppressIdInfo-   -- Suppress separate type signatures in core, but leave types on-   -- lambda bound vars-   | Opt_SuppressUnfoldings-   -- Suppress the details of even stable unfoldings-   | Opt_SuppressTypeSignatures-   -- Suppress unique ids on variables.-   -- Except for uniques, as some simplifier phases introduce new-   -- variables that have otherwise identical names.-   | Opt_SuppressUniques-   | Opt_SuppressStgExts-   | Opt_SuppressTicks     -- Replaces Opt_PprShowTicks-   | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps--   -- temporary flags-   | Opt_AutoLinkPackages-   | Opt_ImplicitImportQualified--   -- keeping stuff-   | Opt_KeepHscppFiles-   | Opt_KeepHiDiffs-   | Opt_KeepHcFiles-   | Opt_KeepSFiles-   | Opt_KeepTmpFiles-   | Opt_KeepRawTokenStream-   | Opt_KeepLlvmFiles-   | Opt_KeepHiFiles-   | Opt_KeepOFiles--   | Opt_BuildDynamicToo--   -- safe haskell flags-   | Opt_DistrustAllPackages-   | Opt_PackageTrust-   | Opt_PluginTrustworthy--   | Opt_G_NoStateHack-   | Opt_G_NoOptCoercion-   deriving (Eq, Show, Enum)---- Check whether a flag should be considered an "optimisation flag"--- for purposes of recompilation avoidance (see--- Note [Ignoring some flag changes] in FlagChecker). Being listed here is--- not a guarantee that the flag has no other effect. We could, and--- perhaps should, separate out the flags that have some minor impact on--- program semantics and/or error behavior (e.g., assertions), but--- then we'd need to go to extra trouble (and an additional flag)--- to allow users to ignore the optimisation level even though that--- means ignoring some change.-optimisationFlags :: EnumSet GeneralFlag-optimisationFlags = EnumSet.fromList-   [ Opt_CallArity-   , Opt_Strictness-   , Opt_LateDmdAnal-   , Opt_KillAbsence-   , Opt_KillOneShot-   , Opt_FullLaziness-   , Opt_FloatIn-   , Opt_LateSpecialise-   , Opt_Specialise-   , Opt_SpecialiseAggressively-   , Opt_CrossModuleSpecialise-   , Opt_StaticArgumentTransformation-   , Opt_CSE-   , Opt_StgCSE-   , Opt_StgLiftLams-   , Opt_LiberateCase-   , Opt_SpecConstr-   , Opt_SpecConstrKeen-   , Opt_DoLambdaEtaExpansion-   , Opt_IgnoreAsserts-   , Opt_DoEtaReduction-   , Opt_CaseMerge-   , Opt_CaseFolding-   , Opt_UnboxStrictFields-   , Opt_UnboxSmallStrictFields-   , Opt_DictsCheap-   , Opt_EnableRewriteRules-   , Opt_RegsGraph-   , Opt_RegsIterative-   , Opt_PedanticBottoms-   , Opt_LlvmTBAA-   , Opt_LlvmFillUndefWithGarbage-   , Opt_IrrefutableTuples-   , Opt_CmmSink-   , Opt_CmmElimCommonBlocks-   , Opt_AsmShortcutting-   , Opt_OmitYields-   , Opt_FunToThunk-   , Opt_DictsStrict-   , Opt_DmdTxDictSel-   , Opt_Loopification-   , Opt_CfgBlocklayout-   , Opt_WeightlessBlocklayout-   , Opt_CprAnal-   , Opt_WorkerWrapper-   , Opt_SolveConstantDicts-   , Opt_CatchBottoms-   , Opt_IgnoreAsserts-   ]---- | Used when outputting warnings: if a reason is given, it is--- displayed. If a warning isn't controlled by a flag, this is made--- explicit at the point of use.-data WarnReason-  = NoReason-  -- | Warning was enabled with the flag-  | Reason !WarningFlag-  -- | Warning was made an error because of -Werror or -Werror=WarningFlag-  | ErrReason !(Maybe WarningFlag)-  deriving Show- -- | Used to differentiate the scope an include needs to apply to. -- We have to split the include paths to avoid accidentally forcing recursive -- includes since -I overrides the system search paths. See #14312.@@ -835,107 +419,6 @@ flattenIncludes :: IncludeSpecs -> [String] flattenIncludes specs = includePathsQuote specs ++ includePathsGlobal specs -instance Outputable WarnReason where-  ppr = text . show--instance ToJson WarnReason where-  json NoReason = JSNull-  json (Reason wf) = JSString (show wf)-  json (ErrReason Nothing) = JSString "Opt_WarnIsError"-  json (ErrReason (Just wf)) = JSString (show wf)--data WarningFlag =--- See Note [Updating flag description in the User's Guide]-     Opt_WarnDuplicateExports-   | Opt_WarnDuplicateConstraints-   | Opt_WarnRedundantConstraints-   | Opt_WarnHiShadows-   | Opt_WarnImplicitPrelude-   | Opt_WarnIncompletePatterns-   | Opt_WarnIncompleteUniPatterns-   | Opt_WarnIncompletePatternsRecUpd-   | Opt_WarnOverflowedLiterals-   | Opt_WarnEmptyEnumerations-   | Opt_WarnMissingFields-   | Opt_WarnMissingImportList-   | Opt_WarnMissingMethods-   | Opt_WarnMissingSignatures-   | Opt_WarnMissingLocalSignatures-   | Opt_WarnNameShadowing-   | Opt_WarnOverlappingPatterns-   | Opt_WarnTypeDefaults-   | Opt_WarnMonomorphism-   | Opt_WarnUnusedTopBinds-   | Opt_WarnUnusedLocalBinds-   | Opt_WarnUnusedPatternBinds-   | Opt_WarnUnusedImports-   | Opt_WarnUnusedMatches-   | Opt_WarnUnusedTypePatterns-   | Opt_WarnUnusedForalls-   | Opt_WarnUnusedRecordWildcards-   | Opt_WarnRedundantRecordWildcards-   | Opt_WarnWarningsDeprecations-   | Opt_WarnDeprecatedFlags-   | Opt_WarnMissingMonadFailInstances -- since 8.0, has no effect since 8.8-   | Opt_WarnSemigroup -- since 8.0-   | Opt_WarnDodgyExports-   | Opt_WarnDodgyImports-   | Opt_WarnOrphans-   | Opt_WarnAutoOrphans-   | Opt_WarnIdentities-   | Opt_WarnTabs-   | Opt_WarnUnrecognisedPragmas-   | Opt_WarnDodgyForeignImports-   | Opt_WarnUnusedDoBind-   | Opt_WarnWrongDoBind-   | Opt_WarnAlternativeLayoutRuleTransitional-   | Opt_WarnUnsafe-   | Opt_WarnSafe-   | Opt_WarnTrustworthySafe-   | Opt_WarnMissedSpecs-   | Opt_WarnAllMissedSpecs-   | Opt_WarnUnsupportedCallingConventions-   | Opt_WarnUnsupportedLlvmVersion-   | Opt_WarnMissedExtraSharedLib-   | Opt_WarnInlineRuleShadowing-   | Opt_WarnTypedHoles-   | Opt_WarnPartialTypeSignatures-   | Opt_WarnMissingExportedSignatures-   | Opt_WarnUntickedPromotedConstructors-   | Opt_WarnDerivingTypeable-   | Opt_WarnDeferredTypeErrors-   | Opt_WarnDeferredOutOfScopeVariables-   | Opt_WarnNonCanonicalMonadInstances   -- since 8.0-   | Opt_WarnNonCanonicalMonadFailInstances   -- since 8.0, removed 8.8-   | Opt_WarnNonCanonicalMonoidInstances  -- since 8.0-   | Opt_WarnMissingPatternSynonymSignatures -- since 8.0-   | Opt_WarnUnrecognisedWarningFlags     -- since 8.0-   | Opt_WarnSimplifiableClassConstraints -- Since 8.2-   | Opt_WarnCPPUndef                     -- Since 8.2-   | Opt_WarnUnbangedStrictPatterns       -- Since 8.2-   | Opt_WarnMissingHomeModules           -- Since 8.2-   | Opt_WarnPartialFields                -- Since 8.4-   | Opt_WarnMissingExportList-   | Opt_WarnInaccessibleCode-   | Opt_WarnStarIsType                   -- Since 8.6-   | Opt_WarnStarBinder                   -- Since 8.6-   | Opt_WarnImplicitKindVars             -- Since 8.6-   | Opt_WarnSpaceAfterBang-   | Opt_WarnMissingDerivingStrategies    -- Since 8.8-   | Opt_WarnPrepositiveQualifiedModule   -- Since TBD-   | Opt_WarnUnusedPackages               -- Since 8.10-   | Opt_WarnInferredSafeImports          -- Since 8.10-   | Opt_WarnMissingSafeHaskellMode       -- Since 8.10-   | Opt_WarnCompatUnqualifiedImports     -- Since 8.10-   | Opt_WarnDerivingDefaults-   deriving (Eq, Show, Enum)--data Language = Haskell98 | Haskell2010-   deriving (Eq, Enum, Show)--instance Outputable Language where-    ppr = text . show- -- | The various Safe Haskell modes data SafeHaskellMode    = Sf_None          -- ^ inferred unsafe@@ -1021,7 +504,7 @@                                         --   by the assembler code generator (0 to disable)   liberateCaseThreshold :: Maybe Int,   -- ^ Threshold for LiberateCase   floatLamArgs          :: Maybe Int,   -- ^ Arg count for lambda floating-                                        --   See CoreMonad.FloatOutSwitches+                                        --   See GHC.Core.Op.Monad.FloatOutSwitches    liftLamsRecArgs       :: Maybe Int,   -- ^ Maximum number of arguments after lambda lifting a                                         --   recursive function.@@ -1046,7 +529,7 @@   thisUnitIdInsts_      :: Maybe [(ModuleName, Module)],    -- ways-  ways                  :: [Way],       -- ^ Way flags from the command line+  ways                  :: Set Way,     -- ^ Way flags from the command line   buildTag              :: String,      -- ^ The global \"way\" (e.g. \"p\" for prof)    -- For object splitting@@ -1366,12 +849,6 @@             ",likelyCondWeight=900,unlikelyCondWeight=300" ++             ",infoTablePenalty=300,backEdgeBonus=400" -backendMaintainsCfg :: DynFlags -> Bool-backendMaintainsCfg dflags = case (platformArch $ targetPlatform dflags) of-    -- ArchX86 -- Should work but not tested so disabled currently.-    ArchX86_64 -> True-    _otherwise -> False- class HasDynFlags m where     getDynFlags :: m DynFlags @@ -1710,143 +1187,6 @@ positionIndependent :: DynFlags -> Bool positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags --------------------------------------------------------------------------------- Ways---- The central concept of a "way" is that all objects in a given--- program must be compiled in the same "way".  Certain options change--- parameters of the virtual machine, eg. profiling adds an extra word--- to the object header, so profiling objects cannot be linked with--- non-profiling objects.---- After parsing the command-line options, we determine which "way" we--- are building - this might be a combination way, eg. profiling+threaded.---- We then find the "build-tag" associated with this way, and this--- becomes the suffix used to find .hi files and libraries used in--- this compilation.--data Way-  = WayCustom String -- for GHC API clients building custom variants-  | WayThreaded-  | WayDebug-  | WayProf-  | WayEventLog-  | WayDyn-  deriving (Eq, Ord, Show)--allowed_combination :: [Way] -> Bool-allowed_combination way = and [ x `allowedWith` y-                              | x <- way, y <- way, x < y ]-  where-        -- Note ordering in these tests: the left argument is-        -- <= the right argument, according to the Ord instance-        -- on Way above.--        -- dyn is allowed with everything-        _ `allowedWith` WayDyn                  = True-        WayDyn `allowedWith` _                  = True--        -- debug is allowed with everything-        _ `allowedWith` WayDebug                = True-        WayDebug `allowedWith` _                = True--        (WayCustom {}) `allowedWith` _          = True-        WayThreaded `allowedWith` WayProf       = True-        WayThreaded `allowedWith` WayEventLog   = True-        WayProf     `allowedWith` WayEventLog   = True-        _ `allowedWith` _                       = False--mkBuildTag :: [Way] -> String-mkBuildTag ways = concat (intersperse "_" (map wayTag ways))--wayTag :: Way -> String-wayTag (WayCustom xs) = xs-wayTag WayThreaded = "thr"-wayTag WayDebug    = "debug"-wayTag WayDyn      = "dyn"-wayTag WayProf     = "p"-wayTag WayEventLog = "l"--wayRTSOnly :: Way -> Bool-wayRTSOnly (WayCustom {}) = False-wayRTSOnly WayThreaded = True-wayRTSOnly WayDebug    = True-wayRTSOnly WayDyn      = False-wayRTSOnly WayProf     = False-wayRTSOnly WayEventLog = True--wayDesc :: Way -> String-wayDesc (WayCustom xs) = xs-wayDesc WayThreaded = "Threaded"-wayDesc WayDebug    = "Debug"-wayDesc WayDyn      = "Dynamic"-wayDesc WayProf     = "Profiling"-wayDesc WayEventLog = "RTS Event Logging"---- Turn these flags on when enabling this way-wayGeneralFlags :: Platform -> Way -> [GeneralFlag]-wayGeneralFlags _ (WayCustom {}) = []-wayGeneralFlags _ WayThreaded = []-wayGeneralFlags _ WayDebug    = []-wayGeneralFlags _ WayDyn      = [Opt_PIC, Opt_ExternalDynamicRefs]-    -- We could get away without adding -fPIC when compiling the-    -- modules of a program that is to be linked with -dynamic; the-    -- program itself does not need to be position-independent, only-    -- the libraries need to be.  HOWEVER, GHCi links objects into a-    -- .so before loading the .so using the system linker.  Since only-    -- PIC objects can be linked into a .so, we have to compile even-    -- modules of the main program with -fPIC when using -dynamic.-wayGeneralFlags _ WayProf     = [Opt_SccProfilingOn]-wayGeneralFlags _ WayEventLog = []---- Turn these flags off when enabling this way-wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag]-wayUnsetGeneralFlags _ (WayCustom {}) = []-wayUnsetGeneralFlags _ WayThreaded = []-wayUnsetGeneralFlags _ WayDebug    = []-wayUnsetGeneralFlags _ WayDyn      = [-- There's no point splitting-                                      -- when we're going to be dynamically-                                      -- linking. Plus it breaks compilation-                                      -- on OSX x86.-                                      Opt_SplitSections]-wayUnsetGeneralFlags _ WayProf     = []-wayUnsetGeneralFlags _ WayEventLog = []--wayOptc :: Platform -> Way -> [String]-wayOptc _ (WayCustom {}) = []-wayOptc platform WayThreaded = case platformOS platform of-                               OSOpenBSD -> ["-pthread"]-                               OSNetBSD  -> ["-pthread"]-                               _         -> []-wayOptc _ WayDebug      = []-wayOptc _ WayDyn        = []-wayOptc _ WayProf       = ["-DPROFILING"]-wayOptc _ WayEventLog   = ["-DTRACING"]--wayOptl :: Platform -> Way -> [String]-wayOptl _ (WayCustom {}) = []-wayOptl platform WayThreaded =-        case platformOS platform of-        -- N.B. FreeBSD cc throws a warning if we pass -pthread without-        -- actually using any pthread symbols.-        OSFreeBSD  -> ["-pthread", "-Wno-unused-command-line-argument"]-        OSOpenBSD  -> ["-pthread"]-        OSNetBSD   -> ["-pthread"]-        _          -> []-wayOptl _ WayDebug      = []-wayOptl _ WayDyn        = []-wayOptl _ WayProf       = []-wayOptl _ WayEventLog   = []--wayOptP :: Platform -> Way -> [String]-wayOptP _ (WayCustom {}) = []-wayOptP _ WayThreaded = []-wayOptP _ WayDebug    = []-wayOptP _ WayDyn      = []-wayOptP _ WayProf     = ["-DPROFILING"]-wayOptP _ WayEventLog = ["-DTRACING"]- whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m () whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ()) @@ -2039,7 +1379,7 @@         pkgDatabase             = Nothing,         pkgState                = emptyPackageState,         ways                    = defaultWays mySettings,-        buildTag                = mkBuildTag (defaultWays mySettings),+        buildTag                = waysTag (defaultWays mySettings),         splitInfo               = Nothing,          ghcNameVersion = sGhcNameVersion mySettings,@@ -2145,26 +1485,10 @@         cfgWeightInfo = defaultCfgWeights       } -defaultWays :: Settings -> [Way]+defaultWays :: Settings -> Set Way defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings)-                       then [WayDyn]-                       else []--interpWays :: [Way]-interpWays-  | dynamicGhc = [WayDyn]-  | rtsIsProfiled = [WayProf]-  | otherwise = []--interpreterProfiled :: DynFlags -> Bool-interpreterProfiled dflags-  | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags-  | otherwise = rtsIsProfiled--interpreterDynamic :: DynFlags -> Bool-interpreterDynamic dflags-  | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags-  | otherwise = dynamicGhc+                       then Set.singleton WayDyn+                       else Set.empty  -------------------------------------------------------------------------- --@@ -2636,13 +1960,14 @@  thisComponentId :: DynFlags -> ComponentId thisComponentId dflags =-  case thisComponentId_ dflags of-    Just cid -> cid+  let pkgstate = pkgState dflags+  in case thisComponentId_ dflags of+    Just (ComponentId raw _) -> mkComponentId pkgstate raw     Nothing  ->       case thisUnitIdInsts_ dflags of         Just _  ->           throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")-        Nothing -> ComponentId (unitIdFS (thisPackage dflags))+        Nothing -> mkComponentId pkgstate (unitIdFS (thisPackage dflags))  thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)] thisUnitIdInsts dflags =@@ -2679,7 +2004,7 @@  setComponentId :: String -> DynFlags -> DynFlags setComponentId s d =-    d { thisComponentId_ = Just (ComponentId (fsLit s)) }+    d { thisComponentId_ = Just (ComponentId (fsLit s) Nothing) }  addPluginModuleName :: String -> DynFlags -> DynFlags addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }@@ -2822,7 +2147,7 @@    unless (allowed_combination theWays) $ liftIO $       throwGhcExceptionIO (CmdLineError ("combination not supported: " ++-                               intercalate "/" (map wayDesc theWays)))+                               intercalate "/" (map wayDesc (Set.toAscList theWays))))    let chooseOutput         | isJust (outputFile dflags3)          -- Only iff user specified -o ...@@ -2855,11 +2180,9 @@  updateWays :: DynFlags -> DynFlags updateWays dflags-    = let theWays = sort $ nub $ ways dflags-      in dflags {-             ways        = theWays,-             buildTag    = mkBuildTag (filter (not . wayRTSOnly) theWays)-         }+    = dflags {+        buildTag = waysTag (Set.filter (not . wayRTSOnly) (ways dflags))+      }  -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode.@@ -3246,6 +2569,7 @@   , make_ord_flag defGhcFlag "ghcversion-file"      (hasArg addGhcVersionFile)   , make_ord_flag defGhcFlag "main-is"              (SepArg setMainIs)   , make_ord_flag defGhcFlag "haddock"              (NoArg (setGeneralFlag Opt_Haddock))+  , make_ord_flag defGhcFlag "no-haddock"           (NoArg (unSetGeneralFlag Opt_Haddock))   , make_ord_flag defGhcFlag "haddock-opts"         (hasArg addHaddockOpts)   , make_ord_flag defGhcFlag "hpcdir"               (SepArg setOptHpcDir)   , make_ord_flag defGhciFlag "ghci-script"         (hasArg addGhciScript)@@ -4243,8 +3567,6 @@   flagGhciSpec "implicit-import-qualified"    Opt_ImplicitImportQualified,   flagSpec "irrefutable-tuples"               Opt_IrrefutableTuples,   flagSpec "keep-going"                       Opt_KeepGoing,-  flagSpec "kill-absence"                     Opt_KillAbsence,-  flagSpec "kill-one-shot"                    Opt_KillOneShot,   flagSpec "late-dmd-anal"                    Opt_LateDmdAnal,   flagSpec "late-specialise"                  Opt_LateSpecialise,   flagSpec "liberate-case"                    Opt_LiberateCase,@@ -4981,21 +4303,6 @@            , LangExt.UnicodeSyntax            , LangExt.UnliftedFFITypes ] -foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt---- | Was the runtime system built with profiling enabled?-rtsIsProfiled :: Bool-rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0---- Consult the RTS to find whether GHC itself has been built with--- dynamic linking.  This can't be statically known at compile-time,--- because we build both the static and dynamic versions together with--- -dynamic-too.-foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO CInt--dynamicGhc :: Bool-dynamicGhc = unsafeDupablePerformIO rtsIsDynamicIO /= 0- setWarnSafe :: Bool -> DynP () setWarnSafe True  = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l }) setWarnSafe False = return ()@@ -5082,7 +4389,7 @@  addWay' :: Way -> DynFlags -> DynFlags addWay' w dflags0 = let platform = targetPlatform dflags0-                        dflags1 = dflags0 { ways = w : ways dflags0 }+                        dflags1 = dflags0 { ways = Set.insert w (ways dflags0) }                         dflags2 = foldr setGeneralFlag' dflags1                                         (wayGeneralFlags platform w)                         dflags3 = foldr unSetGeneralFlag' dflags2@@ -5090,7 +4397,7 @@                     in dflags3  removeWayDyn :: DynP ()-removeWayDyn = upd (\dfs -> dfs { ways = filter (WayDyn /=) (ways dfs) })+removeWayDyn = upd (\dfs -> dfs { ways = Set.filter (WayDyn /=) (ways dfs) })  -------------------------- setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP ()@@ -5513,7 +4820,7 @@       -- correctly.  They need to reference data in the Haskell       -- objects, but can't without -fPIC.  See       -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code-       | gopt Opt_PIC dflags || WayDyn `elem` ways dflags ->+       | gopt Opt_PIC dflags || WayDyn `Set.member` ways dflags ->           ["-fPIC", "-U__PIC__", "-D__PIC__"]       -- gcc may be configured to have PIC on by default, let's be       -- explicit here, see #15847@@ -5588,9 +4895,9 @@        -- Whether or not GHC compiles libraries as dynamic by default        ("Dynamic by default",          showBool $ dYNAMIC_BY_DEFAULT dflags),        -- Whether or not GHC was compiled using -dynamic-       ("GHC Dynamic",                 showBool dynamicGhc),+       ("GHC Dynamic",                 showBool hostIsDynamic),        -- Whether or not GHC was compiled using -prof-       ("GHC Profiled",                showBool rtsIsProfiled),+       ("GHC Profiled",                showBool hostIsProfiled),        ("Debug on",                    showBool debugIsOn),        ("LibDir",                      topDir dflags),        -- The path of the global package database used by GHC@@ -5607,13 +4914,11 @@ #include "GHCConstantsHaskellWrappers.hs"  bLOCK_SIZE_W :: DynFlags -> Int-bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags--wORD_SIZE_IN_BITS :: DynFlags -> Int-wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8+bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` platformWordSizeInBytes platform+   where platform = targetPlatform dflags -wordAlignment :: DynFlags -> Alignment-wordAlignment dflags = alignmentOf (wORD_SIZE dflags)+wordAlignment :: Platform -> Alignment+wordAlignment platform = alignmentOf (platformWordSizeInBytes platform)  tAG_MASK :: DynFlags -> Int tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1@@ -5621,22 +4926,6 @@ mAX_PTR_TAG :: DynFlags -> Int mAX_PTR_TAG = tAG_MASK --- Might be worth caching these in targetPlatform?-tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer-tARGET_MIN_INT dflags-    = case platformWordSize (targetPlatform dflags) of-      PW4 -> toInteger (minBound :: Int32)-      PW8 -> toInteger (minBound :: Int64)-tARGET_MAX_INT dflags-    = case platformWordSize (targetPlatform dflags) of-      PW4 -> toInteger (maxBound :: Int32)-      PW8 -> toInteger (maxBound :: Int64)-tARGET_MAX_WORD dflags-    = case platformWordSize (targetPlatform dflags) of-      PW4 -> toInteger (maxBound :: Word32)-      PW8 -> toInteger (maxBound :: Word64)-- {- ----------------------------------------------------------------------------- Note [DynFlags consistency] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -5711,10 +5000,10 @@   | LinkInMemory <- ghcLink dflags  , not (gopt Opt_ExternalInterpreter dflags)- , rtsIsProfiled+ , hostIsProfiled  , isObjectTarget (hscTarget dflags)- , WayProf `notElem` ways dflags-    = loop dflags{ways = WayProf : ways dflags}+ , WayProf `Set.notMember` ways dflags+    = loop dflags{ways = Set.insert WayProf (ways dflags)}          "Enabling -prof, because -fobject-code is enabled and GHCi is profiled"   | otherwise = (dflags, [])@@ -5910,7 +5199,6 @@   , sdocLineLength                  = pprCols dflags   , sdocCanUseUnicode               = useUnicode dflags   , sdocHexWordLiterals             = gopt Opt_HexWordLiterals dflags-  , sdocDebugLevel                  = debugLevel dflags   , sdocPprDebug                    = dopt Opt_D_ppr_debug dflags   , sdocPrintUnicodeSyntax          = gopt Opt_PrintUnicodeSyntax dflags   , sdocPrintCaseAsLet              = gopt Opt_PprCaseAsLet dflags
compiler/GHC/Driver/Session.hs-boot view
@@ -5,8 +5,6 @@ import {-# SOURCE #-} Outputable  data DynFlags-data DumpFlag-data GeneralFlag  targetPlatform           :: DynFlags -> Platform pprUserLength            :: DynFlags -> Int
compiler/GHC/Driver/Types.hs view
@@ -159,46 +159,47 @@ import GHC.Runtime.Interpreter.Types (Interp) import GHC.ForeignSrcLang -import UniqFM+import GHC.Types.Unique.FM import GHC.Hs-import RdrName-import Avail-import Module-import InstEnv          ( InstEnv, ClsInst, identicalClsInstHead )-import FamInstEnv+import GHC.Types.Name.Reader+import GHC.Types.Avail+import GHC.Types.Module+import GHC.Core.InstEnv ( InstEnv, ClsInst, identicalClsInstHead )+import GHC.Core.FamInstEnv import GHC.Core         ( CoreProgram, RuleBase, CoreRule )-import Name-import NameEnv-import VarSet-import Var-import Id-import IdInfo           ( IdDetails(..), RecSelParent(..))-import Type+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Var.Set+import GHC.Types.Var+import GHC.Types.Id+import GHC.Types.Id.Info ( IdDetails(..), RecSelParent(..))+import GHC.Core.Type  import ApiAnnotation    ( ApiAnns )-import Annotations      ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )-import Class-import TyCon-import CoAxiom-import ConLike-import DataCon-import PatSyn+import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.PatSyn import PrelNames        ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) import TysWiredIn import GHC.Driver.Packages hiding  ( Version(..) ) import GHC.Driver.CmdLine import GHC.Driver.Session-import GHC.Runtime.Linker.Types      ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) )-import GHC.Driver.Phases     ( Phase, HscSource(..), hscSourceString-                        , isHsBootOrSig, isHsigFile )+import GHC.Runtime.Linker.Types ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) )+import GHC.Driver.Phases+   ( Phase, HscSource(..), hscSourceString+   , isHsBootOrSig, isHsigFile ) import qualified GHC.Driver.Phases as Phase-import BasicTypes+import GHC.Types.Basic import GHC.Iface.Syntax import Maybes import Outputable-import SrcLoc-import Unique-import UniqDFM+import GHC.Types.SrcLoc+import GHC.Types.Unique+import GHC.Types.Unique.DFM import FastString import StringBuffer     ( StringBuffer ) import Fingerprint@@ -206,10 +207,10 @@ import Bag import Binary import ErrUtils-import NameCache+import GHC.Types.Name.Cache import GHC.Platform import Util-import UniqDSet+import GHC.Types.Unique.DSet import GHC.Serialized   ( Serialized ) import qualified GHC.LanguageExtensions as LangExt @@ -1610,7 +1611,7 @@      global.   (b) Having an External Name is important because of Note-     [GlobalRdrEnv shadowing] in RdrName+     [GlobalRdrEnv shadowing] in GHC.Types.Names.RdrName   (c) Their types are tidied. This is important, because :info may ask      to look at them, and :info expects the things it looks up to have@@ -2007,7 +2008,7 @@         -- database!      = False      | Just pkgid <- mb_pkgid-     , searchPackageId dflags pkgid `lengthIs` 1+     , searchPackageId (pkgState dflags) pkgid `lengthIs` 1         -- this says: we are given a package pkg-0.1@MMM, are there only one         -- exposed packages whose package ID is pkg-0.1?      = False@@ -2513,7 +2514,7 @@                         -- ^ All the plugins used while compiling this module.          }   deriving( Eq )-        -- Equality used only for old/new comparison in GHC.Iface.Utils.addFingerprints+        -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints         -- See 'TcRnTypes.ImportAvails' for details on dependencies.  instance Binary Dependencies where
+ compiler/GHC/Driver/Ways.hs view
@@ -0,0 +1,190 @@+-- | Ways+--+-- The central concept of a "way" is that all objects in a given+-- program must be compiled in the same "way". Certain options change+-- parameters of the virtual machine, eg. profiling adds an extra word+-- to the object header, so profiling objects cannot be linked with+-- non-profiling objects.+--+-- After parsing the command-line options, we determine which "way" we+-- are building - this might be a combination way, eg. profiling+threaded.+--+-- There are two kinds of ways:+--    - RTS only: only affect the runtime system (RTS) and don't affect code+--    generation (e.g. threaded, debug)+--    - Full ways: affect code generation and the RTS (e.g. profiling, dynamic+--    linking)+--+-- We then find the "build-tag" associated with this way, and this+-- becomes the suffix used to find .hi files and libraries used in+-- this compilation.+module GHC.Driver.Ways+   ( Way(..)+   , allowed_combination+   , wayGeneralFlags+   , wayUnsetGeneralFlags+   , wayOptc+   , wayOptl+   , wayOptP+   , wayDesc+   , wayRTSOnly+   , wayTag+   , waysTag+   -- * Host GHC ways+   , hostFullWays+   , hostIsProfiled+   , hostIsDynamic+   )+where++import GhcPrelude+import GHC.Platform+import GHC.Driver.Flags++import qualified Data.Set as Set+import Data.Set (Set)+import Data.List (intersperse)+import System.IO.Unsafe ( unsafeDupablePerformIO )++-- | A way+--+-- Don't change the constructor order as it us used by `waysTag` to create a+-- unique tag (e.g. thr_debug_p) which is expected by other tools (e.g. Cabal).+data Way+  = WayCustom String -- ^ for GHC API clients building custom variants+  | WayThreaded      -- ^ (RTS only) Multithreaded runtime system+  | WayDebug         -- ^ Debugging, enable trace messages and extra checks+  | WayProf          -- ^ Profiling, enable cost-centre stacks and profiling reports+  | WayEventLog      -- ^ (RTS only) enable event logging+  | WayDyn           -- ^ Dynamic linking+  deriving (Eq, Ord, Show)+++-- | Check if a combination of ways is allowed+allowed_combination :: Set Way -> Bool+allowed_combination ways = not disallowed+  where+   disallowed = or [ Set.member ways x && Set.member ways y+                   | (x,y) <- couples+                   ]+   -- List of disallowed couples of ways+   couples = [] -- we don't have any disallowed combination of ways nowadays++-- | Unique build-tag associated to a list of ways+waysTag :: Set Way -> String+waysTag = concat . intersperse "_" . map wayTag . Set.toAscList++-- | Unique build-tag associated to a way+wayTag :: Way -> String+wayTag (WayCustom xs) = xs+wayTag WayThreaded    = "thr"+wayTag WayDebug       = "debug"+wayTag WayDyn         = "dyn"+wayTag WayProf        = "p"+wayTag WayEventLog    = "l"++-- | Return true for ways that only impact the RTS, not the generated code+wayRTSOnly :: Way -> Bool+wayRTSOnly (WayCustom {}) = False+wayRTSOnly WayDyn         = False+wayRTSOnly WayProf        = False+wayRTSOnly WayThreaded    = True+wayRTSOnly WayDebug       = True+wayRTSOnly WayEventLog    = True++wayDesc :: Way -> String+wayDesc (WayCustom xs) = xs+wayDesc WayThreaded    = "Threaded"+wayDesc WayDebug       = "Debug"+wayDesc WayDyn         = "Dynamic"+wayDesc WayProf        = "Profiling"+wayDesc WayEventLog    = "RTS Event Logging"++-- | Turn these flags on when enabling this way+wayGeneralFlags :: Platform -> Way -> [GeneralFlag]+wayGeneralFlags _ (WayCustom {}) = []+wayGeneralFlags _ WayThreaded = []+wayGeneralFlags _ WayDebug    = []+wayGeneralFlags _ WayDyn      = [Opt_PIC, Opt_ExternalDynamicRefs]+    -- We could get away without adding -fPIC when compiling the+    -- modules of a program that is to be linked with -dynamic; the+    -- program itself does not need to be position-independent, only+    -- the libraries need to be.  HOWEVER, GHCi links objects into a+    -- .so before loading the .so using the system linker.  Since only+    -- PIC objects can be linked into a .so, we have to compile even+    -- modules of the main program with -fPIC when using -dynamic.+wayGeneralFlags _ WayProf     = [Opt_SccProfilingOn]+wayGeneralFlags _ WayEventLog = []++-- | Turn these flags off when enabling this way+wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag]+wayUnsetGeneralFlags _ (WayCustom {}) = []+wayUnsetGeneralFlags _ WayThreaded = []+wayUnsetGeneralFlags _ WayDebug    = []+wayUnsetGeneralFlags _ WayDyn      = [Opt_SplitSections]+   -- There's no point splitting when we're going to be dynamically linking.+   -- Plus it breaks compilation on OSX x86.+wayUnsetGeneralFlags _ WayProf     = []+wayUnsetGeneralFlags _ WayEventLog = []++-- | Pass these options to the C compiler when enabling this way+wayOptc :: Platform -> Way -> [String]+wayOptc _ (WayCustom {}) = []+wayOptc platform WayThreaded = case platformOS platform of+                               OSOpenBSD -> ["-pthread"]+                               OSNetBSD  -> ["-pthread"]+                               _         -> []+wayOptc _ WayDebug      = []+wayOptc _ WayDyn        = []+wayOptc _ WayProf       = ["-DPROFILING"]+wayOptc _ WayEventLog   = ["-DTRACING"]++-- | Pass these options to linker when enabling this way+wayOptl :: Platform -> Way -> [String]+wayOptl _ (WayCustom {}) = []+wayOptl platform WayThreaded =+   case platformOS platform of+   -- N.B. FreeBSD cc throws a warning if we pass -pthread without+   -- actually using any pthread symbols.+   OSFreeBSD  -> ["-pthread", "-Wno-unused-command-line-argument"]+   OSOpenBSD  -> ["-pthread"]+   OSNetBSD   -> ["-pthread"]+   _          -> []+wayOptl _ WayDebug      = []+wayOptl _ WayDyn        = []+wayOptl _ WayProf       = []+wayOptl _ WayEventLog   = []++-- | Pass these options to the preprocessor when enabling this way+wayOptP :: Platform -> Way -> [String]+wayOptP _ (WayCustom {}) = []+wayOptP _ WayThreaded = []+wayOptP _ WayDebug    = []+wayOptP _ WayDyn      = []+wayOptP _ WayProf     = ["-DPROFILING"]+wayOptP _ WayEventLog = ["-DTRACING"]+++-- | Consult the RTS to find whether it has been built with profiling enabled.+hostIsProfiled :: Bool+hostIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0++foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO Int++-- | Consult the RTS to find whether GHC itself has been built with+-- dynamic linking.  This can't be statically known at compile-time,+-- because we build both the static and dynamic versions together with+-- -dynamic-too.+hostIsDynamic :: Bool+hostIsDynamic = unsafeDupablePerformIO rtsIsDynamicIO /= 0++foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO Int++-- | Return host "full" ways (i.e. ways that have an impact on the compilation,+-- not RTS only ways). These ways must be used when compiling codes targeting+-- the internal interpreter.+hostFullWays :: Set Way+hostFullWays = Set.unions+   [ if hostIsDynamic  then Set.singleton WayDyn  else Set.empty+   , if hostIsProfiled then Set.singleton WayProf else Set.empty+   ]
compiler/GHC/Hs.hs view
@@ -46,15 +46,15 @@ import GHC.Hs.Extension import GHC.Hs.Pat import GHC.Hs.Types-import BasicTypes       ( Fixity, WarningTxt )+import GHC.Types.Basic ( Fixity, WarningTxt ) import GHC.Hs.Utils import GHC.Hs.Doc import GHC.Hs.Instances () -- For Data instances  -- others: import Outputable-import SrcLoc-import Module           ( ModuleName )+import GHC.Types.SrcLoc+import GHC.Types.Module ( ModuleName )  -- libraries: import Data.Data hiding ( Fixity )
compiler/GHC/Hs/Binds.hs view
@@ -34,12 +34,12 @@ import GHC.Hs.Types import GHC.Core import TcEvidence-import Type-import NameSet-import BasicTypes+import GHC.Core.Type+import GHC.Types.Name.Set+import GHC.Types.Basic import Outputable-import SrcLoc-import Var+import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Var import Bag import FastString import BooleanFormula (LBooleanFormula)@@ -276,9 +276,7 @@   | VarBind {         var_ext    :: XVarBind idL idR,         var_id     :: IdP idL,-        var_rhs    :: LHsExpr idR,   -- ^ Located only for consistency-        var_inline :: Bool           -- ^ True <=> inline this binding regardless-                                     -- (used for implication constraints only)+        var_rhs    :: LHsExpr idR    -- ^ Located only for consistency     }    -- | Abstraction Bindings@@ -994,7 +992,7 @@          -- For details on above see note [Api annotations] in ApiAnnotation   | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass)-                  -- Note [Pragma source text] in BasicTypes+                  -- Note [Pragma source text] in GHC.Types.Basic          -- | A minimal complete definition pragma         --@@ -1007,7 +1005,7 @@         -- For details on above see note [Api annotations] in ApiAnnotation   | MinimalSig (XMinimalSig pass)                SourceText (LBooleanFormula (Located (IdP pass)))-               -- Note [Pragma source text] in BasicTypes+               -- Note [Pragma source text] in GHC.Types.Basic          -- | A "set cost centre" pragma for declarations         --@@ -1018,7 +1016,7 @@         -- > {-# SCC funName "cost_centre_name" #-}    | SCCFunSig  (XSCCFunSig pass)-               SourceText      -- Note [Pragma source text] in BasicTypes+               SourceText      -- Note [Pragma source text] in GHC.Types.Basic                (Located (IdP pass))  -- Function name                (Maybe (Located StringLiteral))        -- | A complete match pragma
compiler/GHC/Hs/Decls.hs view
@@ -103,19 +103,19 @@ import GHC.Hs.Binds import GHC.Hs.Types import GHC.Hs.Doc-import TyCon-import BasicTypes-import Coercion-import ForeignCall+import GHC.Core.TyCon+import GHC.Types.Basic+import GHC.Core.Coercion+import GHC.Types.ForeignCall import GHC.Hs.Extension-import NameSet+import GHC.Types.Name.Set  -- others:-import Class+import GHC.Core.Class import Outputable import Util-import SrcLoc-import Type+import GHC.Types.SrcLoc+import GHC.Core.Type  import Bag import Maybes@@ -438,7 +438,7 @@    to ensure correct module and provenance is set  These are the two places that we have to conjure up the magic derived-names.  (The actual magic is in OccName.mkWorkerOcc, etc.)+names.  (The actual magic is in GHC.Types.Name.Occurrence.mkWorkerOcc, etc.)  Default methods ~~~~~~~~~~~~~~~@@ -447,7 +447,7 @@   - If there is a default method name at all, it's recorded in    the ClassOpSig (in GHC.Hs.Binds), in the DefMethInfo field.-   (DefMethInfo is defined in Class.hs)+   (DefMethInfo is defined in GHC.Core.Class)  Source-code class decls and interface-code class decls are treated subtly differently, which has given me a great deal of confusion over the years.@@ -631,7 +631,7 @@ own right.  However we are careful to use the same name 'a', so that we can match things up. -c.f. Note [Associated type tyvar names] in Class.hs+c.f. Note [Associated type tyvar names] in GHC.Core.Class      Note [Family instance declaration binders] -} @@ -898,9 +898,9 @@    * The CUSK completely fixes the kind of the type constructor, forever. -  * The precise rules, for each declaration form, for whethher a declaration+  * The precise rules, for each declaration form, for whether a declaration     has a CUSK are given in the user manual section "Complete user-supplied-    kind signatures and polymorphic recursion".  BUt they simply implement+    kind signatures and polymorphic recursion".  But they simply implement     PRINCIPLE above.    * Open type families are interesting:@@ -1057,7 +1057,7 @@ Here injectivity annotation would consist of two comma-separated injectivity conditions. -See also Note [Injective type families] in TyCon+See also Note [Injective type families] in GHC.Core.TyCon -}  -- | Located type Family Result Signature@@ -2241,7 +2241,7 @@ -- | Located Rule Declarations type LRuleDecls pass = Located (RuleDecls pass) -  -- Note [Pragma source text] in BasicTypes+  -- Note [Pragma source text] in GHC.Types.Basic -- | Rule Declarations data RuleDecls pass = HsRules { rds_ext   :: XCRuleDecls pass                               , rds_src   :: SourceText@@ -2260,7 +2260,7 @@        { rd_ext  :: XHsRule pass            -- ^ After renamer, free-vars from the LHS and RHS        , rd_name :: Located (SourceText,RuleName)-           -- ^ Note [Pragma source text] in BasicTypes+           -- ^ Note [Pragma source text] in GHC.Types.Basic        , rd_act  :: Activation        , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)]            -- ^ Forall'd type vars@@ -2387,7 +2387,7 @@ -- | Located Warning Declarations type LWarnDecls pass = Located (WarnDecls pass) - -- Note [Pragma source text] in BasicTypes+ -- Note [Pragma source text] in GHC.Types.Basic -- | Warning pragma Declarations data WarnDecls pass = Warnings { wd_ext      :: XWarnings pass                                , wd_src      :: SourceText@@ -2437,7 +2437,7 @@ -- | Annotation Declaration data AnnDecl pass = HsAnnotation                       (XHsAnnotation pass)-                      SourceText -- Note [Pragma source text] in BasicTypes+                      SourceText -- Note [Pragma source text] in GHC.Types.Basic                       (AnnProvenance (IdP pass)) (Located (HsExpr pass))       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',       --           'ApiAnnotation.AnnType'
compiler/GHC/Hs/Doc.hs view
@@ -28,9 +28,9 @@ import Binary import Encoding import FastFunctions-import Name+import GHC.Types.Name import Outputable-import SrcLoc+import GHC.Types.SrcLoc  import Data.ByteString (ByteString) import qualified Data.ByteString as BS
compiler/GHC/Hs/Dump.hs view
@@ -19,16 +19,15 @@  import Data.Data hiding (Fixity) import Bag-import BasicTypes+import GHC.Types.Basic import FastString-import NameSet-import Name-import DataCon-import SrcLoc+import GHC.Types.Name.Set+import GHC.Types.Name+import GHC.Core.DataCon+import GHC.Types.SrcLoc import GHC.Hs-import OccName hiding (occName)-import Var-import Module+import GHC.Types.Var+import GHC.Types.Module import Outputable  import qualified Data.ByteString as B@@ -110,7 +109,7 @@              occName n  =  braces $                           text "OccName: "-                       <> text (OccName.occNameString n)+                       <> text (occNameString n)              moduleName :: ModuleName -> SDoc             moduleName m = braces $ text "ModuleName: " <> ppr m
compiler/GHC/Hs/Expr.hs view
@@ -38,15 +38,15 @@ -- others: import TcEvidence import GHC.Core-import Name-import NameSet-import BasicTypes-import ConLike-import SrcLoc+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Basic+import GHC.Core.ConLike+import GHC.Types.SrcLoc import Util import Outputable import FastString-import Type+import GHC.Core.Type import TysWiredIn (mkTupleStr) import TcType (TcType) import {-# SOURCE #-} TcRnTypes (TcLclEnv)@@ -55,7 +55,7 @@ import Data.Data hiding (Fixity(..)) import qualified Data.Data as Data (Fixity(..)) import qualified Data.Kind-import Data.Maybe (isNothing)+import Data.Maybe (isJust)  import GHCi.RemoteTypes ( ForeignRef ) import qualified Language.Haskell.TH as TH (Q)@@ -200,7 +200,7 @@ -- See Note [CmdSyntaxTable]  {--Note [CmdSyntaxtable]+Note [CmdSyntaxTable] ~~~~~~~~~~~~~~~~~~~~~ Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps track of the methods needed for a Cmd.@@ -675,7 +675,7 @@ -- | A pragma, written as {-# ... #-}, that may appear within an expression. data HsPragE p   = HsPragSCC   (XSCC p)-                SourceText            -- Note [Pragma source text] in BasicTypes+                SourceText            -- Note [Pragma source text] in GHC.Types.Basic                 StringLiteral         -- "set cost centre" SCC pragma    -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@,@@ -683,7 +683,7 @@    -- For details on above see note [Api annotations] in ApiAnnotation   | HsPragCore  (XCoreAnn p)-                SourceText            -- Note [Pragma source text] in BasicTypes+                SourceText            -- Note [Pragma source text] in GHC.Types.Basic                 StringLiteral         -- hdaume: core annotation    -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',@@ -698,12 +698,12 @@   -- For details on above see note [Api annotations] in ApiAnnotation   | HsPragTick                        -- A pragma introduced tick      (XTickPragma p)-     SourceText                       -- Note [Pragma source text] in BasicTypes+     SourceText                       -- Note [Pragma source text] in GHC.Types.Basic      (StringLiteral,(Int,Int),(Int,Int))                                       -- external span for this tick      ((SourceText,SourceText),(SourceText,SourceText))         -- Source text for the four integers used in the span.-        -- See note [Pragma source text] in BasicTypes+        -- See note [Pragma source text] in GHC.Types.Basic    | XHsPragE (XXPragE p) @@ -1089,10 +1089,9 @@   GhcPs -> ppr x   GhcRn -> ppr x   GhcTc -> case x of-    HsWrap co_fn e ->  pprHsWrapper co_fn (\parens -> if parens then pprExpr e+    HsWrap co_fn e -> pprHsWrapper co_fn (\parens -> if parens then pprExpr e                                                       else pprExpr e) - ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc ppr_infix_expr (HsVar _ (L _ v))    = Just (pprInfixOcc v) ppr_infix_expr (HsConLikeOut _ c)   = Just (pprInfixOcc (conLikeName c))@@ -1118,7 +1117,7 @@     -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))     --   = char '@' <> pprHsType arg     pp (Right arg)-      = char '@' <> ppr arg+      = text "@" <> ppr arg  pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))@@ -1712,41 +1711,39 @@  pprMatch :: (OutputableBndrId idR, Outputable body)          => Match (GhcPass idR) body -> SDoc-pprMatch match+pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })   = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)-        , nest 2 (pprGRHSs ctxt (m_grhss match)) ]+        , nest 2 (pprGRHSs ctxt grhss) ]   where-    ctxt = m_ctxt match     (herald, other_pats)         = case ctxt of             FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}-                | strictness == SrcStrict -> ASSERT(null $ m_pats match)-                                             (char '!'<>pprPrefixOcc fun, m_pats match)-                        -- a strict variable binding-                | fixity == Prefix -> (pprPrefixOcc fun, m_pats match)-                        -- f x y z = e-                        -- Not pprBndr; the AbsBinds will-                        -- have printed the signature--                | null pats2 -> (pp_infix, [])-                        -- x &&& y = e--                | otherwise -> (parens pp_infix, pats2)-                        -- (x &&& y) z = e-                where-                  pp_infix = pprParendLPat opPrec pat1-                         <+> pprInfixOcc fun-                         <+> pprParendLPat opPrec pat2+                | SrcStrict <- strictness+                -> ASSERT(null pats)     -- A strict variable binding+                   (char '!'<>pprPrefixOcc fun, pats) -            LambdaExpr -> (char '\\', m_pats match)+                | Prefix <- fixity+                -> (pprPrefixOcc fun, pats) -- f x y z = e+                                            -- Not pprBndr; the AbsBinds will+                                            -- have printed the signature+                | otherwise+                -> case pats of+                     (p1:p2:rest)+                        | null rest -> (pp_infix, [])           -- x &&& y = e+                        | otherwise -> (parens pp_infix, rest)  -- (x &&& y) z = e+                        where+                          pp_infix = pprParendLPat opPrec p1+                                     <+> pprInfixOcc fun+                                     <+> pprParendLPat opPrec p2+                     _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats) -            _  -> if null (m_pats match)-                     then (empty, [])-                     else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )-                          (ppr pat1, [])        -- No parens around the single pat+            LambdaExpr -> (char '\\', pats) -    (pat1:pats1) = m_pats match-    (pat2:pats2) = pats1+            _ -> case pats of+                   []    -> (empty, [])+                   [pat] -> (ppr pat, [])  -- No parens around the single pat in a case+                   _     -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)+pprMatch (XMatch nec) = noExtCon nec  pprGRHSs :: (OutputableBndrId idR, Outputable body)          => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc@@ -1827,7 +1824,10 @@               -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff           (XLastStmt idL idR body)           body-          Bool               -- True <=> return was stripped by ApplicativeDo+          (Maybe Bool)  -- Whether return was stripped+            -- Just True <=> return with a dollar was stripped by ApplicativeDo+            -- Just False <=> return without a dollar was stripped by ApplicativeDo+            -- Nothing <=> Nothing was stripped           (SyntaxExpr idR)   -- The return operator             -- The return operator is used only for MonadComp             -- For ListComp we use the baked-in 'return'@@ -2213,10 +2213,13 @@                                   OutputableBndrId idR,                                   Outputable body)         => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc-pprStmt (LastStmt _ expr ret_stripped _)+pprStmt (LastStmt _ expr m_dollar_stripped _)   = whenPprDebug (text "[last]") <+>-       (if ret_stripped then text "return" else empty) <+>-       ppr expr+      (case m_dollar_stripped of+        Just True -> text "return $"+        Just False -> text "return"+        Nothing -> empty) <+>+      ppr expr pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr] pprStmt (LetStmt _ (L _ binds))   = hsep [text "let", pprBinds binds] pprStmt (BodyStmt _ expr _ _)     = ppr expr@@ -2267,27 +2270,35 @@      let          ap_expr = sep (punctuate (text " |") (map pp_arg args))      in-       if isNothing mb_join-          then ap_expr-          else text "join" <+> parens ap_expr+       whenPprDebug (if isJust mb_join then text "[join]" else empty) <+>+       (if lengthAtLeast args 2 then parens else id) ap_expr     pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc-   pp_arg (_, ApplicativeArgOne _ pat expr isBody _)-     | isBody =  -- See Note [Applicative BodyStmt]-     ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr+   pp_arg (_, applicativeArg) = ppr applicativeArg++pprStmt (XStmtLR x) = ppr x+++instance (OutputableBndrId idL)+      => Outputable (ApplicativeArg (GhcPass idL)) where+  ppr = pprArg++pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc+pprArg (ApplicativeArgOne _ pat expr isBody _)+  | isBody =  -- See Note [Applicative BodyStmt]+    ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr             :: ExprStmt (GhcPass idL))-     | otherwise =-     ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr+  | otherwise =+    ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr             :: ExprStmt (GhcPass idL))-   pp_arg (_, ApplicativeArgMany _ stmts return pat) =+pprArg (ApplicativeArgMany _ stmts return pat) =      ppr pat <+>      text "<-" <+>      ppr (HsDo (panic "pprStmt") DoExpr (noLoc                (stmts ++-                   [noLoc (LastStmt noExtField (noLoc return) False noSyntaxExpr)])))-   pp_arg (_, XApplicativeArg x) = ppr x+                   [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)]))) -pprStmt (XStmtLR x) = ppr x+pprArg (XApplicativeArg x) = ppr x  pprTransformStmt :: (OutputableBndrId p)                  => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
compiler/GHC/Hs/Expr.hs-boot view
@@ -10,10 +10,10 @@  module GHC.Hs.Expr where -import SrcLoc     ( Located )+import GHC.Types.SrcLoc     ( Located ) import Outputable ( SDoc, Outputable ) import {-# SOURCE #-} GHC.Hs.Pat  ( LPat )-import BasicTypes ( SpliceExplicitFlag(..))+import GHC.Types.Basic  ( SpliceExplicitFlag(..)) import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) import Data.Kind  ( Type )
compiler/GHC/Hs/Extension.hs view
@@ -28,11 +28,11 @@ import GhcPrelude  import Data.Data hiding ( Fixity )-import Name-import RdrName-import Var+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Types.Var import Outputable-import SrcLoc (Located)+import GHC.Types.SrcLoc (Located)  import Data.Kind
compiler/GHC/Hs/ImpExp.hs view
@@ -18,15 +18,15 @@  import GhcPrelude -import Module           ( ModuleName )-import GHC.Hs.Doc       ( HsDocString )-import OccName          ( HasOccName(..), isTcOcc, isSymOcc )-import BasicTypes       ( SourceText(..), StringLiteral(..), pprWithSourceText )-import FieldLabel       ( FieldLbl(..) )+import GHC.Types.Module       ( ModuleName )+import GHC.Hs.Doc             ( HsDocString )+import GHC.Types.Name.Occurrence ( HasOccName(..), isTcOcc, isSymOcc )+import GHC.Types.Basic        ( SourceText(..), StringLiteral(..), pprWithSourceText )+import GHC.Types.FieldLabel   ( FieldLbl(..) )  import Outputable import FastString-import SrcLoc+import GHC.Types.SrcLoc import GHC.Hs.Extension  import Data.Data@@ -80,7 +80,7 @@   = ImportDecl {       ideclExt       :: XCImportDecl pass,       ideclSourceSrc :: SourceText,-                                 -- Note [Pragma source text] in BasicTypes+                                 -- Note [Pragma source text] in GHC.Types.Basic       ideclName      :: Located ModuleName, -- ^ Module name.       ideclPkgQual   :: Maybe StringLiteral,  -- ^ Package qualifier.       ideclSource    :: Bool,          -- ^ True <=> {-\# SOURCE \#-} import@@ -282,7 +282,7 @@     IEThingWith T [MkT] [FieldLabel "x" False x)]           (without DuplicateRecordFields)     IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)]   (with    DuplicateRecordFields) -See Note [Representing fields in AvailInfo] in Avail for more details.+See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details. -}  ieName :: IE (GhcPass p) -> IdP (GhcPass p)
compiler/GHC/Hs/Lit.hs view
@@ -22,10 +22,11 @@ import GhcPrelude  import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, pprExpr )-import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit,-                    negateFractionalLit,SourceText(..),pprWithSourceText,-                    PprPrec(..), topPrec )-import Type+import GHC.Types.Basic+   ( IntegralLit(..), FractionalLit(..), negateIntegralLit+   , negateFractionalLit, SourceText(..), pprWithSourceText+   , PprPrec(..), topPrec )+import GHC.Core.Type import Outputable import FastString import GHC.Hs.Extension@@ -41,7 +42,7 @@ ************************************************************************ -} --- Note [Literal source text] in BasicTypes for SourceText fields in+-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in -- the following -- Note [Trees that grow] in GHC.Hs.Extension for the Xxxxx fields in the following -- | Haskell Literal@@ -133,7 +134,7 @@  type instance XXOverLit (GhcPass _) = NoExtCon --- Note [Literal source text] in BasicTypes for SourceText fields in+-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in -- the following -- | Overloaded Literal Value data OverLitVal
compiler/GHC/Hs/Pat.hs view
@@ -1,3 +1,4 @@+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -55,18 +56,19 @@ import GHC.Hs.Extension import GHC.Hs.Types import TcEvidence-import BasicTypes+import GHC.Types.Basic -- others: import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )+import GHC.Driver.Session ( gopt, GeneralFlag(Opt_PrintTypecheckerElaboration) ) import TysWiredIn-import Var-import RdrName ( RdrName )-import ConLike-import DataCon-import TyCon+import GHC.Types.Var+import GHC.Types.Name.Reader ( RdrName )+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.TyCon import Outputable-import Type-import SrcLoc+import GHC.Core.Type+import GHC.Types.SrcLoc import Bag -- collect ev vars from pats import Maybes -- libraries:@@ -526,10 +528,11 @@ pprPat (NPlusKPat _ n k _ _ _)  = hcat [ppr n, char '+', ppr k] pprPat (SplicePat _ splice)     = pprSplice splice pprPat (CoPat _ co pat _)       = pprIfTc @p $-                                  pprHsWrapper co $ \parens-                                              -> if parens-                                                 then pprParendPat appPrec pat-                                                 else pprPat pat+                                  sdocWithDynFlags $ \ dflags ->+                                  if gopt Opt_PrintTypecheckerElaboration dflags+                                  then hang (text "CoPat" <+> parens (ppr co))+                                          2 (pprParendPat appPrec pat)+                                  else pprPat pat pprPat (SigPat _ pat ty)        = ppr pat <+> dcolon <+> ppr_ty   where ppr_ty = case ghcPass @p of                    GhcPs -> ppr ty@@ -734,7 +737,7 @@     -- since we cannot know until the splice is evaluated.     go (SplicePat {})      = False -    go (XPat {})           = False+    go (XPat nec)          = noExtCon nec  -- | Is the pattern any of combination of: --
compiler/GHC/Hs/Types.hs view
@@ -78,16 +78,16 @@  import GHC.Hs.Extension -import Id ( Id )-import Name( Name, NamedThing(getName) )-import RdrName ( RdrName )-import DataCon( HsSrcBang(..), HsImplBang(..),-                SrcStrictness(..), SrcUnpackedness(..) )+import GHC.Types.Id ( Id )+import GHC.Types.Name( Name, NamedThing(getName) )+import GHC.Types.Name.Reader ( RdrName )+import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..),+                         SrcStrictness(..), SrcUnpackedness(..) ) import TysWiredIn( mkTupleStr )-import Type+import GHC.Core.Type import GHC.Hs.Doc-import BasicTypes-import SrcLoc+import GHC.Types.Basic+import GHC.Types.SrcLoc import Outputable import FastString import Maybes( isJust )@@ -750,7 +750,7 @@ type instance XXType         (GhcPass _) = NewHsTypeX  --- Note [Literal source text] in BasicTypes for SourceText fields in+-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in -- the following -- | Haskell Type Literal data HsTyLit
compiler/GHC/Hs/Utils.hs view
@@ -77,7 +77,7 @@    -- * Template Haskell   mkUntypedSplice, mkTypedSplice,-  mkHsQuasiQuote, unqualQuasiQuote,+  mkHsQuasiQuote,    -- * Collecting binders   isUnliftedHsBind, isBangedHsBind,@@ -110,20 +110,20 @@ import GHC.Hs.Extension  import TcEvidence-import RdrName-import Var-import TyCoRep-import Type   ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig )+import GHC.Types.Name.Reader+import GHC.Types.Var+import GHC.Core.TyCo.Rep+import GHC.Core.Type ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig ) import TysWiredIn ( unitTy ) import TcType-import DataCon-import ConLike-import Id-import Name-import NameSet hiding ( unitFV )-import NameEnv-import BasicTypes-import SrcLoc+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Name.Set hiding ( unitFV )+import GHC.Types.Name.Env+import GHC.Types.Basic+import GHC.Types.SrcLoc import FastString import Util import Bag@@ -316,7 +316,7 @@ mkGroupUsingStmt   ss u   = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } -mkLastStmt body = LastStmt noExtField body False noSyntaxExpr+mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr mkBodyStmt body   = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr mkBindStmt pat body@@ -367,11 +367,6 @@ mkHsQuasiQuote quoter span quote   = HsQuasiQuote noExtField unqualSplice quoter span quote -unqualQuasiQuote :: RdrName-unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))-                -- A name (uniquified later) to-                -- identify the quasi-quote- mkHsString :: String -> HsLit (GhcPass p) mkHsString s = HsString NoSourceText (mkFastString s) @@ -503,8 +498,21 @@ nlHsFunTy a b = noLoc (HsFunTy noExtField (parenthesizeHsType funPrec a) b) nlHsParTy t   = noLoc (HsParTy noExtField t) -nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)-nlHsTyConApp tycon tys  = foldl' nlHsAppTy (nlHsTyVar tycon) tys+nlHsTyConApp :: LexicalFixity -> IdP (GhcPass p)+             -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p)+nlHsTyConApp fixity tycon tys+  | Infix <- fixity+  , HsValArg ty1 : HsValArg ty2 : rest <- tys+  = foldl' mk_app (noLoc $ HsOpTy noExtField ty1 (noLoc tycon) ty2) rest+  | otherwise+  = foldl' mk_app (nlHsTyVar tycon) tys+  where+    mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p)+    mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLoc $ HsParTy noExtField fun) arg+      -- parenthesize things like `(A + B) C`+    mk_app fun (HsValArg ty) = noLoc (HsAppTy noExtField fun (parenthesizeHsType appPrec ty))+    mk_app fun (HsTypeArg _ ki) = noLoc (HsAppKindTy noSrcSpan fun (parenthesizeHsType appPrec ki))+    mk_app fun (HsArgPar _) = noLoc (HsParTy noExtField fun)  nlHsAppKindTy ::   LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)@@ -730,9 +738,10 @@ The derived Eq instance for Glurp (without any kind signatures) would be:    instance Eq a => Eq (Glurp a) where+    (==) :: Glurp a -> Glurp a -> Bool     (==) = coerce @(Wat2 P  -> Wat2 P  -> Bool)                   @(Glurp a -> Glurp a -> Bool)-                  (==) :: Glurp a -> Glurp a -> Bool+                  (==)  (Where the visible type applications use types produced by typeToLHsType.) @@ -828,7 +837,7 @@ mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p) mkVarBind var rhs = L (getLoc rhs) $                     VarBind { var_ext = noExtField,-                              var_id = var, var_rhs = rhs, var_inline = False }+                              var_id = var, var_rhs = rhs }  mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)              -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs
compiler/GHC/HsToCore/PmCheck/Types.hs view
@@ -24,6 +24,10 @@         -- * Caching partially matched COMPLETE sets         ConLikeSet, PossibleMatches(..), +        -- * PmAltConSet+        PmAltConSet, emptyPmAltConSet, isEmptyPmAltConSet, elemPmAltConSet,+        extendPmAltConSet, pmAltConSetElems,+         -- * A 'DIdEnv' where entries may be shared         Shared(..), SharedDIdEnv(..), emptySDIE, lookupSDIE, sameRepresentativeSDIE,         setIndirectSDIE, setEntrySDIE, traverseSDIE,@@ -40,19 +44,20 @@ import Util import Bag import FastString-import Var (EvVar)-import Id-import VarEnv-import UniqDSet-import UniqDFM-import Name-import DataCon-import ConLike+import GHC.Types.Var (EvVar)+import GHC.Types.Id+import GHC.Types.Var.Env+import GHC.Types.Unique.DSet+import GHC.Types.Unique.DFM+import GHC.Types.Name+import GHC.Core.DataCon+import GHC.Core.ConLike import Outputable+import ListSetOps (unionLists) import Maybes-import Type-import TyCon-import Literal+import GHC.Core.Type+import GHC.Core.TyCon+import GHC.Types.Literal import GHC.Core import GHC.Core.Map import GHC.Core.Utils (exprType)@@ -152,6 +157,33 @@ data PmAltCon = PmAltConLike ConLike               | PmAltLit     PmLit +data PmAltConSet = PACS !ConLikeSet ![PmLit]++emptyPmAltConSet :: PmAltConSet+emptyPmAltConSet = PACS emptyUniqDSet []++isEmptyPmAltConSet :: PmAltConSet -> Bool+isEmptyPmAltConSet (PACS cls lits) = isEmptyUniqDSet cls && null lits++-- | Whether there is a 'PmAltCon' in the 'PmAltConSet' that compares 'Equal' to+-- the given 'PmAltCon' according to 'eqPmAltCon'.+elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool+elemPmAltConSet (PmAltConLike cl) (PACS cls _   ) = elementOfUniqDSet cl cls+elemPmAltConSet (PmAltLit lit)    (PACS _   lits) = elem lit lits++extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet+extendPmAltConSet (PACS cls lits) (PmAltConLike cl)+  = PACS (addOneToUniqDSet cls cl) lits+extendPmAltConSet (PACS cls lits) (PmAltLit lit)+  = PACS cls (unionLists lits [lit])++pmAltConSetElems :: PmAltConSet -> [PmAltCon]+pmAltConSetElems (PACS cls lits)+  = map PmAltConLike (uniqDSetToList cls) ++ map PmAltLit lits++instance Outputable PmAltConSet where+  ppr = ppr . pmAltConSetElems+ -- | We can't in general decide whether two 'PmAltCon's match the same set of -- values. In addition to the reasons in 'eqPmLit' and 'eqConLike', a -- 'PmAltConLike' might or might not represent the same value as a 'PmAltLit'.@@ -475,7 +507,7 @@   -- However, no more than one RealDataCon in the list, otherwise contradiction   -- because of generativity. -  , vi_neg :: ![PmAltCon]+  , vi_neg :: !PmAltConSet   -- ^ Negative info: A list of 'PmAltCon's that it cannot match.   -- Example, assuming   --@@ -489,6 +521,9 @@   -- between 'vi_pos' and 'vi_neg'.    -- See Note [Why record both positive and negative info?]+  -- It's worth having an actual set rather than a simple association list,+  -- because files like Cabal's `LicenseId` define relatively huge enums+  -- that lead to quadratic or worse behavior.    , vi_cache :: !PossibleMatches   -- ^ A cache of the associated COMPLETE sets. At any time a superset of
compiler/GHC/Iface/Syntax.hs view
@@ -47,29 +47,29 @@ import GHC.Iface.Type import BinFingerprint import GHC.Core( IsOrphan, isOrphan )-import Demand-import Cpr-import Class-import FieldLabel-import NameSet-import CoAxiom ( BranchIndex )-import Name-import CostCentre-import Literal-import ForeignCall-import Annotations( AnnPayload, AnnTarget )-import BasicTypes+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Core.Class+import GHC.Types.FieldLabel+import GHC.Types.Name.Set+import GHC.Core.Coercion.Axiom ( BranchIndex )+import GHC.Types.Name+import GHC.Types.CostCentre+import GHC.Types.Literal+import GHC.Types.ForeignCall+import GHC.Types.Annotations( AnnPayload, AnnTarget )+import GHC.Types.Basic import Outputable-import Module-import SrcLoc+import GHC.Types.Module+import GHC.Types.SrcLoc import Fingerprint import Binary import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )-import Var( VarBndr(..), binderVar )-import TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag )+import GHC.Types.Var( VarBndr(..), binderVar )+import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) import Util( dropList, filterByList, notNull, unzipWith, debugIsOn )-import DataCon (SrcStrictness(..), SrcUnpackedness(..))-import Lexeme (isLexSym)+import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))+import GHC.Utils.Lexeme (isLexSym) import TysWiredIn ( constraintKindTyConName ) import Util (seqList) @@ -222,7 +222,7 @@                                    , ifaxbRoles     :: [Role]                                    , ifaxbRHS       :: IfaceType                                    , ifaxbIncomps   :: [BranchIndex] }-                                     -- See Note [Storing compatibility] in CoAxiom+                                     -- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom  data IfaceConDecls   = IfAbstractTyCon     -- c.f TyCon.AbstractTyCon@@ -254,7 +254,7 @@           --            set of tyvars (*not* covars) of ifConExTCvs, unioned           --            with the set of ifBinders (from the parent IfaceDecl)           --            whose tyvars do not appear in ifConEqSpec-          -- See Note [DataCon user type variable binders] in DataCon+          -- See Note [DataCon user type variable binders] in GHC.Core.DataCon         ifConEqSpec  :: IfaceEqSpec,        -- Equality constraints         ifConCtxt    :: IfaceContext,       -- Non-stupid context         ifConArgTys  :: [IfaceType],        -- Arg types@@ -262,7 +262,7 @@         ifConStricts :: [IfaceBang],           -- Empty (meaning all lazy),           -- or 1-1 corresp with arg tys-          -- See Note [Bangs on imported data constructors] in MkId+          -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make         ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts  type IfaceEqSpec = [(IfLclName,IfaceType)]@@ -281,7 +281,7 @@                    ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of ClsInst                    ifDFun     :: IfExtName,                -- The dfun                    ifOFlag    :: OverlapFlag,              -- Overlap flag-                   ifInstOrph :: IsOrphan }                -- See Note [Orphans] in InstEnv+                   ifInstOrph :: IsOrphan }                -- See Note [Orphans] in GHC.Core.InstEnv         -- There's always a separate IfaceDecl for the DFun, which gives         -- its IdInfo with its full type and version number.         -- The instance declarations taken together have a version number,@@ -777,7 +777,7 @@                               then isIfaceTauType kind                                       -- Even in the presence of a standalone kind signature, a non-tau                                       -- result kind annotation cannot be discarded as it determines the arity.-                                      -- See Note [Arity inference in kcDeclHeader_sig] in TcHsType+                                      -- See Note [Arity inference in kcCheckDeclHeader_sig] in TcHsType                               else isIfaceLiftedTypeKind kind)                           (dcolon <+> ppr kind) @@ -1200,7 +1200,7 @@     -- 3. Pretty-print the data type constructor applied to its arguments.     --    This process will omit any invisible arguments, such as coercion     --    variables, if necessary. (See Note-    --    [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.)+    --    [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep.)     ppr_tc_app gadt_subst =       pprPrefixIfDeclBndr how_much (occName tycon)       <+> pprParendIfaceAppArgs@@ -1280,7 +1280,7 @@ pprParendIfaceExpr :: IfaceExpr -> SDoc pprParendIfaceExpr = pprIfaceExpr parens --- | Pretty Print an IfaceExpre+-- | Pretty Print an IfaceExpr -- -- The first argument should be a function that adds parens in context that need -- an atomic value (e.g. function args)@@ -1417,7 +1417,7 @@ *                                                                      * ************************************************************************ -This is used for dependency analysis in GHC.Iface.Utils, so that we+This is used for dependency analysis in GHC.Iface.Make, so that we fingerprint a declaration before the things that depend on it.  It is specific to interface-file fingerprinting in the sense that we don't collect *all* Names: for example, the DFun of an instance is
compiler/GHC/Iface/Type.hs view
@@ -64,14 +64,14 @@  import {-# SOURCE #-} TysWiredIn ( coercibleTyCon, heqTyCon                                  , liftedRepDataConTyCon, tupleTyConName )-import {-# SOURCE #-} Type       ( isRuntimeRepTy )+import {-# SOURCE #-} GHC.Core.Type ( isRuntimeRepTy ) -import TyCon hiding ( pprPromotionQuote )-import CoAxiom-import Var+import GHC.Core.TyCon hiding ( pprPromotionQuote )+import GHC.Core.Coercion.Axiom+import GHC.Types.Var import PrelNames-import Name-import BasicTypes+import GHC.Types.Name+import GHC.Types.Basic import Binary import Outputable import FastString@@ -119,7 +119,7 @@ type IfaceLamBndr = (IfaceBndr, IfaceOneShot)  data IfaceOneShot    -- See Note [Preserve OneShotInfo] in CoreTicy-  = IfaceNoOneShot   -- and Note [The oneShot function] in MkId+  = IfaceNoOneShot   -- and Note [The oneShot function] in GHC.Types.Id.Make   | IfaceOneShot  @@ -567,7 +567,7 @@               -- Keep recursing through the remainder of the arguments, as it's               -- possible that there are remaining invisible ones.               -- See the "In type declarations" section of Note [VarBndrs,-              -- TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.+              -- TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep.               |  otherwise               -> suppress_invis ts @@ -675,7 +675,7 @@  Here, @{k} indicates that `k` is an inferred argument, and @k indicates that `k` is a specified argument. (See-Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep for+Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep for a lengthier explanation on what "inferred" and "specified" mean.)  ************************************************************************@@ -776,7 +776,7 @@       case vis of         AnonTCB  VisArg    -> ppr_bndr (UseBndrParens True)         AnonTCB  InvisArg  -> char '@' <> braces (ppr_bndr (UseBndrParens False))-          -- The above case is rare. (See Note [AnonTCB InvisArg] in TyCon.)+          -- The above case is rare. (See Note [AnonTCB InvisArg] in GHC.Core.TyCon.)           -- Should we print these differently?         NamedTCB Required  -> ppr_bndr (UseBndrParens True)         NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True)@@ -922,10 +922,10 @@     (forall a. blah)  Conclusion: keep track of whether we we are in the kind of a-binder; ohly if so, convert free RuntimeRep variables to LiftedRep.+binder; only if so, convert free RuntimeRep variables to LiftedRep. -} --- | Default 'RuntimeRep' variables to 'LiftedPtr'. e.g.+-- | Default 'RuntimeRep' variables to 'LiftedRep'. e.g. -- -- @ -- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r).@@ -967,7 +967,7 @@      go in_kind _ ty@(IfaceFreeTyVar tv)       -- See Note [Defaulting RuntimeRep variables], about free vars-      | in_kind && Type.isRuntimeRepTy (tyVarKind tv)+      | in_kind && GHC.Core.Type.isRuntimeRepTy (tyVarKind tv)       = IfaceTyConApp liftedRep IA_Nil       | otherwise       = ty@@ -1175,7 +1175,7 @@    utterly misleading.     See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]-   in TyCoRep.+   in GHC.Core.TyCo.Rep.  N.B. Until now (Aug 2018) we didn't check anything for coercion variables. @@ -1252,7 +1252,7 @@ pprSpaceIfPromotedTyCon _   = id --- See equivalent function in TyCoRep.hs+-- See equivalent function in GHC.Core.TyCo.Rep.hs pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc -- Given a type-level list (t1 ': t2), see if we can print -- it in list notation [t1, ...].@@ -1462,7 +1462,7 @@ pprSum :: Arity -> PromotionFlag -> IfaceAppArgs -> SDoc pprSum _arity is_promoted args   =   -- drop the RuntimeRep vars.-      -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+      -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon     let tys   = appArgsIfaceTypes args         args' = drop (length tys `div` 2) tys     in pprPromotionQuoteI is_promoted@@ -1489,7 +1489,7 @@        | otherwise       ->   -- drop the RuntimeRep vars.-           -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+           -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon          let tys   = appArgsIfaceTypes args              args' = case sort of                        UnboxedTuple -> drop (length tys `div` 2) tys
compiler/GHC/Iface/Type.hs-boot view
@@ -4,7 +4,7 @@    ) where -import Var (VarBndr, ArgFlag)+import GHC.Types.Var (VarBndr, ArgFlag)  data IfaceAppArgs
compiler/GHC/Platform/Reg.hs view
@@ -29,7 +29,7 @@ import GhcPrelude  import Outputable-import Unique+import GHC.Types.Unique import GHC.Platform.Reg.Class import Data.List (intersect)
compiler/GHC/Platform/Reg/Class.hs view
@@ -6,8 +6,8 @@  import GhcPrelude -import  Outputable-import  Unique+import Outputable+import GHC.Types.Unique   -- | The class of a register.
compiler/GHC/Runtime/Eval/Types.hs view
@@ -16,12 +16,12 @@  import GHCi.RemoteTypes import GHCi.Message (EvalExpr, ResumeContext)-import Id-import Name-import Module-import RdrName-import Type-import SrcLoc+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Module+import GHC.Types.Name.Reader+import GHC.Core.Type+import GHC.Types.SrcLoc import Exception  import Data.Word
compiler/GHC/Runtime/Heap/Layout.hs view
@@ -46,7 +46,7 @@  import GhcPrelude -import BasicTypes( ConTagZ )+import GHC.Types.Basic( ConTagZ ) import GHC.Driver.Session import Outputable import GHC.Platform@@ -72,8 +72,8 @@  -- | Round up the given byte count to the next byte count that's a -- multiple of the machine's word size.-roundUpToWords :: DynFlags -> ByteOff -> ByteOff-roundUpToWords dflags n = roundUpTo n (wORD_SIZE dflags)+roundUpToWords :: Platform -> ByteOff -> ByteOff+roundUpToWords platform n = roundUpTo n (platformWordSizeInBytes platform)  -- | Round up @base@ to a multiple of @size@. roundUpTo :: ByteOff -> ByteOff -> ByteOff@@ -83,17 +83,17 @@ -- -- This function morally has type @WordOff -> ByteOff@, but uses @Num -- a@ to allow for overloading.-wordsToBytes :: Num a => DynFlags -> a -> a-wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n-{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-}-{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-}-{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-}+wordsToBytes :: Num a => Platform -> a -> a+wordsToBytes platform n = fromIntegral (platformWordSizeInBytes platform) * n+{-# SPECIALIZE wordsToBytes :: Platform -> Int -> Int #-}+{-# SPECIALIZE wordsToBytes :: Platform -> Word -> Word #-}+{-# SPECIALIZE wordsToBytes :: Platform -> Integer -> Integer #-}  -- | First round the given byte count up to a multiple of the -- machine's word size and then convert the result to words.-bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff-bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size- where word_size = wORD_SIZE dflags+bytesToWordsRoundUp :: Platform -> ByteOff -> WordOff+bytesToWordsRoundUp platform n = (n + word_size - 1) `quot` word_size+ where word_size = platformWordSizeInBytes platform -- StgWord is a type representing an StgWord on the target platform. -- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform newtype StgWord = StgWord Word64@@ -102,9 +102,9 @@ fromStgWord :: StgWord -> Integer fromStgWord (StgWord i) = toInteger i -toStgWord :: DynFlags -> Integer -> StgWord-toStgWord dflags i-    = case platformWordSize (targetPlatform dflags) of+toStgWord :: Platform -> Integer -> StgWord+toStgWord platform i+    = case platformWordSize platform of       -- These conversions mean that things like toStgWord (-1)       -- do the right thing       PW4 -> StgWord (fromIntegral (fromInteger i :: Word32))@@ -123,9 +123,9 @@ fromStgHalfWord :: StgHalfWord -> Integer fromStgHalfWord (StgHalfWord w) = toInteger w -toStgHalfWord :: DynFlags -> Integer -> StgHalfWord-toStgHalfWord dflags i-    = case platformWordSize (targetPlatform dflags) of+toStgHalfWord :: Platform -> Integer -> StgHalfWord+toStgHalfWord platform i+    = case platformWordSize platform of       -- These conversions mean that things like toStgHalfWord (-1)       -- do the right thing       PW4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16))@@ -135,11 +135,11 @@     ppr (StgHalfWord w) = integer (toInteger w)  -- | Half word size in bytes-halfWordSize :: DynFlags -> ByteOff-halfWordSize dflags = platformWordSizeInBytes (targetPlatform dflags) `div` 2+halfWordSize :: Platform -> ByteOff+halfWordSize platform = platformWordSizeInBytes platform `div` 2 -halfWordSizeInBits :: DynFlags -> Int-halfWordSizeInBits dflags = platformWordSizeInBits (targetPlatform dflags) `div` 2+halfWordSizeInBits :: Platform -> Int+halfWordSizeInBits platform = platformWordSizeInBits platform `div` 2  {- ************************************************************************@@ -255,8 +255,8 @@ smallArrPtrsRep :: WordOff -> SMRep smallArrPtrsRep elems = SmallArrayPtrsRep elems -arrWordsRep :: DynFlags -> ByteOff -> SMRep-arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes)+arrWordsRep :: Platform -> ByteOff -> SMRep+arrWordsRep platform bytes = ArrayWordsRep (bytesToWordsRoundUp platform bytes)  ----------------------------------------------------------------------------- -- Predicates@@ -297,7 +297,7 @@ -- Size-related things  fixedHdrSize :: DynFlags -> ByteOff-fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags)+fixedHdrSize dflags = wordsToBytes (targetPlatform dflags) (fixedHdrSizeW dflags)  -- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h) fixedHdrSizeW :: DynFlags -> WordOff@@ -322,7 +322,8 @@ arrWordsHdrSizeW :: DynFlags -> WordOff arrWordsHdrSizeW dflags =     fixedHdrSizeW dflags +-    (sIZEOF_StgArrBytes_NoHdr dflags `quot` wORD_SIZE dflags)+    (sIZEOF_StgArrBytes_NoHdr dflags `quot`+      platformWordSizeInBytes (targetPlatform dflags))  arrPtrsHdrSize :: DynFlags -> ByteOff arrPtrsHdrSize dflags@@ -331,7 +332,8 @@ arrPtrsHdrSizeW :: DynFlags -> WordOff arrPtrsHdrSizeW dflags =     fixedHdrSizeW dflags +-    (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)+    (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot`+      platformWordSizeInBytes (targetPlatform dflags))  smallArrPtrsHdrSize :: DynFlags -> ByteOff smallArrPtrsHdrSize dflags@@ -340,16 +342,18 @@ smallArrPtrsHdrSizeW :: DynFlags -> WordOff smallArrPtrsHdrSizeW dflags =     fixedHdrSizeW dflags +-    (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)+    (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot`+      platformWordSizeInBytes (targetPlatform dflags))  -- Thunks have an extra header word on SMP, so the update doesn't -- splat the payload. thunkHdrSize :: DynFlags -> WordOff thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr-        where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags+        where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot`+                         platformWordSizeInBytes (targetPlatform dflags)  hdrSize :: DynFlags -> SMRep -> ByteOff-hdrSize dflags rep = wordsToBytes dflags (hdrSizeW dflags rep)+hdrSize dflags rep = wordsToBytes (targetPlatform dflags) (hdrSizeW dflags rep)  hdrSizeW :: DynFlags -> SMRep -> WordOff hdrSizeW dflags (HeapRep _ _ _ ty)    = closureTypeHdrSize dflags ty@@ -358,8 +362,8 @@ hdrSizeW dflags (ArrayWordsRep _)     = arrWordsHdrSizeW dflags hdrSizeW _ _                          = panic "SMRep.hdrSizeW" -nonHdrSize :: DynFlags -> SMRep -> ByteOff-nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep)+nonHdrSize :: Platform -> SMRep -> ByteOff+nonHdrSize platform rep = wordsToBytes platform (nonHdrSizeW rep)  nonHdrSizeW :: SMRep -> WordOff nonHdrSizeW (HeapRep _ p np _) = p + np@@ -413,7 +417,8 @@ -- | The size of a card table, in words cardTableSizeW :: DynFlags -> Int -> WordOff cardTableSizeW dflags elems =-  bytesToWordsRoundUp dflags (cardTableSizeB dflags elems)+  bytesToWordsRoundUp (targetPlatform dflags)+                      (cardTableSizeB dflags elems)  ----------------------------------------------------------------------------- -- deriving the RTS closure type from an SMRep
compiler/GHC/Runtime/Interpreter/Types.hs view
@@ -14,7 +14,7 @@  import GHCi.RemoteTypes import GHCi.Message         ( Pipe )-import UniqFM+import GHC.Types.Unique.FM import Foreign  import Control.Concurrent@@ -22,9 +22,9 @@  -- | Runtime interpreter data Interp-   = ExternalInterp !IServ -- ^ External interpreter+   = ExternalInterp !IServConfig !IServ -- ^ External interpreter #if defined(HAVE_INTERNAL_INTERPRETER)-   | InternalInterp        -- ^ Internal interpreter+   | InternalInterp                     -- ^ Internal interpreter #endif  -- | External interpreter@@ -36,15 +36,17 @@  -- | State of an external interpreter data IServState-   = IServPending !IServConfig    -- ^ Not spawned yet+   = IServPending                 -- ^ Not spawned yet    | IServRunning !IServInstance  -- ^ Running  -- | Configuration needed to spawn an external interpreter data IServConfig = IServConfig-  { iservConfProgram :: !String   -- ^ External program to run-  , iservConfOpts    :: ![String] -- ^ Command-line options-  , iservConfHook    :: !(Maybe (CreateProcess -> IO ProcessHandle)) -- ^ Hook-  , iservConfTrace   :: IO ()   -- ^ Trace action executed after spawn+  { iservConfProgram  :: !String   -- ^ External program to run+  , iservConfOpts     :: ![String] -- ^ Command-line options+  , iservConfProfiled :: !Bool     -- ^ Use Profiling way+  , iservConfDynamic  :: !Bool     -- ^ Use Dynamic way+  , iservConfHook     :: !(Maybe (CreateProcess -> IO ProcessHandle)) -- ^ Hook+  , iservConfTrace    :: IO ()     -- ^ Trace action executed after spawn   }  -- | External interpreter instance@@ -56,8 +58,5 @@       -- ^ Values that need to be freed before the next command is sent.       -- Threads can append values to this list asynchronously (by modifying the       -- IServ state MVar).--  , iservConfig            :: !IServConfig-      -- ^ Config used to spawn the external interpreter   }
compiler/GHC/Runtime/Linker/Types.hs view
@@ -19,13 +19,13 @@ import Data.Time               ( UTCTime ) import Data.Maybe              ( Maybe ) import Control.Concurrent.MVar ( MVar )-import Module                  ( InstalledUnitId, Module )-import GHC.ByteCode.Types           ( ItblEnv, CompiledByteCode )+import GHC.Types.Module        ( InstalledUnitId, Module )+import GHC.ByteCode.Types      ( ItblEnv, CompiledByteCode ) import Outputable-import Var                     ( Id )+import GHC.Types.Var           ( Id ) import GHC.Fingerprint.Type    ( Fingerprint )-import NameEnv                 ( NameEnv )-import Name                    ( Name )+import GHC.Types.Name.Env      ( NameEnv )+import GHC.Types.Name          ( Name ) import GHCi.RemoteTypes        ( ForeignHValue )  type ClosureEnv = NameEnv (Name, ForeignHValue)
compiler/GHC/Stg/Syntax.hs view
@@ -64,25 +64,25 @@ import GhcPrelude  import GHC.Core     ( AltCon, Tickish )-import CostCentre  ( CostCentreStack )+import GHC.Types.CostCentre ( CostCentreStack ) import Data.ByteString ( ByteString ) import Data.Data   ( Data ) import Data.List   ( intersperse )-import DataCon+import GHC.Core.DataCon import GHC.Driver.Session-import ForeignCall ( ForeignCall )-import Id-import VarSet-import Literal     ( Literal, literalType )-import Module      ( Module )+import GHC.Types.ForeignCall ( ForeignCall )+import GHC.Types.Id+import GHC.Types.Var.Set+import GHC.Types.Literal     ( Literal, literalType )+import GHC.Types.Module      ( Module ) import Outputable-import GHC.Driver.Packages    ( isDllName )+import GHC.Driver.Packages ( isDynLinkName ) import GHC.Platform import GHC.Core.Ppr( {- instances -} )-import PrimOp      ( PrimOp, PrimCall )-import TyCon       ( PrimRep(..), TyCon )-import Type        ( Type )-import GHC.Types.RepType     ( typePrimRep1 )+import PrimOp            ( PrimOp, PrimCall )+import GHC.Core.TyCon    ( PrimRep(..), TyCon )+import GHC.Core.Type     ( Type )+import GHC.Types.RepType ( typePrimRep1 ) import Util  import Data.List.NonEmpty ( NonEmpty, toList )@@ -127,14 +127,14 @@ isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool isDllConApp dflags this_mod con args  | platformOS (targetPlatform dflags) == OSMinGW32-    = isDllName dflags this_mod (dataConName con) || any is_dll_arg args+    = isDynLinkName dflags this_mod (dataConName con) || any is_dll_arg args  | otherwise = False   where     -- NB: typePrimRep1 is legit because any free variables won't have     -- unlifted type (there are no unlifted things at top level)     is_dll_arg :: StgArg -> Bool     is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep1 (idType v))-                             && isDllName dflags this_mod (idName v)+                             && isDynLinkName dflags this_mod (idName v)     is_dll_arg _             = False  -- True of machine addresses; these are the things that don't work across DLLs.
+ compiler/GHC/Types/Annotations.hs view
@@ -0,0 +1,142 @@+-- |+-- Support for source code annotation feature of GHC. That is the ANN pragma.+--+-- (c) The University of Glasgow 2006+-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998+--+{-# LANGUAGE DeriveFunctor #-}+module GHC.Types.Annotations (+        -- * Main Annotation data types+        Annotation(..), AnnPayload,+        AnnTarget(..), CoreAnnTarget,++        -- * AnnEnv for collecting and querying Annotations+        AnnEnv,+        mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv,+        findAnns, findAnnsByTypeRep,+        deserializeAnns+    ) where++import GhcPrelude++import Binary+import GHC.Types.Module ( Module+                        , ModuleEnv, emptyModuleEnv, extendModuleEnvWith+                        , plusModuleEnv_C, lookupWithDefaultModuleEnv+                        , mapModuleEnv )+import GHC.Types.Name.Env+import GHC.Types.Name+import Outputable+import GHC.Serialized++import Control.Monad+import Data.Maybe+import Data.Typeable+import Data.Word        ( Word8 )+++-- | Represents an annotation after it has been sufficiently desugared from+-- it's initial form of 'HsDecls.AnnDecl'+data Annotation = Annotation {+        ann_target :: CoreAnnTarget,    -- ^ The target of the annotation+        ann_value  :: AnnPayload+    }++type AnnPayload = Serialized    -- ^ The "payload" of an annotation+                                --   allows recovery of its value at a given type,+                                --   and can be persisted to an interface file++-- | An annotation target+data AnnTarget name+  = NamedTarget name          -- ^ We are annotating something with a name:+                              --      a type or identifier+  | ModuleTarget Module       -- ^ We are annotating a particular module+  deriving (Functor)++-- | The kind of annotation target found in the middle end of the compiler+type CoreAnnTarget = AnnTarget Name++instance Outputable name => Outputable (AnnTarget name) where+    ppr (NamedTarget nm) = text "Named target" <+> ppr nm+    ppr (ModuleTarget mod) = text "Module target" <+> ppr mod++instance Binary name => Binary (AnnTarget name) where+    put_ bh (NamedTarget a) = do+        putByte bh 0+        put_ bh a+    put_ bh (ModuleTarget a) = do+        putByte bh 1+        put_ bh a+    get bh = do+        h <- getByte bh+        case h of+            0 -> liftM NamedTarget  $ get bh+            _ -> liftM ModuleTarget $ get bh++instance Outputable Annotation where+    ppr ann = ppr (ann_target ann)++-- | A collection of annotations+data AnnEnv = MkAnnEnv { ann_mod_env :: !(ModuleEnv [AnnPayload])+                       , ann_name_env :: !(NameEnv [AnnPayload])+                       }++-- | An empty annotation environment.+emptyAnnEnv :: AnnEnv+emptyAnnEnv = MkAnnEnv emptyModuleEnv emptyNameEnv++-- | Construct a new annotation environment that contains the list of+-- annotations provided.+mkAnnEnv :: [Annotation] -> AnnEnv+mkAnnEnv = extendAnnEnvList emptyAnnEnv++-- | Add the given annotation to the environment.+extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv+extendAnnEnvList env =+  foldl' extendAnnEnv env++extendAnnEnv :: AnnEnv -> Annotation -> AnnEnv+extendAnnEnv (MkAnnEnv mod_env name_env) (Annotation tgt payload) =+  case tgt of+    NamedTarget name -> MkAnnEnv mod_env (extendNameEnv_C (++) name_env name [payload])+    ModuleTarget mod -> MkAnnEnv (extendModuleEnvWith (++) mod_env mod [payload]) name_env++-- | Union two annotation environments.+plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv+plusAnnEnv a b =+  MkAnnEnv { ann_mod_env = plusModuleEnv_C (++) (ann_mod_env a) (ann_mod_env b)+           , ann_name_env = plusNameEnv_C (++) (ann_name_env a) (ann_name_env b)+           }++-- | Find the annotations attached to the given target as 'Typeable'+--   values of your choice. If no deserializer is specified,+--   only transient annotations will be returned.+findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]+findAnns deserialize env+  = mapMaybe (fromSerialized deserialize) . findAnnPayloads env++-- | Find the annotations attached to the given target as 'Typeable'+--   values of your choice. If no deserializer is specified,+--   only transient annotations will be returned.+findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]]+findAnnsByTypeRep env target tyrep+  = [ ws | Serialized tyrep' ws <- findAnnPayloads env target+    , tyrep' == tyrep ]++-- | Find payloads for the given 'CoreAnnTarget' in an 'AnnEnv'.+findAnnPayloads :: AnnEnv -> CoreAnnTarget -> [AnnPayload]+findAnnPayloads env target =+  case target of+    ModuleTarget mod -> lookupWithDefaultModuleEnv (ann_mod_env env) [] mod+    NamedTarget name -> fromMaybe [] $ lookupNameEnv (ann_name_env env) name++-- | Deserialize all annotations of a given type. This happens lazily, that is+--   no deserialization will take place until the [a] is actually demanded and+--   the [a] can also be empty (the UniqFM is not filtered).+deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])+deserializeAnns deserialize env+  = ( mapModuleEnv deserAnns (ann_mod_env env)+    , mapNameEnv deserAnns (ann_name_env env)+    )+  where deserAnns = mapMaybe (fromSerialized deserialize)+
+ compiler/GHC/Types/Avail.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+--+-- (c) The University of Glasgow+--++#include "HsVersions.h"++module GHC.Types.Avail (+    Avails,+    AvailInfo(..),+    avail,+    availsToNameSet,+    availsToNameSetWithSelectors,+    availsToNameEnv,+    availName, availNames, availNonFldNames,+    availNamesWithSelectors,+    availFlds,+    availsNamesWithOccs,+    availNamesWithOccs,+    stableAvailCmp,+    plusAvail,+    trimAvail,+    filterAvail,+    filterAvails,+    nubAvails+++  ) where++import GhcPrelude++import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set++import GHC.Types.FieldLabel+import Binary+import ListSetOps+import Outputable+import Util++import Data.Data ( Data )+import Data.List ( find )+import Data.Function++-- -----------------------------------------------------------------------------+-- The AvailInfo type++-- | Records what things are \"available\", i.e. in scope+data AvailInfo++  -- | An ordinary identifier in scope+  = Avail Name++  -- | A type or class in scope+  --+  -- The __AvailTC Invariant__: If the type or class is itself to be in scope,+  -- it must be /first/ in this list.  Thus, typically:+  --+  -- > AvailTC Eq [Eq, ==, \/=] []+  | AvailTC+       Name         -- ^ The name of the type or class+       [Name]       -- ^ The available pieces of type or class,+                    -- excluding field selectors.+       [FieldLabel] -- ^ The record fields of the type+                    -- (see Note [Representing fields in AvailInfo]).++   deriving ( Eq    -- ^ Used when deciding if the interface has changed+            , Data )++-- | A collection of 'AvailInfo' - several things that are \"available\"+type Avails = [AvailInfo]++{-+Note [Representing fields in AvailInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When -XDuplicateRecordFields is disabled (the normal case), a+datatype like++  data T = MkT { foo :: Int }++gives rise to the AvailInfo++  AvailTC T [T, MkT] [FieldLabel "foo" False foo]++whereas if -XDuplicateRecordFields is enabled it gives++  AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT]++since the label does not match the selector name.++The labels in a field list are not necessarily unique:+data families allow the same parent (the family tycon) to have+multiple distinct fields with the same label. For example,++  data family F a+  data instance F Int  = MkFInt { foo :: Int }+  data instance F Bool = MkFBool { foo :: Bool}++gives rise to++  AvailTC F [ F, MkFInt, MkFBool ]+            [ FieldLabel "foo" True $sel:foo:MkFInt+            , FieldLabel "foo" True $sel:foo:MkFBool ]++Moreover, note that the flIsOverloaded flag need not be the same for+all the elements of the list.  In the example above, this occurs if+the two data instances are defined in different modules, one with+`-XDuplicateRecordFields` enabled and one with it disabled.  Thus it+is possible to have++  AvailTC F [ F, MkFInt, MkFBool ]+            [ FieldLabel "foo" True $sel:foo:MkFInt+            , FieldLabel "foo" False foo ]++If the two data instances are defined in different modules, both+without `-XDuplicateRecordFields`, it will be impossible to export+them from the same module (even with `-XDuplicateRecordfields`+enabled), because they would be represented identically.  The+workaround here is to enable `-XDuplicateRecordFields` on the defining+modules.+-}++-- | Compare lexicographically+stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering+stableAvailCmp (Avail n1)       (Avail n2)   = n1 `stableNameCmp` n2+stableAvailCmp (Avail {})         (AvailTC {})   = LT+stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =+    (n `stableNameCmp` m) `thenCmp`+    (cmpList stableNameCmp ns ms) `thenCmp`+    (cmpList (stableNameCmp `on` flSelector) nfs mfs)+stableAvailCmp (AvailTC {})       (Avail {})     = GT++avail :: Name -> AvailInfo+avail n = Avail n++-- -----------------------------------------------------------------------------+-- Operations on AvailInfo++availsToNameSet :: [AvailInfo] -> NameSet+availsToNameSet avails = foldr add emptyNameSet avails+      where add avail set = extendNameSetList set (availNames avail)++availsToNameSetWithSelectors :: [AvailInfo] -> NameSet+availsToNameSetWithSelectors avails = foldr add emptyNameSet avails+      where add avail set = extendNameSetList set (availNamesWithSelectors avail)++availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo+availsToNameEnv avails = foldr add emptyNameEnv avails+     where add avail env = extendNameEnvList env+                                (zip (availNames avail) (repeat avail))++-- | Just the main name made available, i.e. not the available pieces+-- of type or class brought into scope by the 'GenAvailInfo'+availName :: AvailInfo -> Name+availName (Avail n)     = n+availName (AvailTC n _ _) = n++-- | All names made available by the availability information (excluding overloaded selectors)+availNames :: AvailInfo -> [Name]+availNames (Avail n)         = [n]+availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]++-- | All names made available by the availability information (including overloaded selectors)+availNamesWithSelectors :: AvailInfo -> [Name]+availNamesWithSelectors (Avail n)         = [n]+availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs++-- | Names for non-fields made available by the availability information+availNonFldNames :: AvailInfo -> [Name]+availNonFldNames (Avail n)        = [n]+availNonFldNames (AvailTC _ ns _) = ns++-- | Fields made available by the availability information+availFlds :: AvailInfo -> [FieldLabel]+availFlds (AvailTC _ _ fs) = fs+availFlds _                = []++availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)]+availsNamesWithOccs = concatMap availNamesWithOccs++-- | 'Name's made available by the availability information, paired with+-- the 'OccName' used to refer to each one.+--+-- When @DuplicateRecordFields@ is in use, the 'Name' may be the+-- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the+-- 'OccName' will be the label of the field (e.g. @foo@).+--+-- See Note [Representing fields in AvailInfo].+availNamesWithOccs :: AvailInfo -> [(Name, OccName)]+availNamesWithOccs (Avail n) = [(n, nameOccName n)]+availNamesWithOccs (AvailTC _ ns fs)+  = [ (n, nameOccName n) | n <- ns ] +++    [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ]++-- -----------------------------------------------------------------------------+-- Utility++plusAvail :: AvailInfo -> AvailInfo -> AvailInfo+plusAvail a1 a2+  | debugIsOn && availName a1 /= availName a2+  = pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2])+plusAvail a1@(Avail {})         (Avail {})        = a1+plusAvail (AvailTC _ [] [])     a2@(AvailTC {})   = a2+plusAvail a1@(AvailTC {})       (AvailTC _ [] []) = a1+plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)+  = case (n1==s1, n2==s2) of  -- Maintain invariant the parent is first+       (True,True)   -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))+                                   (fs1 `unionLists` fs2)+       (True,False)  -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))+                                   (fs1 `unionLists` fs2)+       (False,True)  -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))+                                   (fs1 `unionLists` fs2)+       (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))+                                   (fs1 `unionLists` fs2)+plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)+  = AvailTC n1 ss1 (fs1 `unionLists` fs2)+plusAvail (AvailTC n1 [] fs1)  (AvailTC _ ss2 fs2)+  = AvailTC n1 ss2 (fs1 `unionLists` fs2)+plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2])++-- | trims an 'AvailInfo' to keep only a single name+trimAvail :: AvailInfo -> Name -> AvailInfo+trimAvail (Avail n)         _ = Avail n+trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of+    Just x  -> AvailTC n [] [x]+    Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] []++-- | filters 'AvailInfo's by the given predicate+filterAvails  :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]+filterAvails keep avails = foldr (filterAvail keep) [] avails++-- | filters an 'AvailInfo' by the given predicate+filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]+filterAvail keep ie rest =+  case ie of+    Avail n | keep n    -> ie : rest+            | otherwise -> rest+    AvailTC tc ns fs ->+        let ns' = filter keep ns+            fs' = filter (keep . flSelector) fs in+        if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest+++-- | Combines 'AvailInfo's from the same family+-- 'avails' may have several items with the same availName+-- E.g  import Ix( Ix(..), index )+-- will give Ix(Ix,index,range) and Ix(index)+-- We want to combine these; addAvail does that+nubAvails :: [AvailInfo] -> [AvailInfo]+nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails)+  where+    add env avail = extendNameEnv_C plusAvail env (availName avail) avail++-- -----------------------------------------------------------------------------+-- Printing++instance Outputable AvailInfo where+   ppr = pprAvail++pprAvail :: AvailInfo -> SDoc+pprAvail (Avail n)+  = ppr n+pprAvail (AvailTC n ns fs)+  = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi+                         , fsep (punctuate comma (map (ppr . flLabel) fs))])++instance Binary AvailInfo where+    put_ bh (Avail aa) = do+            putByte bh 0+            put_ bh aa+    put_ bh (AvailTC ab ac ad) = do+            putByte bh 1+            put_ bh ab+            put_ bh ac+            put_ bh ad+    get bh = do+            h <- getByte bh+            case h of+              0 -> do aa <- get bh+                      return (Avail aa)+              _ -> do ab <- get bh+                      ac <- get bh+                      ad <- get bh+                      return (AvailTC ab ac ad)
+ compiler/GHC/Types/Basic.hs view
@@ -0,0 +1,1736 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1997-1998++\section[BasicTypes]{Miscellaneous types}++This module defines a miscellaneously collection of very simple+types that++\begin{itemize}+\item have no other obvious home+\item don't depend on any other complicated types+\item are used in more than one "part" of the compiler+\end{itemize}+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.Types.Basic (+        Version, bumpVersion, initialVersion,++        LeftOrRight(..),+        pickLR,++        ConTag, ConTagZ, fIRST_TAG,++        Arity, RepArity, JoinArity,++        Alignment, mkAlignment, alignmentOf, alignmentBytes,++        PromotionFlag(..), isPromoted,+        FunctionOrData(..),++        WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..),++        Fixity(..), FixityDirection(..),+        defaultFixity, maxPrecedence, minPrecedence,+        negateFixity, funTyFixity,+        compareFixity,+        LexicalFixity(..),++        RecFlag(..), isRec, isNonRec, boolToRecFlag,+        Origin(..), isGenerated,++        RuleName, pprRuleName,++        TopLevelFlag(..), isTopLevel, isNotTopLevel,++        OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,+        hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,++        Boxity(..), isBoxed,++        PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec,+        maybeParen,++        TupleSort(..), tupleSortBoxity, boxityTupleSort,+        tupleParens,++        sumParens, pprAlternative,++        -- ** The OneShotInfo type+        OneShotInfo(..),+        noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,+        bestOneShot, worstOneShot,++        OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc,+        isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs,+        strongLoopBreaker, weakLoopBreaker,++        InsideLam(..),+        OneBranch(..),+        InterestingCxt(..),+        TailCallInfo(..), tailCallInfo, zapOccTailCallInfo,+        isAlwaysTailCalled,++        EP(..),++        DefMethSpec(..),+        SwapFlag(..), flipSwap, unSwap, isSwapped,++        CompilerPhase(..), PhaseNum,++        Activation(..), isActive, isActiveIn, competesWith,+        isNeverActive, isAlwaysActive, isEarlyActive,+        activeAfterInitial, activeDuringFinal,++        RuleMatchInfo(..), isConLike, isFunLike,+        InlineSpec(..), noUserInlineSpec,+        InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,+        neverInlinePragma, dfunInlinePragma,+        isDefaultInlinePragma,+        isInlinePragma, isInlinablePragma, isAnyInlinePragma,+        inlinePragmaSpec, inlinePragmaSat,+        inlinePragmaActivation, inlinePragmaRuleMatchInfo,+        setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,+        pprInline, pprInlineDebug,++        SuccessFlag(..), succeeded, failed, successIf,++        IntegralLit(..), FractionalLit(..),+        negateIntegralLit, negateFractionalLit,+        mkIntegralLit, mkFractionalLit,+        integralFractionalLit,++        SourceText(..), pprWithSourceText,++        IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,++        SpliceExplicitFlag(..),++        TypeOrKind(..), isTypeLevel, isKindLevel+   ) where++import GhcPrelude++import FastString+import Outputable+import GHC.Types.SrcLoc ( Located,unLoc )+import Data.Data hiding (Fixity, Prefix, Infix)+import Data.Function (on)+import Data.Bits+import qualified Data.Semigroup as Semi++{-+************************************************************************+*                                                                      *+          Binary choice+*                                                                      *+************************************************************************+-}++data LeftOrRight = CLeft | CRight+                 deriving( Eq, Data )++pickLR :: LeftOrRight -> (a,a) -> a+pickLR CLeft  (l,_) = l+pickLR CRight (_,r) = r++instance Outputable LeftOrRight where+  ppr CLeft    = text "Left"+  ppr CRight   = text "Right"++{-+************************************************************************+*                                                                      *+\subsection[Arity]{Arity}+*                                                                      *+************************************************************************+-}++-- | The number of value arguments that can be applied to a value before it does+-- "real work". So:+--  fib 100     has arity 0+--  \x -> fib x has arity 1+-- See also Note [Definition of arity] in GHC.Core.Arity+type Arity = Int++-- | Representation Arity+--+-- The number of represented arguments that can be applied to a value before it does+-- "real work". So:+--  fib 100                    has representation arity 0+--  \x -> fib x                has representation arity 1+--  \(# x, y #) -> fib (x + y) has representation arity 2+type RepArity = Int++-- | The number of arguments that a join point takes. Unlike the arity of a+-- function, this is a purely syntactic property and is fixed when the join+-- point is created (or converted from a value). Both type and value arguments+-- are counted.+type JoinArity = Int++{-+************************************************************************+*                                                                      *+              Constructor tags+*                                                                      *+************************************************************************+-}++-- | Constructor Tag+--+-- Type of the tags associated with each constructor possibility or superclass+-- selector+type ConTag = Int++-- | A *zero-indexed* constructor tag+type ConTagZ = Int++fIRST_TAG :: ConTag+-- ^ Tags are allocated from here for real constructors+--   or for superclass selectors+fIRST_TAG =  1++{-+************************************************************************+*                                                                      *+\subsection[Alignment]{Alignment}+*                                                                      *+************************************************************************+-}++-- | A power-of-two alignment+newtype Alignment = Alignment { alignmentBytes :: Int } deriving (Eq, Ord)++-- Builds an alignment, throws on non power of 2 input. This is not+-- ideal, but convenient for internal use and better then silently+-- passing incorrect data.+mkAlignment :: Int -> Alignment+mkAlignment n+  | n == 1 = Alignment 1+  | n == 2 = Alignment 2+  | n == 4 = Alignment 4+  | n == 8 = Alignment 8+  | n == 16 = Alignment 16+  | n == 32 = Alignment 32+  | n == 64 = Alignment 64+  | n == 128 = Alignment 128+  | n == 256 = Alignment 256+  | n == 512 = Alignment 512+  | otherwise = panic "mkAlignment: received either a non power of 2 argument or > 512"++-- Calculates an alignment of a number. x is aligned at N bytes means+-- the remainder from x / N is zero. Currently, interested in N <= 8,+-- but can be expanded to N <= 16 or N <= 32 if used within SSE or AVX+-- context.+alignmentOf :: Int -> Alignment+alignmentOf x = case x .&. 7 of+  0 -> Alignment 8+  4 -> Alignment 4+  2 -> Alignment 2+  _ -> Alignment 1++instance Outputable Alignment where+  ppr (Alignment m) = ppr m+{-+************************************************************************+*                                                                      *+         One-shot information+*                                                                      *+************************************************************************+-}++-- | If the 'Id' is a lambda-bound variable then it may have lambda-bound+-- variable info. Sometimes we know whether the lambda binding this variable+-- is a \"one-shot\" lambda; that is, whether it is applied at most once.+--+-- This information may be useful in optimisation, as computations may+-- safely be floated inside such a lambda without risk of duplicating+-- work.+data OneShotInfo+  = NoOneShotInfo -- ^ No information+  | OneShotLam    -- ^ The lambda is applied at most once.+  deriving (Eq)++-- | It is always safe to assume that an 'Id' has no lambda-bound variable information+noOneShotInfo :: OneShotInfo+noOneShotInfo = NoOneShotInfo++isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool+isOneShotInfo OneShotLam = True+isOneShotInfo _          = False++hasNoOneShotInfo NoOneShotInfo = True+hasNoOneShotInfo _             = False++worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo+worstOneShot NoOneShotInfo _             = NoOneShotInfo+worstOneShot OneShotLam    os            = os++bestOneShot NoOneShotInfo os         = os+bestOneShot OneShotLam    _          = OneShotLam++pprOneShotInfo :: OneShotInfo -> SDoc+pprOneShotInfo NoOneShotInfo = empty+pprOneShotInfo OneShotLam    = text "OneShot"++instance Outputable OneShotInfo where+    ppr = pprOneShotInfo++{-+************************************************************************+*                                                                      *+           Swap flag+*                                                                      *+************************************************************************+-}++data SwapFlag+  = NotSwapped  -- Args are: actual,   expected+  | IsSwapped   -- Args are: expected, actual++instance Outputable SwapFlag where+  ppr IsSwapped  = text "Is-swapped"+  ppr NotSwapped = text "Not-swapped"++flipSwap :: SwapFlag -> SwapFlag+flipSwap IsSwapped  = NotSwapped+flipSwap NotSwapped = IsSwapped++isSwapped :: SwapFlag -> Bool+isSwapped IsSwapped  = True+isSwapped NotSwapped = False++unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b+unSwap NotSwapped f a b = f a b+unSwap IsSwapped  f a b = f b a+++{- *********************************************************************+*                                                                      *+           Promotion flag+*                                                                      *+********************************************************************* -}++-- | Is a TyCon a promoted data constructor or just a normal type constructor?+data PromotionFlag+  = NotPromoted+  | IsPromoted+  deriving ( Eq, Data )++isPromoted :: PromotionFlag -> Bool+isPromoted IsPromoted  = True+isPromoted NotPromoted = False++instance Outputable PromotionFlag where+  ppr NotPromoted = text "NotPromoted"+  ppr IsPromoted  = text "IsPromoted"++{-+************************************************************************+*                                                                      *+\subsection[FunctionOrData]{FunctionOrData}+*                                                                      *+************************************************************************+-}++data FunctionOrData = IsFunction | IsData+    deriving (Eq, Ord, Data)++instance Outputable FunctionOrData where+    ppr IsFunction = text "(function)"+    ppr IsData     = text "(data)"++{-+************************************************************************+*                                                                      *+\subsection[Version]{Module and identifier version numbers}+*                                                                      *+************************************************************************+-}++type Version = Int++bumpVersion :: Version -> Version+bumpVersion v = v+1++initialVersion :: Version+initialVersion = 1++{-+************************************************************************+*                                                                      *+                Deprecations+*                                                                      *+************************************************************************+-}++-- | A String Literal in the source, including its original raw format for use by+-- source to source manipulation tools.+data StringLiteral = StringLiteral+                       { sl_st :: SourceText, -- literal raw source.+                                              -- See not [Literal source text]+                         sl_fs :: FastString  -- literal string value+                       } deriving Data++instance Eq StringLiteral where+  (StringLiteral _ a) == (StringLiteral _ b) = a == b++instance Outputable StringLiteral where+  ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)++-- | Warning Text+--+-- reason/explanation from a WARNING or DEPRECATED pragma+data WarningTxt = WarningTxt (Located SourceText)+                             [Located StringLiteral]+                | DeprecatedTxt (Located SourceText)+                                [Located StringLiteral]+    deriving (Eq, Data)++instance Outputable WarningTxt where+    ppr (WarningTxt    lsrc ws)+      = case unLoc lsrc of+          NoSourceText   -> pp_ws ws+          SourceText src -> text src <+> pp_ws ws <+> text "#-}"++    ppr (DeprecatedTxt lsrc  ds)+      = case unLoc lsrc of+          NoSourceText   -> pp_ws ds+          SourceText src -> text src <+> pp_ws ds <+> text "#-}"++pp_ws :: [Located StringLiteral] -> SDoc+pp_ws [l] = ppr $ unLoc l+pp_ws ws+  = text "["+    <+> vcat (punctuate comma (map (ppr . unLoc) ws))+    <+> text "]"+++pprWarningTxtForMsg :: WarningTxt -> SDoc+pprWarningTxtForMsg (WarningTxt    _ ws)+                     = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))+pprWarningTxtForMsg (DeprecatedTxt _ ds)+                     = text "Deprecated:" <+>+                       doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))++{-+************************************************************************+*                                                                      *+                Rules+*                                                                      *+************************************************************************+-}++type RuleName = FastString++pprRuleName :: RuleName -> SDoc+pprRuleName rn = doubleQuotes (ftext rn)++{-+************************************************************************+*                                                                      *+\subsection[Fixity]{Fixity info}+*                                                                      *+************************************************************************+-}++------------------------+data Fixity = Fixity SourceText Int FixityDirection+  -- Note [Pragma source text]+  deriving Data++instance Outputable Fixity where+    ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec]++instance Eq Fixity where -- Used to determine if two fixities conflict+  (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2++------------------------+data FixityDirection = InfixL | InfixR | InfixN+                     deriving (Eq, Data)++instance Outputable FixityDirection where+    ppr InfixL = text "infixl"+    ppr InfixR = text "infixr"+    ppr InfixN = text "infix"++------------------------+maxPrecedence, minPrecedence :: Int+maxPrecedence = 9+minPrecedence = 0++defaultFixity :: Fixity+defaultFixity = Fixity NoSourceText maxPrecedence InfixL++negateFixity, funTyFixity :: Fixity+-- Wired-in fixities+negateFixity = Fixity NoSourceText 6 InfixL  -- Fixity of unary negate+funTyFixity  = Fixity NoSourceText (-1) InfixR  -- Fixity of '->', see #15235++{-+Consider++\begin{verbatim}+        a `op1` b `op2` c+\end{verbatim}+@(compareFixity op1 op2)@ tells which way to arrange application, or+whether there's an error.+-}++compareFixity :: Fixity -> Fixity+              -> (Bool,         -- Error please+                  Bool)         -- Associate to the right: a op1 (b op2 c)+compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)+  = case prec1 `compare` prec2 of+        GT -> left+        LT -> right+        EQ -> case (dir1, dir2) of+                        (InfixR, InfixR) -> right+                        (InfixL, InfixL) -> left+                        _                -> error_please+  where+    right        = (False, True)+    left         = (False, False)+    error_please = (True,  False)++-- |Captures the fixity of declarations as they are parsed. This is not+-- necessarily the same as the fixity declaration, as the normal fixity may be+-- overridden using parens or backticks.+data LexicalFixity = Prefix | Infix deriving (Data,Eq)++instance Outputable LexicalFixity where+  ppr Prefix = text "Prefix"+  ppr Infix  = text "Infix"++{-+************************************************************************+*                                                                      *+\subsection[Top-level/local]{Top-level/not-top level flag}+*                                                                      *+************************************************************************+-}++data TopLevelFlag+  = TopLevel+  | NotTopLevel++isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool++isNotTopLevel NotTopLevel = True+isNotTopLevel TopLevel    = False++isTopLevel TopLevel     = True+isTopLevel NotTopLevel  = False++instance Outputable TopLevelFlag where+  ppr TopLevel    = text "<TopLevel>"+  ppr NotTopLevel = text "<NotTopLevel>"++{-+************************************************************************+*                                                                      *+                Boxity flag+*                                                                      *+************************************************************************+-}++data Boxity+  = Boxed+  | Unboxed+  deriving( Eq, Data )++isBoxed :: Boxity -> Bool+isBoxed Boxed   = True+isBoxed Unboxed = False++instance Outputable Boxity where+  ppr Boxed   = text "Boxed"+  ppr Unboxed = text "Unboxed"++{-+************************************************************************+*                                                                      *+                Recursive/Non-Recursive flag+*                                                                      *+************************************************************************+-}++-- | Recursivity Flag+data RecFlag = Recursive+             | NonRecursive+             deriving( Eq, Data )++isRec :: RecFlag -> Bool+isRec Recursive    = True+isRec NonRecursive = False++isNonRec :: RecFlag -> Bool+isNonRec Recursive    = False+isNonRec NonRecursive = True++boolToRecFlag :: Bool -> RecFlag+boolToRecFlag True  = Recursive+boolToRecFlag False = NonRecursive++instance Outputable RecFlag where+  ppr Recursive    = text "Recursive"+  ppr NonRecursive = text "NonRecursive"++{-+************************************************************************+*                                                                      *+                Code origin+*                                                                      *+************************************************************************+-}++data Origin = FromSource+            | Generated+            deriving( Eq, Data )++isGenerated :: Origin -> Bool+isGenerated Generated = True+isGenerated FromSource = False++instance Outputable Origin where+  ppr FromSource  = text "FromSource"+  ppr Generated   = text "Generated"++{-+************************************************************************+*                                                                      *+                Instance overlap flag+*                                                                      *+************************************************************************+-}++-- | The semantics allowed for overlapping instances for a particular+-- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a+-- explanation of the `isSafeOverlap` field.+--+-- - 'ApiAnnotation.AnnKeywordId' :+--      'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or+--                              @'\{-\# OVERLAPPING'@ or+--                              @'\{-\# OVERLAPS'@ or+--                              @'\{-\# INCOHERENT'@,+--      'ApiAnnotation.AnnClose' @`\#-\}`@,++-- For details on above see note [Api annotations] in ApiAnnotation+data OverlapFlag = OverlapFlag+  { overlapMode   :: OverlapMode+  , isSafeOverlap :: Bool+  } deriving (Eq, Data)++setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag+setOverlapModeMaybe f Nothing  = f+setOverlapModeMaybe f (Just m) = f { overlapMode = m }++hasIncoherentFlag :: OverlapMode -> Bool+hasIncoherentFlag mode =+  case mode of+    Incoherent   _ -> True+    _              -> False++hasOverlappableFlag :: OverlapMode -> Bool+hasOverlappableFlag mode =+  case mode of+    Overlappable _ -> True+    Overlaps     _ -> True+    Incoherent   _ -> True+    _              -> False++hasOverlappingFlag :: OverlapMode -> Bool+hasOverlappingFlag mode =+  case mode of+    Overlapping  _ -> True+    Overlaps     _ -> True+    Incoherent   _ -> True+    _              -> False++data OverlapMode  -- See Note [Rules for instance lookup] in GHC.Core.InstEnv+  = NoOverlap SourceText+                  -- See Note [Pragma source text]+    -- ^ This instance must not overlap another `NoOverlap` instance.+    -- However, it may be overlapped by `Overlapping` instances,+    -- and it may overlap `Overlappable` instances.+++  | Overlappable SourceText+                  -- See Note [Pragma source text]+    -- ^ Silently ignore this instance if you find a+    -- more specific one that matches the constraint+    -- you are trying to resolve+    --+    -- Example: constraint (Foo [Int])+    --   instance                      Foo [Int]+    --   instance {-# OVERLAPPABLE #-} Foo [a]+    --+    -- Since the second instance has the Overlappable flag,+    -- the first instance will be chosen (otherwise+    -- its ambiguous which to choose)+++  | Overlapping SourceText+                  -- See Note [Pragma source text]+    -- ^ Silently ignore any more general instances that may be+    --   used to solve the constraint.+    --+    -- Example: constraint (Foo [Int])+    --   instance {-# OVERLAPPING #-} Foo [Int]+    --   instance                     Foo [a]+    --+    -- Since the first instance has the Overlapping flag,+    -- the second---more general---instance will be ignored (otherwise+    -- it is ambiguous which to choose)+++  | Overlaps SourceText+                  -- See Note [Pragma source text]+    -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.++  | Incoherent SourceText+                  -- See Note [Pragma source text]+    -- ^ Behave like Overlappable and Overlapping, and in addition pick+    -- an an arbitrary one if there are multiple matching candidates, and+    -- don't worry about later instantiation+    --+    -- Example: constraint (Foo [b])+    -- instance {-# INCOHERENT -} Foo [Int]+    -- instance                   Foo [a]+    -- Without the Incoherent flag, we'd complain that+    -- instantiating 'b' would change which instance+    -- was chosen. See also note [Incoherent instances] in GHC.Core.InstEnv++  deriving (Eq, Data)+++instance Outputable OverlapFlag where+   ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)++instance Outputable OverlapMode where+   ppr (NoOverlap    _) = empty+   ppr (Overlappable _) = text "[overlappable]"+   ppr (Overlapping  _) = text "[overlapping]"+   ppr (Overlaps     _) = text "[overlap ok]"+   ppr (Incoherent   _) = text "[incoherent]"++pprSafeOverlap :: Bool -> SDoc+pprSafeOverlap True  = text "[safe]"+pprSafeOverlap False = empty++{-+************************************************************************+*                                                                      *+                Precedence+*                                                                      *+************************************************************************+-}++-- | A general-purpose pretty-printing precedence type.+newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show)+-- See Note [Precedence in types]++topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec :: PprPrec+topPrec = PprPrec 0 -- No parens+sigPrec = PprPrec 1 -- Explicit type signatures+funPrec = PprPrec 2 -- Function args; no parens for constructor apps+                    -- See [Type operator precedence] for why both+                    -- funPrec and opPrec exist.+opPrec  = PprPrec 2 -- Infix operator+starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *)+                     -- See Note [Star kind precedence]+appPrec  = PprPrec 4 -- Constructor args; no parens for atomic++maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc+maybeParen ctxt_prec inner_prec pretty+  | ctxt_prec < inner_prec = pretty+  | otherwise              = parens pretty++{- Note [Precedence in types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Many pretty-printing functions have type+    ppr_ty :: PprPrec -> Type -> SDoc++The PprPrec gives the binding strength of the context.  For example, in+   T ty1 ty2+we will pretty-print 'ty1' and 'ty2' with the call+  (ppr_ty appPrec ty)+to indicate that the context is that of an argument of a TyConApp.++We use this consistently for Type and HsType.++Note [Type operator precedence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't keep the fixity of type operators in the operator. So the+pretty printer follows the following precedence order:++   TyConPrec         Type constructor application+   TyOpPrec/FunPrec  Operator application and function arrow++We have funPrec and opPrec to represent the precedence of function+arrow and type operators respectively, but currently we implement+funPrec == opPrec, so that we don't distinguish the two. Reason:+it's hard to parse a type like+    a ~ b => c * d -> e - f++By treating opPrec = funPrec we end up with more parens+    (a ~ b) => (c * d) -> (e - f)++But the two are different constructors of PprPrec so we could make+(->) bind more or less tightly if we wanted.++Note [Star kind precedence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We parenthesize the (*) kind to avoid two issues:++1. Printing invalid or incorrect code.+   For example, instead of  type F @(*) x = x+         GHC used to print  type F @*   x = x+   However, (@*) is a type operator, not a kind application.++2. Printing kinds that are correct but hard to read.+   Should  Either * Int  be read as  Either (*) Int+                              or as  (*) Either Int  ?+   This depends on whether -XStarIsType is enabled, but it would be+   easier if we didn't have to check for the flag when reading the code.++At the same time, we cannot parenthesize (*) blindly.+Consider this Haskell98 kind:          ((* -> *) -> *) -> *+With parentheses, it is less readable: (((*) -> (*)) -> (*)) -> (*)++The solution is to assign a special precedence to (*), 'starPrec', which is+higher than 'funPrec' but lower than 'appPrec':++   F * * *   becomes  F (*) (*) (*)+   F A * B   becomes  F A (*) B+   Proxy *   becomes  Proxy (*)+   a * -> *  becomes  a (*) -> *+-}++{-+************************************************************************+*                                                                      *+                Tuples+*                                                                      *+************************************************************************+-}++data TupleSort+  = BoxedTuple+  | UnboxedTuple+  | ConstraintTuple+  deriving( Eq, Data )++instance Outputable TupleSort where+  ppr ts = text $+    case ts of+      BoxedTuple      -> "BoxedTuple"+      UnboxedTuple    -> "UnboxedTuple"+      ConstraintTuple -> "ConstraintTuple"++tupleSortBoxity :: TupleSort -> Boxity+tupleSortBoxity BoxedTuple      = Boxed+tupleSortBoxity UnboxedTuple    = Unboxed+tupleSortBoxity ConstraintTuple = Boxed++boxityTupleSort :: Boxity -> TupleSort+boxityTupleSort Boxed   = BoxedTuple+boxityTupleSort Unboxed = UnboxedTuple++tupleParens :: TupleSort -> SDoc -> SDoc+tupleParens BoxedTuple      p = parens p+tupleParens UnboxedTuple    p = text "(#" <+> p <+> ptext (sLit "#)")+tupleParens ConstraintTuple p   -- In debug-style write (% Eq a, Ord b %)+  = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)"))+               (parens p)++{-+************************************************************************+*                                                                      *+                Sums+*                                                                      *+************************************************************************+-}++sumParens :: SDoc -> SDoc+sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")++-- | Pretty print an alternative in an unboxed sum e.g. "| a | |".+pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use+               -> a           -- ^ The things to be pretty printed+               -> ConTag      -- ^ Alternative (one-based)+               -> Arity       -- ^ Arity+               -> SDoc        -- ^ 'SDoc' where the alternative havs been pretty+                              -- printed and finally packed into a paragraph.+pprAlternative pp x alt arity =+    fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar)++{-+************************************************************************+*                                                                      *+\subsection[Generic]{Generic flag}+*                                                                      *+************************************************************************++This is the "Embedding-Projection pair" datatype, it contains+two pieces of code (normally either RenamedExpr's or Id's)+If we have a such a pair (EP from to), the idea is that 'from' and 'to'+represents functions of type++        from :: T -> Tring+        to   :: Tring -> T++And we should have++        to (from x) = x++T and Tring are arbitrary, but typically T is the 'main' type while+Tring is the 'representation' type.  (This just helps us remember+whether to use 'from' or 'to'.+-}++-- | Embedding Projection pair+data EP a = EP { fromEP :: a,   -- :: T -> Tring+                 toEP   :: a }  -- :: Tring -> T++{-+Embedding-projection pairs are used in several places:++First of all, each type constructor has an EP associated with it, the+code in EP converts (datatype T) from T to Tring and back again.++Secondly, when we are filling in Generic methods (in the typechecker,+tcMethodBinds), we are constructing bimaps by induction on the structure+of the type of the method signature.+++************************************************************************+*                                                                      *+\subsection{Occurrence information}+*                                                                      *+************************************************************************++This data type is used exclusively by the simplifier, but it appears in a+SubstResult, which is currently defined in GHC.Types.Var.Env, which is pretty+near the base of the module hierarchy.  So it seemed simpler to put the defn of+OccInfo here, safely at the bottom+-}++-- | identifier Occurrence Information+data OccInfo+  = ManyOccs        { occ_tail    :: !TailCallInfo }+                        -- ^ There are many occurrences, or unknown occurrences++  | IAmDead             -- ^ Marks unused variables.  Sometimes useful for+                        -- lambda and case-bound variables.++  | OneOcc          { occ_in_lam  :: !InsideLam+                    , occ_one_br  :: !OneBranch+                    , occ_int_cxt :: !InterestingCxt+                    , occ_tail    :: !TailCallInfo }+                        -- ^ Occurs exactly once (per branch), not inside a rule++  -- | This identifier breaks a loop of mutually recursive functions. The field+  -- marks whether it is only a loop breaker due to a reference in a rule+  | IAmALoopBreaker { occ_rules_only :: !RulesOnly+                    , occ_tail       :: !TailCallInfo }+                        -- Note [LoopBreaker OccInfo]+  deriving (Eq)++type RulesOnly = Bool++{-+Note [LoopBreaker OccInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~+   IAmALoopBreaker True  <=> A "weak" or rules-only loop breaker+                             Do not preInlineUnconditionally++   IAmALoopBreaker False <=> A "strong" loop breaker+                             Do not inline at all++See OccurAnal Note [Weak loop breakers]+-}++noOccInfo :: OccInfo+noOccInfo = ManyOccs { occ_tail = NoTailCallInfo }++isManyOccs :: OccInfo -> Bool+isManyOccs ManyOccs{} = True+isManyOccs _          = False++seqOccInfo :: OccInfo -> ()+seqOccInfo occ = occ `seq` ()++-----------------+-- | Interesting Context+data InterestingCxt+  = IsInteresting+    -- ^ Function: is applied+    --   Data value: scrutinised by a case with at least one non-DEFAULT branch+  | NotInteresting+  deriving (Eq)++-- | If there is any 'interesting' identifier occurrence, then the+-- aggregated occurrence info of that identifier is considered interesting.+instance Semi.Semigroup InterestingCxt where+  NotInteresting <> x = x+  IsInteresting  <> _ = IsInteresting++instance Monoid InterestingCxt where+  mempty = NotInteresting+  mappend = (Semi.<>)++-----------------+-- | Inside Lambda+data InsideLam+  = IsInsideLam+    -- ^ Occurs inside a non-linear lambda+    -- Substituting a redex for this occurrence is+    -- dangerous because it might duplicate work.+  | NotInsideLam+  deriving (Eq)++-- | If any occurrence of an identifier is inside a lambda, then the+-- occurrence info of that identifier marks it as occurring inside a lambda+instance Semi.Semigroup InsideLam where+  NotInsideLam <> x = x+  IsInsideLam  <> _ = IsInsideLam++instance Monoid InsideLam where+  mempty = NotInsideLam+  mappend = (Semi.<>)++-----------------+data OneBranch+  = InOneBranch+    -- ^ One syntactic occurrence: Occurs in only one case branch+    -- so no code-duplication issue to worry about+  | MultipleBranches+  deriving (Eq)++-----------------+data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo]+                  | NoTailCallInfo+  deriving (Eq)++tailCallInfo :: OccInfo -> TailCallInfo+tailCallInfo IAmDead   = NoTailCallInfo+tailCallInfo other     = occ_tail other++zapOccTailCallInfo :: OccInfo -> OccInfo+zapOccTailCallInfo IAmDead   = IAmDead+zapOccTailCallInfo occ       = occ { occ_tail = NoTailCallInfo }++isAlwaysTailCalled :: OccInfo -> Bool+isAlwaysTailCalled occ+  = case tailCallInfo occ of AlwaysTailCalled{} -> True+                             NoTailCallInfo     -> False++instance Outputable TailCallInfo where+  ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ]+  ppr _                     = empty++-----------------+strongLoopBreaker, weakLoopBreaker :: OccInfo+strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo+weakLoopBreaker   = IAmALoopBreaker True  NoTailCallInfo++isWeakLoopBreaker :: OccInfo -> Bool+isWeakLoopBreaker (IAmALoopBreaker{}) = True+isWeakLoopBreaker _                   = False++isStrongLoopBreaker :: OccInfo -> Bool+isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True+  -- Loop-breaker that breaks a non-rule cycle+isStrongLoopBreaker _                                            = False++isDeadOcc :: OccInfo -> Bool+isDeadOcc IAmDead = True+isDeadOcc _       = False++isOneOcc :: OccInfo -> Bool+isOneOcc (OneOcc {}) = True+isOneOcc _           = False++zapFragileOcc :: OccInfo -> OccInfo+-- Keep only the most robust data: deadness, loop-breaker-hood+zapFragileOcc (OneOcc {}) = noOccInfo+zapFragileOcc occ         = zapOccTailCallInfo occ++instance Outputable OccInfo where+  -- only used for debugging; never parsed.  KSW 1999-07+  ppr (ManyOccs tails)     = pprShortTailCallInfo tails+  ppr IAmDead              = text "Dead"+  ppr (IAmALoopBreaker rule_only tails)+        = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails+        where+          pp_ro | rule_only = char '!'+                | otherwise = empty+  ppr (OneOcc inside_lam one_branch int_cxt tail_info)+        = text "Once" <> pp_lam inside_lam <> pp_br one_branch <> pp_args int_cxt <> pp_tail+        where+          pp_lam IsInsideLam     = char 'L'+          pp_lam NotInsideLam    = empty+          pp_br MultipleBranches = char '*'+          pp_br InOneBranch      = empty+          pp_args IsInteresting  = char '!'+          pp_args NotInteresting = empty+          pp_tail                = pprShortTailCallInfo tail_info++pprShortTailCallInfo :: TailCallInfo -> SDoc+pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar)+pprShortTailCallInfo NoTailCallInfo        = empty++{-+Note [TailCallInfo]+~~~~~~~~~~~~~~~~~~~+The occurrence analyser determines what can be made into a join point, but it+doesn't change the binder into a JoinId because then it would be inconsistent+with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to+change the IdDetails.++The AlwaysTailCalled marker actually means slightly more than simply that the+function is always tail-called. See Note [Invariants on join points].++This info is quite fragile and should not be relied upon unless the occurrence+analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of+the join-point-hood of a binder; a join id itself will not be marked+AlwaysTailCalled.++Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that+being tail-called would mean that the variable could only appear once per branch+(thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join+point can also be invoked from other join points, not just from case branches:++  let j1 x = ...+      j2 y = ... j1 z {- tail call -} ...+  in case w of+       A -> j1 v+       B -> j2 u+       C -> j2 q++Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get+ManyOccs and j2 will get `OneOcc { occ_one_br = True }`.++************************************************************************+*                                                                      *+                Default method specification+*                                                                      *+************************************************************************++The DefMethSpec enumeration just indicates what sort of default method+is used for a class. It is generated from source code, and present in+interface files; it is converted to Class.DefMethInfo before begin put in a+Class object.+-}++-- | Default Method Specification+data DefMethSpec ty+  = VanillaDM     -- Default method given with polymorphic code+  | GenericDM ty  -- Default method given with code of this type++instance Outputable (DefMethSpec ty) where+  ppr VanillaDM      = text "{- Has default method -}"+  ppr (GenericDM {}) = text "{- Has generic default method -}"++{-+************************************************************************+*                                                                      *+\subsection{Success flag}+*                                                                      *+************************************************************************+-}++data SuccessFlag = Succeeded | Failed++instance Outputable SuccessFlag where+    ppr Succeeded = text "Succeeded"+    ppr Failed    = text "Failed"++successIf :: Bool -> SuccessFlag+successIf True  = Succeeded+successIf False = Failed++succeeded, failed :: SuccessFlag -> Bool+succeeded Succeeded = True+succeeded Failed    = False++failed Succeeded = False+failed Failed    = True++{-+************************************************************************+*                                                                      *+\subsection{Source Text}+*                                                                      *+************************************************************************+Keeping Source Text for source to source conversions++Note [Pragma source text]+~~~~~~~~~~~~~~~~~~~~~~~~~+The lexer does a case-insensitive match for pragmas, as well as+accepting both UK and US spelling variants.++So++  {-# SPECIALISE #-}+  {-# SPECIALIZE #-}+  {-# Specialize #-}++will all generate ITspec_prag token for the start of the pragma.++In order to be able to do source to source conversions, the original+source text for the token needs to be preserved, hence the+`SourceText` field.++So the lexer will then generate++  ITspec_prag "{ -# SPECIALISE"+  ITspec_prag "{ -# SPECIALIZE"+  ITspec_prag "{ -# Specialize"++for the cases above.+ [without the space between '{' and '-', otherwise this comment won't parse]+++Note [Literal source text]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The lexer/parser converts literals from their original source text+versions to an appropriate internal representation. This is a problem+for tools doing source to source conversions, so the original source+text is stored in literals where this can occur.++Motivating examples for HsLit++  HsChar          '\n'       == '\x20`+  HsCharPrim      '\x41`#    == `A`+  HsString        "\x20\x41" == " A"+  HsStringPrim    "\x20"#    == " "#+  HsInt           001        == 1+  HsIntPrim       002#       == 2#+  HsWordPrim      003##      == 3##+  HsInt64Prim     004##      == 4##+  HsWord64Prim    005##      == 5##+  HsInteger       006        == 6++For OverLitVal++  HsIntegral      003      == 0x003+  HsIsString      "\x41nd" == "And"+-}++ -- Note [Literal source text],[Pragma source text]+data SourceText = SourceText String+                | NoSourceText -- ^ For when code is generated, e.g. TH,+                               -- deriving. The pretty printer will then make+                               -- its own representation of the item.+                deriving (Data, Show, Eq )++instance Outputable SourceText where+  ppr (SourceText s) = text "SourceText" <+> text s+  ppr NoSourceText   = text "NoSourceText"++-- | Special combinator for showing string literals.+pprWithSourceText :: SourceText -> SDoc -> SDoc+pprWithSourceText NoSourceText     d = d+pprWithSourceText (SourceText src) _ = text src++{-+************************************************************************+*                                                                      *+\subsection{Activation}+*                                                                      *+************************************************************************++When a rule or inlining is active+-}++-- | Phase Number+type PhaseNum = Int  -- Compilation phase+                     -- Phases decrease towards zero+                     -- Zero is the last phase++data CompilerPhase+  = Phase PhaseNum+  | InitialPhase    -- The first phase -- number = infinity!++instance Outputable CompilerPhase where+   ppr (Phase n)    = int n+   ppr InitialPhase = text "InitialPhase"++activeAfterInitial :: Activation+-- Active in the first phase after the initial phase+-- Currently we have just phases [2,1,0]+activeAfterInitial = ActiveAfter NoSourceText 2++activeDuringFinal :: Activation+-- Active in the final simplification phase (which is repeated)+activeDuringFinal = ActiveAfter NoSourceText 0++-- See note [Pragma source text]+data Activation = NeverActive+                | AlwaysActive+                | ActiveBefore SourceText PhaseNum+                  -- Active only *strictly before* this phase+                | ActiveAfter SourceText PhaseNum+                  -- Active in this phase and later+                deriving( Eq, Data )+                  -- Eq used in comparing rules in GHC.Hs.Decls++-- | Rule Match Information+data RuleMatchInfo = ConLike                    -- See Note [CONLIKE pragma]+                   | FunLike+                   deriving( Eq, Data, Show )+        -- Show needed for Lexer.x++data InlinePragma            -- Note [InlinePragma]+  = InlinePragma+      { inl_src    :: SourceText -- Note [Pragma source text]+      , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act]++      , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n+                                     --            explicit (non-type, non-dictionary) args+                                     --   That is, inl_sat describes the number of *source-code*+                                     --   arguments the thing must be applied to.  We add on the+                                     --   number of implicit, dictionary arguments when making+                                     --   the Unfolding, and don't look at inl_sat further++      , inl_act    :: Activation     -- Says during which phases inlining is allowed+                                     -- See Note [inl_inline and inl_act]++      , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?+    } deriving( Eq, Data )++-- | Inline Specification+data InlineSpec   -- What the user's INLINE pragma looked like+  = Inline       -- User wrote INLINE+  | Inlinable    -- User wrote INLINABLE+  | NoInline     -- User wrote NOINLINE+  | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE+                 -- e.g. in `defaultInlinePragma` or when created by CSE+  deriving( Eq, Data, Show )+        -- Show needed for Lexer.x++{- Note [InlinePragma]+~~~~~~~~~~~~~~~~~~~~~~+This data type mirrors what you can write in an INLINE or NOINLINE pragma in+the source program.++If you write nothing at all, you get defaultInlinePragma:+   inl_inline = NoUserInline+   inl_act    = AlwaysActive+   inl_rule   = FunLike++It's not possible to get that combination by *writing* something, so+if an Id has defaultInlinePragma it means the user didn't specify anything.++If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding.++If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.makeCorePair++Note [inl_inline and inl_act]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* inl_inline says what the user wrote: did she say INLINE, NOINLINE,+  INLINABLE, or nothing at all++* inl_act says in what phases the unfolding is active or inactive+  E.g  If you write INLINE[1]    then inl_act will be set to ActiveAfter 1+       If you write NOINLINE[1]  then inl_act will be set to ActiveBefore 1+       If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1+  So note that inl_act does not say what pragma you wrote: it just+  expresses its consequences++* inl_act just says when the unfolding is active; it doesn't say what+  to inline.  If you say INLINE f, then f's inl_act will be AlwaysActive,+  but in addition f will get a "stable unfolding" with UnfoldingGuidance+  that tells the inliner to be pretty eager about it.++Note [CONLIKE pragma]+~~~~~~~~~~~~~~~~~~~~~+The ConLike constructor of a RuleMatchInfo is aimed at the following.+Consider first+    {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-}+    g b bs = let x = b:bs in ..x...x...(r x)...+Now, the rule applies to the (r x) term, because GHC "looks through"+the definition of 'x' to see that it is (b:bs).++Now consider+    {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}+    g v = let x = f v in ..x...x...(r x)...+Normally the (r x) would *not* match the rule, because GHC would be+scared about duplicating the redex (f v), so it does not "look+through" the bindings.++However the CONLIKE modifier says to treat 'f' like a constructor in+this situation, and "look through" the unfolding for x.  So (r x)+fires, yielding (f (v+1)).++This is all controlled with a user-visible pragma:+     {-# NOINLINE CONLIKE [1] f #-}++The main effects of CONLIKE are:++    - The occurrence analyser (OccAnal) and simplifier (Simplify) treat+      CONLIKE thing like constructors, by ANF-ing them++    - New function GHC.Core.Utils.exprIsExpandable is like exprIsCheap, but+      additionally spots applications of CONLIKE functions++    - A CoreUnfolding has a field that caches exprIsExpandable++    - The rule matcher consults this field.  See+      Note [Expanding variables] in GHC.Core.Rules.+-}++isConLike :: RuleMatchInfo -> Bool+isConLike ConLike = True+isConLike _       = False++isFunLike :: RuleMatchInfo -> Bool+isFunLike FunLike = True+isFunLike _       = False++noUserInlineSpec :: InlineSpec -> Bool+noUserInlineSpec NoUserInline = True+noUserInlineSpec _            = False++defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma+  :: InlinePragma+defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"+                                   , inl_act = AlwaysActive+                                   , inl_rule = FunLike+                                   , inl_inline = NoUserInline+                                   , inl_sat = Nothing }++alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }+neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }++inlinePragmaSpec :: InlinePragma -> InlineSpec+inlinePragmaSpec = inl_inline++-- A DFun has an always-active inline activation so that+-- exprIsConApp_maybe can "see" its unfolding+-- (However, its actual Unfolding is a DFunUnfolding, which is+--  never inlined other than via exprIsConApp_maybe.)+dfunInlinePragma   = defaultInlinePragma { inl_act  = AlwaysActive+                                         , inl_rule = ConLike }++isDefaultInlinePragma :: InlinePragma -> Bool+isDefaultInlinePragma (InlinePragma { inl_act = activation+                                    , inl_rule = match_info+                                    , inl_inline = inline })+  = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info++isInlinePragma :: InlinePragma -> Bool+isInlinePragma prag = case inl_inline prag of+                        Inline -> True+                        _      -> False++isInlinablePragma :: InlinePragma -> Bool+isInlinablePragma prag = case inl_inline prag of+                           Inlinable -> True+                           _         -> False++isAnyInlinePragma :: InlinePragma -> Bool+-- INLINE or INLINABLE+isAnyInlinePragma prag = case inl_inline prag of+                        Inline    -> True+                        Inlinable -> True+                        _         -> False++inlinePragmaSat :: InlinePragma -> Maybe Arity+inlinePragmaSat = inl_sat++inlinePragmaActivation :: InlinePragma -> Activation+inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation++inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo+inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info++setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma+setInlinePragmaActivation prag activation = prag { inl_act = activation }++setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma+setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }++instance Outputable Activation where+   ppr AlwaysActive       = empty+   ppr NeverActive        = brackets (text "~")+   ppr (ActiveBefore _ n) = brackets (char '~' <> int n)+   ppr (ActiveAfter  _ n) = brackets (int n)++instance Outputable RuleMatchInfo where+   ppr ConLike = text "CONLIKE"+   ppr FunLike = text "FUNLIKE"++instance Outputable InlineSpec where+   ppr Inline       = text "INLINE"+   ppr NoInline     = text "NOINLINE"+   ppr Inlinable    = text "INLINABLE"+   ppr NoUserInline = text "NOUSERINLINE" -- what is better?++instance Outputable InlinePragma where+  ppr = pprInline++pprInline :: InlinePragma -> SDoc+pprInline = pprInline' True++pprInlineDebug :: InlinePragma -> SDoc+pprInlineDebug = pprInline' False++pprInline' :: Bool           -- True <=> do not display the inl_inline field+           -> InlinePragma+           -> SDoc+pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation+                                    , inl_rule = info, inl_sat = mb_arity })+    = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info+    where+      pp_inl x = if emptyInline then empty else ppr x++      pp_act Inline   AlwaysActive = empty+      pp_act NoInline NeverActive  = empty+      pp_act _        act          = ppr act++      pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar)+             | otherwise           = empty+      pp_info | isFunLike info = empty+              | otherwise      = ppr info++isActive :: CompilerPhase -> Activation -> Bool+isActive InitialPhase AlwaysActive      = True+isActive InitialPhase (ActiveBefore {}) = True+isActive InitialPhase _                 = False+isActive (Phase p)    act               = isActiveIn p act++isActiveIn :: PhaseNum -> Activation -> Bool+isActiveIn _ NeverActive        = False+isActiveIn _ AlwaysActive       = True+isActiveIn p (ActiveAfter _ n)  = p <= n+isActiveIn p (ActiveBefore _ n) = p >  n++competesWith :: Activation -> Activation -> Bool+-- See Note [Activation competition]+competesWith NeverActive       _                = False+competesWith _                 NeverActive      = False+competesWith AlwaysActive      _                = True++competesWith (ActiveBefore {})  AlwaysActive      = True+competesWith (ActiveBefore {})  (ActiveBefore {}) = True+competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b++competesWith (ActiveAfter {})  AlwaysActive      = False+competesWith (ActiveAfter {})  (ActiveBefore {}) = False+competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b++{- Note [Competing activations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Sometimes a RULE and an inlining may compete, or two RULES.+See Note [Rules and inlining/other rules] in GHC.HsToCore.++We say that act1 "competes with" act2 iff+   act1 is active in the phase when act2 *becomes* active+NB: remember that phases count *down*: 2, 1, 0!++It's too conservative to ensure that the two are never simultaneously+active.  For example, a rule might be always active, and an inlining+might switch on in phase 2.  We could switch off the rule, but it does+no harm.+-}++isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool+isNeverActive NeverActive = True+isNeverActive _           = False++isAlwaysActive AlwaysActive = True+isAlwaysActive _            = False++isEarlyActive AlwaysActive      = True+isEarlyActive (ActiveBefore {}) = True+isEarlyActive _                 = False++-- | Integral Literal+--+-- Used (instead of Integer) to represent negative zegative zero which is+-- required for NegativeLiterals extension to correctly parse `-0::Double`+-- as negative zero. See also #13211.+data IntegralLit+  = IL { il_text :: SourceText+       , il_neg :: Bool -- See Note [Negative zero]+       , il_value :: Integer+       }+  deriving (Data, Show)++mkIntegralLit :: Integral a => a -> IntegralLit+mkIntegralLit i = IL { il_text = SourceText (show i_integer)+                     , il_neg = i < 0+                     , il_value = i_integer }+  where+    i_integer :: Integer+    i_integer = toInteger i++negateIntegralLit :: IntegralLit -> IntegralLit+negateIntegralLit (IL text neg value)+  = case text of+      SourceText ('-':src) -> IL (SourceText src)       False    (negate value)+      SourceText      src  -> IL (SourceText ('-':src)) True     (negate value)+      NoSourceText         -> IL NoSourceText          (not neg) (negate value)++-- | Fractional Literal+--+-- Used (instead of Rational) to represent exactly the floating point literal that we+-- encountered in the user's source program. This allows us to pretty-print exactly what+-- the user wrote, which is important e.g. for floating point numbers that can't represented+-- as Doubles (we used to via Double for pretty-printing). See also #2245.+data FractionalLit+  = FL { fl_text :: SourceText     -- How the value was written in the source+       , fl_neg :: Bool            -- See Note [Negative zero]+       , fl_value :: Rational      -- Numeric value of the literal+       }+  deriving (Data, Show)+  -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on++mkFractionalLit :: Real a => a -> FractionalLit+mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))+                           -- Converting to a Double here may technically lose+                           -- precision (see #15502). We could alternatively+                           -- convert to a Rational for the most accuracy, but+                           -- it would cause Floats and Doubles to be displayed+                           -- strangely, so we opt not to do this. (In contrast+                           -- to mkIntegralLit, where we always convert to an+                           -- Integer for the highest accuracy.)+                       , fl_neg = r < 0+                       , fl_value = toRational r }++negateFractionalLit :: FractionalLit -> FractionalLit+negateFractionalLit (FL text neg value)+  = case text of+      SourceText ('-':src) -> FL (SourceText src)     False value+      SourceText      src  -> FL (SourceText ('-':src)) True  value+      NoSourceText         -> FL NoSourceText (not neg) (negate value)++integralFractionalLit :: Bool -> Integer -> FractionalLit+integralFractionalLit neg i = FL { fl_text = SourceText (show i),+                                   fl_neg = neg,+                                   fl_value = fromInteger i }++-- Comparison operations are needed when grouping literals+-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal)++instance Eq IntegralLit where+  (==) = (==) `on` il_value++instance Ord IntegralLit where+  compare = compare `on` il_value++instance Outputable IntegralLit where+  ppr (IL (SourceText src) _ _) = text src+  ppr (IL NoSourceText _ value) = text (show value)++instance Eq FractionalLit where+  (==) = (==) `on` fl_value++instance Ord FractionalLit where+  compare = compare `on` fl_value++instance Outputable FractionalLit where+  ppr f = pprWithSourceText (fl_text f) (rational (fl_value f))++{-+************************************************************************+*                                                                      *+    IntWithInf+*                                                                      *+************************************************************************++Represents an integer or positive infinity++-}++-- | An integer or infinity+data IntWithInf = Int {-# UNPACK #-} !Int+                | Infinity+  deriving Eq++-- | A representation of infinity+infinity :: IntWithInf+infinity = Infinity++instance Ord IntWithInf where+  compare Infinity Infinity = EQ+  compare (Int _)  Infinity = LT+  compare Infinity (Int _)  = GT+  compare (Int a)  (Int b)  = a `compare` b++instance Outputable IntWithInf where+  ppr Infinity = char '∞'+  ppr (Int n)  = int n++instance Num IntWithInf where+  (+) = plusWithInf+  (*) = mulWithInf++  abs Infinity = Infinity+  abs (Int n)  = Int (abs n)++  signum Infinity = Int 1+  signum (Int n)  = Int (signum n)++  fromInteger = Int . fromInteger++  (-) = panic "subtracting IntWithInfs"++intGtLimit :: Int -> IntWithInf -> Bool+intGtLimit _ Infinity = False+intGtLimit n (Int m)  = n > m++-- | Add two 'IntWithInf's+plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf+plusWithInf Infinity _        = Infinity+plusWithInf _        Infinity = Infinity+plusWithInf (Int a)  (Int b)  = Int (a + b)++-- | Multiply two 'IntWithInf's+mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf+mulWithInf Infinity _        = Infinity+mulWithInf _        Infinity = Infinity+mulWithInf (Int a)  (Int b)  = Int (a * b)++-- | Turn a positive number into an 'IntWithInf', where 0 represents infinity+treatZeroAsInf :: Int -> IntWithInf+treatZeroAsInf 0 = Infinity+treatZeroAsInf n = Int n++-- | Inject any integer into an 'IntWithInf'+mkIntWithInf :: Int -> IntWithInf+mkIntWithInf = Int++data SpliceExplicitFlag+          = ExplicitSplice | -- ^ <=> $(f x y)+            ImplicitSplice   -- ^ <=> f x y,  i.e. a naked top level expression+    deriving Data++{- *********************************************************************+*                                                                      *+                        Types vs Kinds+*                                                                      *+********************************************************************* -}++-- | Flag to see whether we're type-checking terms or kind-checking types+data TypeOrKind = TypeLevel | KindLevel+  deriving Eq++instance Outputable TypeOrKind where+  ppr TypeLevel = text "TypeLevel"+  ppr KindLevel = text "KindLevel"++isTypeLevel :: TypeOrKind -> Bool+isTypeLevel TypeLevel = True+isTypeLevel KindLevel = False++isKindLevel :: TypeOrKind -> Bool+isKindLevel TypeLevel = False+isKindLevel KindLevel = True
+ compiler/GHC/Types/CostCentre.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE DeriveDataTypeable #-}+module GHC.Types.CostCentre (+        CostCentre(..), CcName, CCFlavour(..),+                -- All abstract except to friend: ParseIface.y++        CostCentreStack,+        CollectedCCs, emptyCollectedCCs, collectCC,+        currentCCS, dontCareCCS,+        isCurrentCCS,+        maybeSingletonCCS,++        mkUserCC, mkAutoCC, mkAllCafsCC,+        mkSingletonCCS,+        isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule,++        pprCostCentreCore,+        costCentreUserName, costCentreUserNameFS,+        costCentreSrcSpan,++        cmpCostCentre   -- used for removing dups in a list+    ) where++import GhcPrelude++import Binary+import GHC.Types.Var+import GHC.Types.Name+import GHC.Types.Module+import GHC.Types.Unique+import Outputable+import GHC.Types.SrcLoc+import FastString+import Util+import GHC.Types.CostCentre.State++import Data.Data++-----------------------------------------------------------------------------+-- Cost Centres++-- | A Cost Centre is a single @{-# SCC #-}@ annotation.++data CostCentre+  = NormalCC {+                cc_flavour  :: CCFlavour,+                 -- ^ Two cost centres may have the same name and+                 -- module but different SrcSpans, so we need a way to+                 -- distinguish them easily and give them different+                 -- object-code labels.  So every CostCentre has an+                 -- associated flavour that indicates how it was+                 -- generated, and flavours that allow multiple instances+                 -- of the same name and module have a deterministic 0-based+                 -- index.+                cc_name :: CcName,      -- ^ Name of the cost centre itself+                cc_mod  :: Module,      -- ^ Name of module defining this CC.+                cc_loc  :: SrcSpan+    }++  | AllCafsCC {+                cc_mod  :: Module,      -- Name of module defining this CC.+                cc_loc  :: SrcSpan+    }+  deriving Data++type CcName = FastString++-- | The flavour of a cost centre.+--+-- Index fields represent 0-based indices giving source-code ordering of+-- centres with the same module, name, and flavour.+data CCFlavour = CafCC -- ^ Auto-generated top-level thunk+               | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression+               | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration+               | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage+               deriving (Eq, Ord, Data)++-- | Extract the index from a flavour+flavourIndex :: CCFlavour -> Int+flavourIndex CafCC = 0+flavourIndex (ExprCC x) = unCostCentreIndex x+flavourIndex (DeclCC x) = unCostCentreIndex x+flavourIndex (HpcCC x) = unCostCentreIndex x++instance Eq CostCentre where+        c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }++instance Ord CostCentre where+        compare = cmpCostCentre++cmpCostCentre :: CostCentre -> CostCentre -> Ordering++cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2})+  = m1 `compare` m2++cmpCostCentre NormalCC {cc_flavour = f1, cc_mod =  m1, cc_name = n1}+              NormalCC {cc_flavour = f2, cc_mod =  m2, cc_name = n2}+    -- first key is module name, then centre name, then flavour+  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2)++cmpCostCentre other_1 other_2+  = let+        tag1 = tag_CC other_1+        tag2 = tag_CC other_2+    in+    if tag1 < tag2 then LT else GT+  where+    tag_CC :: CostCentre -> Int+    tag_CC (NormalCC   {}) = 0+    tag_CC (AllCafsCC  {}) = 1+++-----------------------------------------------------------------------------+-- Predicates on CostCentre++isCafCC :: CostCentre -> Bool+isCafCC (AllCafsCC {})                  = True+isCafCC (NormalCC {cc_flavour = CafCC}) = True+isCafCC _                               = False++-- | Is this a cost-centre which records scc counts+isSccCountCC :: CostCentre -> Bool+isSccCountCC cc | isCafCC cc  = False+                | otherwise   = True++-- | Is this a cost-centre which can be sccd ?+sccAbleCC :: CostCentre -> Bool+sccAbleCC cc | isCafCC cc = False+             | otherwise  = True++ccFromThisModule :: CostCentre -> Module -> Bool+ccFromThisModule cc m = cc_mod cc == m+++-----------------------------------------------------------------------------+-- Building cost centres++mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre+mkUserCC cc_name mod loc flavour+  = NormalCC { cc_name = cc_name, cc_mod =  mod, cc_loc = loc,+               cc_flavour = flavour+    }++mkAutoCC :: Id -> Module -> CostCentre+mkAutoCC id mod+  = NormalCC { cc_name = str, cc_mod =  mod,+               cc_loc = nameSrcSpan (getName id),+               cc_flavour = CafCC+    }+  where+        name = getName id+        -- beware: only external names are guaranteed to have unique+        -- Occnames.  If the name is not external, we must append its+        -- Unique.+        -- See bug #249, tests prof001, prof002,  also #2411+        str | isExternalName name = occNameFS (getOccName id)+            | otherwise           = occNameFS (getOccName id)+                                    `appendFS`+                                    mkFastString ('_' : show (getUnique name))+mkAllCafsCC :: Module -> SrcSpan -> CostCentre+mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc }++-----------------------------------------------------------------------------+-- Cost Centre Stacks++-- | A Cost Centre Stack is something that can be attached to a closure.+-- This is either:+--+--      * the current cost centre stack (CCCS)+--      * a pre-defined cost centre stack (there are several+--        pre-defined CCSs, see below).++data CostCentreStack+  = CurrentCCS          -- Pinned on a let(rec)-bound+                        -- thunk/function/constructor, this says that the+                        -- cost centre to be attached to the object, when it+                        -- is allocated, is whatever is in the+                        -- current-cost-centre-stack register.++  | DontCareCCS         -- We need a CCS to stick in static closures+                        -- (for data), but we *don't* expect them to+                        -- accumulate any costs.  But we still need+                        -- the placeholder.  This CCS is it.++  | SingletonCCS CostCentre++  deriving (Eq, Ord)    -- needed for Ord on CLabel+++-- synonym for triple which describes the cost centre info in the generated+-- code for a module.+type CollectedCCs+  = ( [CostCentre]       -- local cost-centres that need to be decl'd+    , [CostCentreStack]  -- pre-defined "singleton" cost centre stacks+    )++emptyCollectedCCs :: CollectedCCs+emptyCollectedCCs = ([], [])++collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs+collectCC cc ccs (c, cs) = (cc : c, ccs : cs)++currentCCS, dontCareCCS :: CostCentreStack++currentCCS              = CurrentCCS+dontCareCCS             = DontCareCCS++-----------------------------------------------------------------------------+-- Predicates on Cost-Centre Stacks++isCurrentCCS :: CostCentreStack -> Bool+isCurrentCCS CurrentCCS                 = True+isCurrentCCS _                          = False++isCafCCS :: CostCentreStack -> Bool+isCafCCS (SingletonCCS cc)              = isCafCC cc+isCafCCS _                              = False++maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre+maybeSingletonCCS (SingletonCCS cc)     = Just cc+maybeSingletonCCS _                     = Nothing++mkSingletonCCS :: CostCentre -> CostCentreStack+mkSingletonCCS cc = SingletonCCS cc+++-----------------------------------------------------------------------------+-- Printing Cost Centre Stacks.++-- The outputable instance for CostCentreStack prints the CCS as a C+-- expression.++instance Outputable CostCentreStack where+  ppr CurrentCCS        = text "CCCS"+  ppr DontCareCCS       = text "CCS_DONT_CARE"+  ppr (SingletonCCS cc) = ppr cc <> text "_ccs"+++-----------------------------------------------------------------------------+-- Printing Cost Centres+--+-- There are several different ways in which we might want to print a+-- cost centre:+--+--      - the name of the cost centre, for profiling output (a C string)+--      - the label, i.e. C label for cost centre in .hc file.+--      - the debugging name, for output in -ddump things+--      - the interface name, for printing in _scc_ exprs in iface files.+--+-- The last 3 are derived from costCentreStr below.  The first is given+-- by costCentreName.++instance Outputable CostCentre where+  ppr cc = getPprStyle $ \ sty ->+           if codeStyle sty+           then ppCostCentreLbl cc+           else text (costCentreUserName cc)++-- Printing in Core+pprCostCentreCore :: CostCentre -> SDoc+pprCostCentreCore (AllCafsCC {cc_mod = m})+  = text "__sccC" <+> braces (ppr m)+pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n,+                             cc_mod = m, cc_loc = loc})+  = text "__scc" <+> braces (hsep [+        ppr m <> char '.' <> ftext n,+        pprFlavourCore flavour,+        whenPprDebug (ppr loc)+    ])++-- ^ Print a flavour in Core+pprFlavourCore :: CCFlavour -> SDoc+pprFlavourCore CafCC = text "__C"+pprFlavourCore f     = pprIdxCore $ flavourIndex f++-- ^ Print a flavour's index in Core+pprIdxCore :: Int -> SDoc+pprIdxCore 0 = empty+pprIdxCore idx = whenPprDebug $ ppr idx++-- Printing as a C label+ppCostCentreLbl :: CostCentre -> SDoc+ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = ppr m <> text "_CAFs_cc"+ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m})+  = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>+        ppFlavourLblComponent f <> text "_cc"++-- ^ Print the flavour component of a C label+ppFlavourLblComponent :: CCFlavour -> SDoc+ppFlavourLblComponent CafCC = text "CAF"+ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i+ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i+ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i++-- ^ Print the flavour index component of a C label+ppIdxLblComponent :: CostCentreIndex -> SDoc+ppIdxLblComponent n =+  case unCostCentreIndex n of+    0 -> empty+    n -> ppr n++-- This is the name to go in the user-displayed string,+-- recorded in the cost centre declaration+costCentreUserName :: CostCentre -> String+costCentreUserName = unpackFS . costCentreUserNameFS++costCentreUserNameFS :: CostCentre -> FastString+costCentreUserNameFS (AllCafsCC {})  = mkFastString "CAF"+costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf})+  =  case is_caf of+      CafCC -> mkFastString "CAF:" `appendFS` name+      _     -> name++costCentreSrcSpan :: CostCentre -> SrcSpan+costCentreSrcSpan = cc_loc++instance Binary CCFlavour where+    put_ bh CafCC = do+            putByte bh 0+    put_ bh (ExprCC i) = do+            putByte bh 1+            put_ bh i+    put_ bh (DeclCC i) = do+            putByte bh 2+            put_ bh i+    put_ bh (HpcCC i) = do+            putByte bh 3+            put_ bh i+    get bh = do+            h <- getByte bh+            case h of+              0 -> do return CafCC+              1 -> ExprCC <$> get bh+              2 -> DeclCC <$> get bh+              _ -> HpcCC <$> get bh++instance Binary CostCentre where+    put_ bh (NormalCC aa ab ac _ad) = do+            putByte bh 0+            put_ bh aa+            put_ bh ab+            put_ bh ac+    put_ bh (AllCafsCC ae _af) = do+            putByte bh 1+            put_ bh ae+    get bh = do+            h <- getByte bh+            case h of+              0 -> do aa <- get bh+                      ab <- get bh+                      ac <- get bh+                      return (NormalCC aa ab ac noSrcSpan)+              _ -> do ae <- get bh+                      return (AllCafsCC ae noSrcSpan)++    -- We ignore the SrcSpans in CostCentres when we serialise them,+    -- and set the SrcSpans to noSrcSpan when deserialising.  This is+    -- ok, because we only need the SrcSpan when declaring the+    -- CostCentre in the original module, it is not used by importing+    -- modules.
+ compiler/GHC/Types/CostCentre/State.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module GHC.Types.CostCentre.State+   ( CostCentreState+   , newCostCentreState+   , CostCentreIndex+   , unCostCentreIndex+   , getCCIndex+   )+where++import GhcPrelude+import FastString+import FastStringEnv++import Data.Data+import Binary++-- | Per-module state for tracking cost centre indices.+--+-- See documentation of 'CostCentre.cc_flavour' for more details.+newtype CostCentreState = CostCentreState (FastStringEnv Int)++-- | Initialize cost centre state.+newCostCentreState :: CostCentreState+newCostCentreState = CostCentreState emptyFsEnv++-- | An index into a given cost centre module,name,flavour set+newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int }+  deriving (Eq, Ord, Data, Binary)++-- | Get a new index for a given cost centre name.+getCCIndex :: FastString+           -> CostCentreState+           -> (CostCentreIndex, CostCentreState)+getCCIndex nm (CostCentreState m) =+    (CostCentreIndex idx, CostCentreState m')+  where+    m_idx = lookupFsEnv m nm+    idx = maybe 0 id m_idx+    m' = extendFsEnv m nm (idx + 1)
+ compiler/GHC/Types/Cpr.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+-- | Types for the Constructed Product Result lattice. "GHC.Core.Op.CprAnal" and "GHC.Core.Op.WorkWrap.Lib"+-- are its primary customers via 'idCprInfo'.+module GHC.Types.Cpr (+    CprResult, topCpr, botCpr, conCpr, asConCpr,+    CprType (..), topCprType, botCprType, conCprType,+    lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy,+    CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig+  ) where++import GhcPrelude++import GHC.Types.Basic+import Outputable+import Binary++--+-- * CprResult+--++-- | The constructed product result lattice.+--+-- @+--                    NoCPR+--                      |+--                 ConCPR ConTag+--                      |+--                    BotCPR+-- @+data CprResult = NoCPR          -- ^ Top of the lattice+               | ConCPR !ConTag -- ^ Returns a constructor from a data type+               | BotCPR         -- ^ Bottom of the lattice+               deriving( Eq, Show )++lubCpr :: CprResult -> CprResult -> CprResult+lubCpr (ConCPR t1) (ConCPR t2)+  | t1 == t2               = ConCPR t1+lubCpr BotCPR      cpr     = cpr+lubCpr cpr         BotCPR  = cpr+lubCpr _           _       = NoCPR++topCpr :: CprResult+topCpr = NoCPR++botCpr :: CprResult+botCpr = BotCPR++conCpr :: ConTag -> CprResult+conCpr = ConCPR++trimCpr :: CprResult -> CprResult+trimCpr ConCPR{} = NoCPR+trimCpr cpr      = cpr++asConCpr :: CprResult -> Maybe ConTag+asConCpr (ConCPR t)  = Just t+asConCpr NoCPR       = Nothing+asConCpr BotCPR      = Nothing++--+-- * CprType+--++-- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper.+data CprType+  = CprType+  { ct_arty :: !Arity     -- ^ Number of value arguments the denoted expression+                          --   eats before returning the 'ct_cpr'+  , ct_cpr  :: !CprResult -- ^ 'CprResult' eventually unleashed when applied to+                          --   'ct_arty' arguments+  }++instance Eq CprType where+  a == b =  ct_cpr a == ct_cpr b+         && (ct_arty a == ct_arty b || ct_cpr a == topCpr)++topCprType :: CprType+topCprType = CprType 0 topCpr++botCprType :: CprType+botCprType = CprType 0 botCpr -- TODO: Figure out if arity 0 does what we want... Yes it does: arity zero means we may unleash it under any number of incoming arguments++conCprType :: ConTag -> CprType+conCprType con_tag = CprType 0 (conCpr con_tag)++lubCprType :: CprType -> CprType -> CprType+lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2)+  -- The arity of bottom CPR types can be extended arbitrarily.+  | cpr1 == botCpr && n1 <= n2 = ty2+  | cpr2 == botCpr && n2 <= n1 = ty1+  -- There might be non-bottom CPR types with mismatching arities.+  -- Consider test DmdAnalGADTs. We want to return top in these cases.+  | n1 == n2                   = CprType n1 (lubCpr cpr1 cpr2)+  | otherwise                  = topCprType++applyCprTy :: CprType -> CprType+applyCprTy (CprType n res)+  | n > 0         = CprType (n-1) res+  | res == botCpr = botCprType+  | otherwise     = topCprType++abstractCprTy :: CprType -> CprType+abstractCprTy (CprType n res)+  | res == topCpr = topCprType+  | otherwise     = CprType (n+1) res++ensureCprTyArity :: Arity -> CprType -> CprType+ensureCprTyArity n ty@(CprType m _)+  | n == m    = ty+  | otherwise = topCprType++trimCprTy :: CprType -> CprType+trimCprTy (CprType arty res) = CprType arty (trimCpr res)++-- | The arity of the wrapped 'CprType' is the arity at which it is safe+-- to unleash. See Note [Understanding DmdType and StrictSig] in GHC.Types.Demand+newtype CprSig = CprSig { getCprSig :: CprType }+  deriving (Eq, Binary)++-- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig'+-- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in+-- Demand+mkCprSigForArity :: Arity -> CprType -> CprSig+mkCprSigForArity arty ty = CprSig (ensureCprTyArity arty ty)++topCprSig :: CprSig+topCprSig = CprSig topCprType++mkCprSig :: Arity -> CprResult -> CprSig+mkCprSig arty cpr = CprSig (CprType arty cpr)++seqCprSig :: CprSig -> ()+seqCprSig sig = sig `seq` ()++instance Outputable CprResult where+  ppr NoCPR        = empty+  ppr (ConCPR n)   = char 'm' <> int n+  ppr BotCPR       = char 'b'++instance Outputable CprType where+  ppr (CprType arty res) = ppr arty <> ppr res++-- | Only print the CPR result+instance Outputable CprSig where+  ppr (CprSig ty) = ppr (ct_cpr ty)++instance Binary CprResult where+  put_ bh (ConCPR n)   = do { putByte bh 0; put_ bh n }+  put_ bh NoCPR        = putByte bh 1+  put_ bh BotCPR       = putByte bh 2++  get  bh = do+          h <- getByte bh+          case h of+            0 -> do { n <- get bh; return (ConCPR n) }+            1 -> return NoCPR+            _ -> return BotCPR++instance Binary CprType where+  put_ bh (CprType arty cpr) = do+    put_ bh arty+    put_ bh cpr+  get  bh = CprType <$> get bh <*> get bh
+ compiler/GHC/Types/Demand.hs view
@@ -0,0 +1,1974 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[Demand]{@Demand@: A decoupled implementation of a demand domain}+-}++{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Types.Demand (+        StrDmd, UseDmd(..), Count,++        Demand, DmdShell, CleanDemand, getStrDmd, getUseDmd,+        mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd,+        toCleanDmd,+        absDmd, topDmd, botDmd, seqDmd,+        lubDmd, bothDmd,+        lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd,+        isTopDmd, isAbsDmd, isSeqDmd,+        peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd,+        addCaseBndrDmd,++        DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,+        nopDmdType, botDmdType, mkDmdType,+        addDemand, ensureArgs,+        BothDmdArg, mkBothDmdArg, toBothDmdArg,++        DmdEnv, emptyDmdEnv,+        peelFV, findIdDemand,++        Divergence(..), lubDivergence, isBotDiv, isTopDiv, topDiv, botDiv,+        appIsBottom, isBottomingSig, pprIfaceStrictSig,+        StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,+        nopSig, botSig, cprProdSig,+        isTopSig, hasDemandEnvSig,+        splitStrictSig, strictSigDmdEnv,+        increaseStrictSigArity, etaExpandStrictSig,++        seqDemand, seqDemandList, seqDmdType, seqStrictSig,++        evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd,+        splitDmdTy, splitFVs,+        deferAfterIO,+        postProcessUnsat, postProcessDmdType,++        splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds,+        mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig,+        dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots,+        TypeShape(..), peelTsFuns, trimToType,++        useCount, isUsedOnce, reuseEnv,+        zapUsageDemand, zapUsageEnvSig,+        zapUsedOnceDemand, zapUsedOnceSig,+        strictifyDictDmd, strictifyDmd++     ) where++#include "HsVersions.h"++import GhcPrelude++import Outputable+import GHC.Types.Var ( Var )+import GHC.Types.Var.Env+import GHC.Types.Unique.FM+import Util+import GHC.Types.Basic+import Binary+import Maybes           ( orElse )++import GHC.Core.Type    ( Type )+import GHC.Core.TyCon   ( isNewTyCon, isClassTyCon )+import GHC.Core.DataCon ( splitDataProductType_maybe )++{-+************************************************************************+*                                                                      *+        Joint domain for Strictness and Absence+*                                                                      *+************************************************************************+-}++data JointDmd s u = JD { sd :: s, ud :: u }+  deriving ( Eq, Show )++getStrDmd :: JointDmd s u -> s+getStrDmd = sd++getUseDmd :: JointDmd s u -> u+getUseDmd = ud++-- Pretty-printing+instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where+  ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u)++-- Well-formedness preserving constructors for the joint domain+mkJointDmd :: s -> u -> JointDmd s u+mkJointDmd s u = JD { sd = s, ud = u }++mkJointDmds :: [s] -> [u] -> [JointDmd s u]+mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as+++{-+************************************************************************+*                                                                      *+            Strictness domain+*                                                                      *+************************************************************************++          Lazy+           |+        HeadStr+        /     \+    SCall      SProd+        \     /+        HyperStr++Note [Exceptions and strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to smart about catching exceptions, but we aren't anymore.+See #14998 for the way it's resolved at the moment.++Here's a historic breakdown:++Apparently, exception handling prim-ops didn't use to have any special+strictness signatures, thus defaulting to topSig, which assumes they use their+arguments lazily. Joachim was the first to realise that we could provide richer+information. Thus, in 0558911f91c (Dec 13), he added signatures to+primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call+their argument, which is useful information for usage analysis. Still with a+'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine.++In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a+'strictApply1Dmd' leads to substantial performance gains. That was at the cost+of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in+28638dfe79e (Dec 15).++Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712,+Ben opened #11222. Simon made the demand analyser "understand catch" in+9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call+its argument strictly, but also swallow any thrown exceptions in+'postProcessDivergence'. This was realized by extending the 'Str' constructor of+'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and+adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element+between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330,+so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17).++This left the other variants like 'catchRetry#' having 'catchArgDmd', which is+where #14998 picked up. Item 1 was concerned with measuring the impact of also+making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that+there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7+(Apr 18). There was a lot of dead code resulting from that change, that we+removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and+removed any code that was dealing with the peculiarities.++Where did the speed-ups vanish to? In #14998, item 3 established that+turning 'catch#' strict in its first argument didn't bring back any of the+alleged performance benefits. Item 2 of that ticket finally found out that it+was entirely due to 'catchException's new (since #11555) definition, which+was simply++    catchException !io handler = catch io handler++While 'catchException' is arguably the saner semantics for 'catch', it is an+internal helper function in "GHC.IO". Its use in+"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences:+Remove the bang and you find the regressions we originally wanted to avoid with+'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO".++So history keeps telling us that the only possibly correct strictness annotation+for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really+is not strict in its argument: Just try this in GHCi++  :set -XScopedTypeVariables+  import Control.Exception+  catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this")++Any analysis that assumes otherwise will be broken in some way or another+(beyond `-fno-pendantic-bottoms`).+-}++-- | Vanilla strictness domain+data StrDmd+  = HyperStr             -- ^ Hyper-strict (bottom of the lattice).+                         -- See Note [HyperStr and Use demands]++  | SCall StrDmd         -- ^ Call demand+                         -- Used only for values of function type++  | SProd [ArgStr]       -- ^ Product+                         -- Used only for values of product type+                         -- Invariant: not all components are HyperStr (use HyperStr)+                         --            not all components are Lazy     (use HeadStr)++  | HeadStr              -- ^ Head-Strict+                         -- A polymorphic demand: used for values of all types,+                         --                       including a type variable++  deriving ( Eq, Show )++-- | Strictness of a function argument.+type ArgStr = Str StrDmd++-- | Strictness demand.+data Str s = Lazy  -- ^ Lazy (top of the lattice)+           | Str s -- ^ Strict+  deriving ( Eq, Show )++-- Well-formedness preserving constructors for the Strictness domain+strBot, strTop :: ArgStr+strBot = Str HyperStr+strTop = Lazy++mkSCall :: StrDmd -> StrDmd+mkSCall HyperStr = HyperStr+mkSCall s        = SCall s++mkSProd :: [ArgStr] -> StrDmd+mkSProd sx+  | any isHyperStr sx = HyperStr+  | all isLazy     sx = HeadStr+  | otherwise         = SProd sx++isLazy :: ArgStr -> Bool+isLazy Lazy     = True+isLazy (Str {}) = False++isHyperStr :: ArgStr -> Bool+isHyperStr (Str HyperStr) = True+isHyperStr _              = False++-- Pretty-printing+instance Outputable StrDmd where+  ppr HyperStr      = char 'B'+  ppr (SCall s)     = char 'C' <> parens (ppr s)+  ppr HeadStr       = char 'S'+  ppr (SProd sx)    = char 'S' <> parens (hcat (map ppr sx))++instance Outputable ArgStr where+  ppr (Str s) = ppr s+  ppr Lazy    = char 'L'++lubArgStr :: ArgStr -> ArgStr -> ArgStr+lubArgStr Lazy     _        = Lazy+lubArgStr _        Lazy     = Lazy+lubArgStr (Str s1) (Str s2) = Str (s1 `lubStr` s2)++lubStr :: StrDmd -> StrDmd -> StrDmd+lubStr HyperStr s              = s+lubStr (SCall s1) HyperStr     = SCall s1+lubStr (SCall _)  HeadStr      = HeadStr+lubStr (SCall s1) (SCall s2)   = SCall (s1 `lubStr` s2)+lubStr (SCall _)  (SProd _)    = HeadStr+lubStr (SProd sx) HyperStr     = SProd sx+lubStr (SProd _)  HeadStr      = HeadStr+lubStr (SProd s1) (SProd s2)+    | s1 `equalLength` s2      = mkSProd (zipWith lubArgStr s1 s2)+    | otherwise                = HeadStr+lubStr (SProd _) (SCall _)     = HeadStr+lubStr HeadStr   _             = HeadStr++bothArgStr :: ArgStr -> ArgStr -> ArgStr+bothArgStr Lazy     s        = s+bothArgStr s        Lazy     = s+bothArgStr (Str s1) (Str s2) = Str (s1 `bothStr` s2)++bothStr :: StrDmd -> StrDmd -> StrDmd+bothStr HyperStr _             = HyperStr+bothStr HeadStr s              = s+bothStr (SCall _)  HyperStr    = HyperStr+bothStr (SCall s1) HeadStr     = SCall s1+bothStr (SCall s1) (SCall s2)  = SCall (s1 `bothStr` s2)+bothStr (SCall _)  (SProd _)   = HyperStr  -- Weird++bothStr (SProd _)  HyperStr    = HyperStr+bothStr (SProd s1) HeadStr     = SProd s1+bothStr (SProd s1) (SProd s2)+    | s1 `equalLength` s2      = mkSProd (zipWith bothArgStr s1 s2)+    | otherwise                = HyperStr  -- Weird+bothStr (SProd _) (SCall _)    = HyperStr++-- utility functions to deal with memory leaks+seqStrDmd :: StrDmd -> ()+seqStrDmd (SProd ds)   = seqStrDmdList ds+seqStrDmd (SCall s)    = seqStrDmd s+seqStrDmd _            = ()++seqStrDmdList :: [ArgStr] -> ()+seqStrDmdList [] = ()+seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds++seqArgStr :: ArgStr -> ()+seqArgStr Lazy    = ()+seqArgStr (Str s) = seqStrDmd s++-- Splitting polymorphic demands+splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr]+splitArgStrProdDmd n Lazy    = Just (replicate n Lazy)+splitArgStrProdDmd n (Str s) = splitStrProdDmd n s++splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr]+splitStrProdDmd n HyperStr   = Just (replicate n strBot)+splitStrProdDmd n HeadStr    = Just (replicate n strTop)+splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n),+                                     text "splitStrProdDmd" $$ ppr n $$ ppr ds )+                               Just ds+splitStrProdDmd _ (SCall {}) = Nothing+      -- This can happen when the programmer uses unsafeCoerce,+      -- and we don't then want to crash the compiler (#9208)++{-+************************************************************************+*                                                                      *+            Absence domain+*                                                                      *+************************************************************************++         Used+         /   \+     UCall   UProd+         \   /+         UHead+          |+  Count x -+        |+       Abs+-}++-- | Domain for genuine usage+data UseDmd+  = UCall Count UseDmd   -- ^ Call demand for absence.+                         -- Used only for values of function type++  | UProd [ArgUse]       -- ^ Product.+                         -- Used only for values of product type+                         -- See Note [Don't optimise UProd(Used) to Used]+                         --+                         -- Invariant: Not all components are Abs+                         -- (in that case, use UHead)++  | UHead                -- ^ May be used but its sub-components are+                         -- definitely *not* used.  For product types, UHead+                         -- is equivalent to U(AAA); see mkUProd.+                         --+                         -- UHead is needed only to express the demand+                         -- of 'seq' and 'case' which are polymorphic;+                         -- i.e. the scrutinised value is of type 'a'+                         -- rather than a product type. That's why we+                         -- can't use UProd [A,A,A]+                         --+                         -- Since (UCall _ Abs) is ill-typed, UHead doesn't+                         -- make sense for lambdas++  | Used                 -- ^ May be used and its sub-components may be used.+                         -- (top of the lattice)+  deriving ( Eq, Show )++-- Extended usage demand for absence and counting+type ArgUse = Use UseDmd++data Use u+  = Abs             -- Definitely unused+                    -- Bottom of the lattice++  | Use Count u     -- May be used with some cardinality+  deriving ( Eq, Show )++-- | Abstract counting of usages+data Count = One | Many+  deriving ( Eq, Show )++-- Pretty-printing+instance Outputable ArgUse where+  ppr Abs           = char 'A'+  ppr (Use Many a)   = ppr a+  ppr (Use One  a)   = char '1' <> char '*' <> ppr a++instance Outputable UseDmd where+  ppr Used           = char 'U'+  ppr (UCall c a)    = char 'C' <> ppr c <> parens (ppr a)+  ppr UHead          = char 'H'+  ppr (UProd as)     = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as)))++instance Outputable Count where+  ppr One  = char '1'+  ppr Many = text ""++useBot, useTop :: ArgUse+useBot     = Abs+useTop     = Use Many Used++mkUCall :: Count -> UseDmd -> UseDmd+--mkUCall c Used = Used c+mkUCall c a  = UCall c a++mkUProd :: [ArgUse] -> UseDmd+mkUProd ux+  | all (== Abs) ux    = UHead+  | otherwise          = UProd ux++lubCount :: Count -> Count -> Count+lubCount _ Many = Many+lubCount Many _ = Many+lubCount x _    = x++lubArgUse :: ArgUse -> ArgUse -> ArgUse+lubArgUse Abs x                   = x+lubArgUse x Abs                   = x+lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2)++lubUse :: UseDmd -> UseDmd -> UseDmd+lubUse UHead       u               = u+lubUse (UCall c u) UHead           = UCall c u+lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2)+lubUse (UCall _ _) _               = Used+lubUse (UProd ux) UHead            = UProd ux+lubUse (UProd ux1) (UProd ux2)+     | ux1 `equalLength` ux2       = UProd $ zipWith lubArgUse ux1 ux2+     | otherwise                   = Used+lubUse (UProd {}) (UCall {})       = Used+-- lubUse (UProd {}) Used             = Used+lubUse (UProd ux) Used             = UProd (map (`lubArgUse` useTop) ux)+lubUse Used       (UProd ux)       = UProd (map (`lubArgUse` useTop) ux)+lubUse Used _                      = Used  -- Note [Used should win]++-- `both` is different from `lub` in its treatment of counting; if+-- `both` is computed for two used, the result always has+--  cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain).+--  Also,  x `bothUse` x /= x (for anything but Abs).++bothArgUse :: ArgUse -> ArgUse -> ArgUse+bothArgUse Abs x                   = x+bothArgUse x Abs                   = x+bothArgUse (Use _ a1) (Use _ a2)   = Use Many (bothUse a1 a2)+++bothUse :: UseDmd -> UseDmd -> UseDmd+bothUse UHead       u               = u+bothUse (UCall c u) UHead           = UCall c u++-- Exciting special treatment of inner demand for call demands:+--    use `lubUse` instead of `bothUse`!+bothUse (UCall _ u1) (UCall _ u2)   = UCall Many (u1 `lubUse` u2)++bothUse (UCall {}) _                = Used+bothUse (UProd ux) UHead            = UProd ux+bothUse (UProd ux1) (UProd ux2)+      | ux1 `equalLength` ux2       = UProd $ zipWith bothArgUse ux1 ux2+      | otherwise                   = Used+bothUse (UProd {}) (UCall {})       = Used+-- bothUse (UProd {}) Used             = Used  -- Note [Used should win]+bothUse Used (UProd ux)             = UProd (map (`bothArgUse` useTop) ux)+bothUse (UProd ux) Used             = UProd (map (`bothArgUse` useTop) ux)+bothUse Used _                      = Used  -- Note [Used should win]++peelUseCall :: UseDmd -> Maybe (Count, UseDmd)+peelUseCall (UCall c u)   = Just (c,u)+peelUseCall _             = Nothing++addCaseBndrDmd :: Demand    -- On the case binder+               -> [Demand]  -- On the components of the constructor+               -> [Demand]  -- Final demands for the components of the constructor+-- See Note [Demand on case-alternative binders]+addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds+  = case mu of+     Abs     -> alt_dmds+     Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us)+             where+                Just ss = splitArgStrProdDmd arity ms  -- Guaranteed not to be a call+                Just us = splitUseProdDmd      arity u   -- Ditto+  where+    arity = length alt_dmds++{- Note [Demand on case-alternative binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The demand on a binder in a case alternative comes+  (a) From the demand on the binder itself+  (b) From the demand on the case binder+Forgetting (b) led directly to #10148.++Example. Source code:+  f x@(p,_) = if p then foo x else True++  foo (p,True) = True+  foo (p,q)    = foo (q,p)++After strictness analysis:+  f = \ (x_an1 [Dmd=<S(SL),1*U(U,1*U)>] :: (Bool, Bool)) ->+      case x_an1+      of wild_X7 [Dmd=<L,1*U(1*U,1*U)>]+      { (p_an2 [Dmd=<S,1*U>], ds_dnz [Dmd=<L,A>]) ->+      case p_an2 of _ {+        False -> GHC.Types.True;+        True -> foo wild_X7 }++It's true that ds_dnz is *itself* absent, but the use of wild_X7 means+that it is very much alive and demanded.  See #10148 for how the+consequences play out.++This is needed even for non-product types, in case the case-binder+is used but the components of the case alternative are not.++Note [Don't optimise UProd(Used) to Used]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+These two UseDmds:+   UProd [Used, Used]   and    Used+are semantically equivalent, but we do not turn the former into+the latter, for a regrettable-subtle reason.  Suppose we did.+then+  f (x,y) = (y,x)+would get+  StrDmd = Str  = SProd [Lazy, Lazy]+  UseDmd = Used = UProd [Used, Used]+But with the joint demand of <Str, Used> doesn't convey any clue+that there is a product involved, and so the worthSplittingFun+will not fire.  (We'd need to use the type as well to make it fire.)+Moreover, consider+  g h p@(_,_) = h p+This too would get <Str, Used>, but this time there really isn't any+point in w/w since the components of the pair are not used at all.++So the solution is: don't aggressively collapse UProd [Used,Used] to+Used; instead leave it as-is. In effect we are using the UseDmd to do a+little bit of boxity analysis.  Not very nice.++Note [Used should win]+~~~~~~~~~~~~~~~~~~~~~~+Both in lubUse and bothUse we want (Used `both` UProd us) to be Used.+Why?  Because Used carries the implication the whole thing is used,+box and all, so we don't want to w/w it.  If we use it both boxed and+unboxed, then we are definitely using the box, and so we are quite+likely to pay a reboxing cost.  So we make Used win here.++Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer++Baseline: (A) Not making Used win (UProd wins)+Compare with: (B) making Used win for lub and both++            Min          -0.3%     -5.6%    -10.7%    -11.0%    -33.3%+            Max          +0.3%    +45.6%    +11.5%    +11.5%     +6.9%+ Geometric Mean          -0.0%     +0.5%     +0.3%     +0.2%     -0.8%++Baseline: (B) Making Used win for both lub and both+Compare with: (C) making Used win for both, but UProd win for lub++            Min          -0.1%     -0.3%     -7.9%     -8.0%     -6.5%+            Max          +0.1%     +1.0%    +21.0%    +21.0%     +0.5%+ Geometric Mean          +0.0%     +0.0%     -0.0%     -0.1%     -0.1%+-}++-- If a demand is used multiple times (i.e. reused), than any use-once+-- mentioned there, that is not protected by a UCall, can happen many times.+markReusedDmd :: ArgUse -> ArgUse+markReusedDmd Abs         = Abs+markReusedDmd (Use _ a)   = Use Many (markReused a)++markReused :: UseDmd -> UseDmd+markReused (UCall _ u)      = UCall Many u   -- No need to recurse here+markReused (UProd ux)       = UProd (map markReusedDmd ux)+markReused u                = u++isUsedMU :: ArgUse -> Bool+-- True <=> markReusedDmd d = d+isUsedMU Abs          = True+isUsedMU (Use One _)  = False+isUsedMU (Use Many u) = isUsedU u++isUsedU :: UseDmd -> Bool+-- True <=> markReused d = d+isUsedU Used           = True+isUsedU UHead          = True+isUsedU (UProd us)     = all isUsedMU us+isUsedU (UCall One _)  = False+isUsedU (UCall Many _) = True  -- No need to recurse++-- Squashing usage demand demands+seqUseDmd :: UseDmd -> ()+seqUseDmd (UProd ds)   = seqArgUseList ds+seqUseDmd (UCall c d)  = c `seq` seqUseDmd d+seqUseDmd _            = ()++seqArgUseList :: [ArgUse] -> ()+seqArgUseList []     = ()+seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds++seqArgUse :: ArgUse -> ()+seqArgUse (Use c u)  = c `seq` seqUseDmd u+seqArgUse _          = ()++-- Splitting polymorphic Maybe-Used demands+splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse]+splitUseProdDmd n Used        = Just (replicate n useTop)+splitUseProdDmd n UHead       = Just (replicate n Abs)+splitUseProdDmd n (UProd ds)  = WARN( not (ds `lengthIs` n),+                                      text "splitUseProdDmd" $$ ppr n+                                                             $$ ppr ds )+                                Just ds+splitUseProdDmd _ (UCall _ _) = Nothing+      -- This can happen when the programmer uses unsafeCoerce,+      -- and we don't then want to crash the compiler (#9208)++useCount :: Use u -> Count+useCount Abs         = One+useCount (Use One _) = One+useCount _           = Many+++{-+************************************************************************+*                                                                      *+         Clean demand for Strictness and Usage+*                                                                      *+************************************************************************++This domain differst from JointDemand in the sense that pure absence+is taken away, i.e., we deal *only* with non-absent demands.++Note [Strict demands]+~~~~~~~~~~~~~~~~~~~~~+isStrictDmd returns true only of demands that are+   both strict+   and  used+In particular, it is False for <HyperStr, Abs>, which can and does+arise in, say (#7319)+   f x = raise# <some exception>+Then 'x' is not used, so f gets strictness <HyperStr,Abs> -> .+Now the w/w generates+   fx = let x <HyperStr,Abs> = absentError "unused"+        in raise <some exception>+At this point we really don't want to convert to+   fx = case absentError "unused" of x -> raise <some exception>+Since the program is going to diverge, this swaps one error for another,+but it's really a bad idea to *ever* evaluate an absent argument.+In #7319 we get+   T7319.exe: Oops!  Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}]++Note [Dealing with call demands]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Call demands are constructed and deconstructed coherently for+strictness and absence. For instance, the strictness signature for the+following function++f :: (Int -> (Int, Int)) -> (Int, Bool)+f g = (snd (g 3), True)++should be: <L,C(U(AU))>m+-}++type CleanDemand = JointDmd StrDmd UseDmd+     -- A demand that is at least head-strict++bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand+bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2})+  = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 }++mkHeadStrict :: CleanDemand -> CleanDemand+mkHeadStrict cd = cd { sd = HeadStr }++mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand+mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use One a }+mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use Many a }++evalDmd :: Demand+-- Evaluated strictly, and used arbitrarily deeply+evalDmd = JD { sd = Str HeadStr, ud = useTop }++mkProdDmd :: [Demand] -> CleanDemand+mkProdDmd dx+  = JD { sd = mkSProd $ map getStrDmd dx+       , ud = mkUProd $ map getUseDmd dx }++-- | Wraps the 'CleanDemand' with a one-shot call demand: @d@ -> @C1(d)@.+mkCallDmd :: CleanDemand -> CleanDemand+mkCallDmd (JD {sd = d, ud = u})+  = JD { sd = mkSCall d, ud = mkUCall One u }++-- | @mkCallDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s.+mkCallDmds :: Arity -> CleanDemand -> CleanDemand+mkCallDmds arity cd = iterate mkCallDmd cd !! arity++-- See Note [Demand on the worker] in GHC.Core.Op.WorkWrap+mkWorkerDemand :: Int -> Demand+mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) }+  where go 0 = Used+        go n = mkUCall One $ go (n-1)++cleanEvalDmd :: CleanDemand+cleanEvalDmd = JD { sd = HeadStr, ud = Used }++cleanEvalProdDmd :: Arity -> CleanDemand+cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) }+++{-+************************************************************************+*                                                                      *+           Demand: Combining Strictness and Usage+*                                                                      *+************************************************************************+-}++type Demand = JointDmd ArgStr ArgUse++lubDmd :: Demand -> Demand -> Demand+lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})+ = JD { sd = s1 `lubArgStr` s2+      , ud = a1 `lubArgUse` a2 }++bothDmd :: Demand -> Demand -> Demand+bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})+ = JD { sd = s1 `bothArgStr` s2+      , ud = a1 `bothArgUse` a2 }++lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd :: Demand++strictApply1Dmd = JD { sd = Str (SCall HeadStr)+                     , ud = Use Many (UCall One Used) }++lazyApply1Dmd = JD { sd = Lazy+                   , ud = Use One (UCall One Used) }++-- Second argument of catch#:+--    uses its arg at most once, applies it once+--    but is lazy (might not be called at all)+lazyApply2Dmd = JD { sd = Lazy+                   , ud = Use One (UCall One (UCall One Used)) }++absDmd :: Demand+absDmd = JD { sd = Lazy, ud = Abs }++topDmd :: Demand+topDmd = JD { sd = Lazy, ud = useTop }++botDmd :: Demand+botDmd = JD { sd = strBot, ud = useBot }++seqDmd :: Demand+seqDmd = JD { sd = Str HeadStr, ud = Use One UHead }++oneifyDmd :: JointDmd s (Use u) -> JointDmd s (Use u)+oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a }+oneifyDmd jd                            = jd++isTopDmd :: Demand -> Bool+-- Used to suppress pretty-printing of an uninformative demand+isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True+isTopDmd _                                    = False++isAbsDmd :: JointDmd (Str s) (Use u) -> Bool+isAbsDmd (JD {ud = Abs}) = True   -- The strictness part can be HyperStr+isAbsDmd _               = False  -- for a bottom demand++isSeqDmd :: Demand -> Bool+isSeqDmd (JD {sd = Str HeadStr, ud = Use _ UHead}) = True+isSeqDmd _                                                = False++isUsedOnce :: JointDmd (Str s) (Use u) -> Bool+isUsedOnce (JD { ud = a }) = case useCount a of+                               One  -> True+                               Many -> False++-- More utility functions for strictness+seqDemand :: Demand -> ()+seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u++seqDemandList :: [Demand] -> ()+seqDemandList [] = ()+seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds++isStrictDmd :: JointDmd (Str s) (Use u) -> Bool+-- See Note [Strict demands]+isStrictDmd (JD {ud = Abs})  = False+isStrictDmd (JD {sd = Lazy}) = False+isStrictDmd _                = True++isWeakDmd :: Demand -> Bool+isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a++cleanUseDmd_maybe :: Demand -> Maybe UseDmd+cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u+cleanUseDmd_maybe _                     = Nothing++splitFVs :: Bool   -- Thunk+         -> DmdEnv -> (DmdEnv, DmdEnv)+splitFVs is_thunk rhs_fvs+  | is_thunk  = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs+                -- It's OK to use nonDetFoldUFM_Directly because we+                -- immediately forget the ordering by putting the elements+                -- in the envs again+  | otherwise = partitionVarEnv isWeakDmd rhs_fvs+  where+    add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv)+      | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv)+      | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u })+                    , addToUFM_Directly sig_fv  uniq (JD { sd = s,    ud = Abs }) )++data TypeShape = TsFun TypeShape+               | TsProd [TypeShape]+               | TsUnk++instance Outputable TypeShape where+  ppr TsUnk        = text "TsUnk"+  ppr (TsFun ts)   = text "TsFun" <> parens (ppr ts)+  ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)++-- | @peelTsFuns n ts@ tries to peel off @n@ 'TsFun' constructors from @ts@ and+-- returns 'Just' the wrapped 'TypeShape' on success, and 'Nothing' otherwise.+peelTsFuns :: Arity -> TypeShape -> Maybe TypeShape+peelTsFuns 0 ts         = Just ts+peelTsFuns n (TsFun ts) = peelTsFuns (n-1) ts+peelTsFuns _ _          = Nothing++trimToType :: Demand -> TypeShape -> Demand+-- See Note [Trimming a demand to a type]+trimToType (JD { sd = ms, ud = mu }) ts+  = JD (go_ms ms ts) (go_mu mu ts)+  where+    go_ms :: ArgStr -> TypeShape -> ArgStr+    go_ms Lazy    _  = Lazy+    go_ms (Str s) ts = Str (go_s s ts)++    go_s :: StrDmd -> TypeShape -> StrDmd+    go_s HyperStr    _            = HyperStr+    go_s (SCall s)   (TsFun ts)   = SCall (go_s s ts)+    go_s (SProd mss) (TsProd tss)+      | equalLength mss tss       = SProd (zipWith go_ms mss tss)+    go_s _           _            = HeadStr++    go_mu :: ArgUse -> TypeShape -> ArgUse+    go_mu Abs _ = Abs+    go_mu (Use c u) ts = Use c (go_u u ts)++    go_u :: UseDmd -> TypeShape -> UseDmd+    go_u UHead       _          = UHead+    go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts)+    go_u (UProd mus) (TsProd tss)+      | equalLength mus tss      = UProd (zipWith go_mu mus tss)+    go_u _           _           = Used++{-+Note [Trimming a demand to a type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++  f :: a -> Bool+  f x = case ... of+          A g1 -> case (x |> g1) of (p,q) -> ...+          B    -> error "urk"++where A,B are the constructors of a GADT.  We'll get a U(U,U) demand+on x from the A branch, but that's a stupid demand for x itself, which+has type 'a'. Indeed we get ASSERTs going off (notably in+splitUseProdDmd, #8569).++Bottom line: we really don't want to have a binder whose demand is more+deeply-nested than its type.  There are various ways to tackle this.+When processing (x |> g1), we could "trim" the incoming demand U(U,U)+to match x's type.  But I'm currently doing so just at the moment when+we pin a demand on a binder, in GHC.Core.Op.DmdAnal.findBndrDmd.+++Note [Threshold demands]+~~~~~~~~~~~~~~~~~~~~~~~~+Threshold usage demand is generated to figure out if+cardinality-instrumented demands of a binding's free variables should+be unleashed. See also [Aggregated demand for cardinality].++Note [Replicating polymorphic demands]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some demands can be considered as polymorphic. Generally, it is+applicable to such beasts as tops, bottoms as well as Head-Used and+Head-stricts demands. For instance,++S ~ S(L, ..., L)++Also, when top or bottom is occurred as a result demand, it in fact+can be expanded to saturate a callee's arity.+-}++splitProdDmd_maybe :: Demand -> Maybe [Demand]+-- Split a product into its components, iff there is any+-- useful information to be extracted thereby+-- The demand is not necessarily strict!+splitProdDmd_maybe (JD { sd = s, ud = u })+  = case (s,u) of+      (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u+                                -> Just (mkJointDmds sx ux)+      (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s+                                -> Just (mkJointDmds sx ux)+      (Lazy,  Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)+      _ -> Nothing++{-+************************************************************************+*                                                                      *+                   Termination+*                                                                      *+************************************************************************++Divergence:     Dunno+               /+          Diverges++In a fixpoint iteration, start from Diverges+-}++data Divergence+  = Diverges    -- Definitely diverges+  | Dunno       -- Might diverge or converge+  deriving( Eq, Show )++lubDivergence :: Divergence -> Divergence ->Divergence+lubDivergence Diverges r        = r+lubDivergence r        Diverges = r+lubDivergence Dunno    Dunno    = Dunno+-- This needs to commute with defaultDmd, i.e.+-- defaultDmd (r1 `lubDivergence` r2) = defaultDmd r1 `lubDmd` defaultDmd r2+-- (See Note [Default demand on free variables] for why)++bothDivergence :: Divergence -> Divergence -> Divergence+-- See Note [Asymmetry of 'both' for DmdType and Divergence]+bothDivergence _ Diverges = Diverges+bothDivergence r Dunno    = r+-- This needs to commute with defaultDmd, i.e.+-- defaultDmd (r1 `bothDivergence` r2) = defaultDmd r1 `bothDmd` defaultDmd r2+-- (See Note [Default demand on free variables] for why)++instance Outputable Divergence where+  ppr Diverges      = char 'b'+  ppr Dunno         = empty++------------------------------------------------------------------------+-- Combined demand result                                             --+------------------------------------------------------------------------++-- [cprRes] lets us switch off CPR analysis+-- by making sure that everything uses TopRes+topDiv, botDiv :: Divergence+topDiv = Dunno+botDiv = Diverges++isTopDiv :: Divergence -> Bool+isTopDiv Dunno = True+isTopDiv _     = False++-- | True if the result diverges or throws an exception+isBotDiv :: Divergence -> Bool+isBotDiv Diverges = True+isBotDiv _        = False++-- See Notes [Default demand on free variables]+-- and [defaultDmd vs. resTypeArgDmd]+defaultDmd :: Divergence -> Demand+defaultDmd Dunno = absDmd+defaultDmd _     = botDmd  -- Diverges++resTypeArgDmd :: Divergence -> Demand+-- TopRes and BotRes are polymorphic, so that+--      BotRes === (Bot -> BotRes) === ...+--      TopRes === (Top -> TopRes) === ...+-- This function makes that concrete+-- Also see Note [defaultDmd vs. resTypeArgDmd]+resTypeArgDmd Dunno = topDmd+resTypeArgDmd _     = botDmd   -- Diverges++{-+Note [defaultDmd and resTypeArgDmd]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++These functions are similar: They express the demand on something not+explicitly mentioned in the environment resp. the argument list. Yet they are+different:+ * Variables not mentioned in the free variables environment are definitely+   unused, so we can use absDmd there.+ * Further arguments *can* be used, of course. Hence topDmd is used.+++************************************************************************+*                                                                      *+           Demand environments and types+*                                                                      *+************************************************************************+-}++type DmdEnv = VarEnv Demand   -- See Note [Default demand on free variables]++data DmdType = DmdType+                  DmdEnv        -- Demand on explicitly-mentioned+                                --      free variables+                  [Demand]      -- Demand on arguments+                  Divergence     -- See [Nature of result demand]++{-+Note [Nature of result demand]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A Divergence contains information about termination (currently distinguishing+definite divergence and no information; it is possible to include definite+convergence here), and CPR information about the result.++The semantics of this depends on whether we are looking at a DmdType, i.e. the+demand put on by an expression _under a specific incoming demand_ on its+environment, or at a StrictSig describing a demand transformer.++For a+ * DmdType, the termination information is true given the demand it was+   generated with, while for+ * a StrictSig it holds after applying enough arguments.++The CPR information, though, is valid after the number of arguments mentioned+in the type is given. Therefore, when forgetting the demand on arguments, as in+dmdAnalRhs, this needs to be considered (via removeDmdTyArgs).++Consider+  b2 x y = x `seq` y `seq` error (show x)+this has a strictness signature of+  <S><S>b+meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but+for "b2 1 2 `seq` ()" we get definite divergence.++For comparison,+  b1 x = x `seq` error (show x)+has a strictness signature of+  <S>b+and "b1 1 `seq` ()" is known to terminate.++Now consider a function h with signature "<C(S)>", and the expression+  e1 = h b1+now h puts a demand of <C(S)> onto its argument, and the demand transformer+turns it into+  <S>b+Now the Divergence "b" does apply to us, even though "b1 `seq` ()" does not+diverge, and we do not anything being passed to b.++Note [Asymmetry of 'both' for DmdType and Divergence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'both' for DmdTypes is *asymmetrical*, because there is only one+result!  For example, given (e1 e2), we get a DmdType dt1 for e1, use+its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2).+Similarly with+  case e of { p -> rhs }+we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then+compute (dt_rhs `bothType` dt_scrut).++We+ 1. combine the information on the free variables,+ 2. take the demand on arguments from the first argument+ 3. combine the termination results, but+ 4. take CPR info from the first argument.++3 and 4 are implemented in bothDivergence.+-}++-- Equality needed for fixpoints in GHC.Core.Op.DmdAnal+instance Eq DmdType where+  (==) (DmdType fv1 ds1 div1)+       (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2+         -- It's OK to use nonDetUFMToList here because we're testing for+         -- equality and even though the lists will be in some arbitrary+         -- Unique order, it is the same order for both+                              && ds1 == ds2 && div1 == div2++lubDmdType :: DmdType -> DmdType -> DmdType+lubDmdType d1 d2+  = DmdType lub_fv lub_ds lub_div+  where+    n = max (dmdTypeDepth d1) (dmdTypeDepth d2)+    (DmdType fv1 ds1 r1) = ensureArgs n d1+    (DmdType fv2 ds2 r2) = ensureArgs n d2++    lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2)+    lub_ds  = zipWithEqual "lubDmdType" lubDmd ds1 ds2+    lub_div = lubDivergence r1 r2++{-+Note [The need for BothDmdArg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Previously, the right argument to bothDmdType, as well as the return value of+dmdAnalStar via postProcessDmdType, was a DmdType. But bothDmdType only needs+to know about the free variables and termination information, but nothing about+the demand put on arguments, nor cpr information. So we make that explicit by+only passing the relevant information.+-}++type BothDmdArg = (DmdEnv, Divergence)++mkBothDmdArg :: DmdEnv -> BothDmdArg+mkBothDmdArg env = (env, Dunno)++toBothDmdArg :: DmdType -> BothDmdArg+toBothDmdArg (DmdType fv _ r) = (fv, go r)+  where+    go Dunno    = Dunno+    go Diverges = Diverges++bothDmdType :: DmdType -> BothDmdArg -> DmdType+bothDmdType (DmdType fv1 ds1 r1) (fv2, t2)+    -- See Note [Asymmetry of 'both' for DmdType and Divergence]+    -- 'both' takes the argument/result info from its *first* arg,+    -- using its second arg just for its free-var info.+  = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2))+            ds1+            (r1 `bothDivergence` t2)++instance Outputable DmdType where+  ppr (DmdType fv ds res)+    = hsep [hcat (map ppr ds) <> ppr res,+            if null fv_elts then empty+            else braces (fsep (map pp_elt fv_elts))]+    where+      pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd+      fv_elts = nonDetUFMToList fv+        -- It's OK to use nonDetUFMToList here because we only do it for+        -- pretty printing++emptyDmdEnv :: VarEnv Demand+emptyDmdEnv = emptyVarEnv++-- nopDmdType is the demand of doing nothing+-- (lazy, absent, no CPR information, no termination information).+-- Note that it is ''not'' the top of the lattice (which would be "may use everything"),+-- so it is (no longer) called topDmd+nopDmdType, botDmdType :: DmdType+nopDmdType = DmdType emptyDmdEnv [] topDiv+botDmdType = DmdType emptyDmdEnv [] botDiv++isTopDmdType :: DmdType -> Bool+isTopDmdType (DmdType env [] res)+  | isTopDiv res && isEmptyVarEnv env = True+isTopDmdType _                        = False++mkDmdType :: DmdEnv -> [Demand] -> Divergence -> DmdType+mkDmdType fv ds res = DmdType fv ds res++dmdTypeDepth :: DmdType -> Arity+dmdTypeDepth (DmdType _ ds _) = length ds++-- | This makes sure we can use the demand type with n arguments.+-- It extends the argument list with the correct resTypeArgDmd.+-- It also adjusts the Divergence: Divergence survives additional arguments,+-- CPR information does not (and definite converge also would not).+ensureArgs :: Arity -> DmdType -> DmdType+ensureArgs n d | n == depth = d+               | otherwise  = DmdType fv ds' r'+  where depth = dmdTypeDepth d+        DmdType fv ds r = d++        ds' = take n (ds ++ repeat (resTypeArgDmd r))+        r' = case r of    -- See [Nature of result demand]+              Dunno -> topDiv+              _     -> r+++seqDmdType :: DmdType -> ()+seqDmdType (DmdType env ds res) =+  seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` ()++seqDmdEnv :: DmdEnv -> ()+seqDmdEnv env = seqEltsUFM seqDemandList env++splitDmdTy :: DmdType -> (Demand, DmdType)+-- Split off one function argument+-- We already have a suitable demand on all+-- free vars, so no need to add more!+splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)+splitDmdTy ty@(DmdType _ [] res_ty)       = (resTypeArgDmd res_ty, ty)++-- When e is evaluated after executing an IO action, and d is e's demand, then+-- what of this demand should we consider, given that the IO action can cleanly+-- exit?+-- * We have to kill all strictness demands (i.e. lub with a lazy demand)+-- * We can keep usage information (i.e. lub with an absent demand)+-- * We have to kill definite divergence+-- * We can keep CPR information.+-- See Note [IO hack in the demand analyser] in GHC.Core.Op.DmdAnal+deferAfterIO :: DmdType -> DmdType+deferAfterIO d@(DmdType _ _ res) =+    case d `lubDmdType` nopDmdType of+        DmdType fv ds _ -> DmdType fv ds (defer_res res)+  where+  defer_res r@(Dunno {}) = r+  defer_res _            = topDiv  -- Diverges++strictenDmd :: Demand -> CleanDemand+strictenDmd (JD { sd = s, ud = u})+  = JD { sd = poke_s s, ud = poke_u u }+  where+    poke_s Lazy      = HeadStr+    poke_s (Str s)   = s+    poke_u Abs       = UHead+    poke_u (Use _ u) = u++-- Deferring and peeling++type DmdShell   -- Describes the "outer shell"+                -- of a Demand+   = JointDmd (Str ()) (Use ())++toCleanDmd :: Demand -> (DmdShell, CleanDemand)+-- Splits a Demand into its "shell" and the inner "clean demand"+toCleanDmd (JD { sd = s, ud = u })+  = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' })+    -- See Note [Analyzing with lazy demand and lambdas]+    -- See Note [Analysing with absent demand]+  where+    (ss, s') = case s of+                Str s' -> (Str (), s')+                Lazy   -> (Lazy,   HeadStr)++    (us, u') = case u of+                 Use c u' -> (Use c (), u')+                 Abs      -> (Abs,      Used)++-- This is used in dmdAnalStar when post-processing+-- a function's argument demand. So we only care about what+-- does to free variables, and whether it terminates.+-- see Note [The need for BothDmdArg]+postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg+postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty)+    = (postProcessDmdEnv du fv, postProcessDivergence ss res_ty)++postProcessDivergence :: Str () -> Divergence -> Divergence+postProcessDivergence Lazy _   = topDiv+postProcessDivergence _    res = res++postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv+postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env+  | Abs <- us       = emptyDmdEnv+    -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild+    -- of the environment. Be careful, bad things will happen if this doesn't+    -- match postProcessDmd (see #13977).+  | Str _ <- ss+  , Use One _ <- us = env+  | otherwise       = mapVarEnv (postProcessDmd ds) env+  -- For the Absent case just discard all usage information+  -- We only processed the thing at all to analyse the body+  -- See Note [Always analyse in virgin pass]++reuseEnv :: DmdEnv -> DmdEnv+reuseEnv = mapVarEnv (postProcessDmd+                        (JD { sd = Str (), ud = Use Many () }))++postProcessUnsat :: DmdShell -> DmdType -> DmdType+postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty)+  = DmdType (postProcessDmdEnv ds fv)+            (map (postProcessDmd ds) args)+            (postProcessDivergence ss res_ty)++postProcessDmd :: DmdShell -> Demand -> Demand+postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a})+  = JD { sd = s', ud = a' }+  where+    s' = case ss of+           Lazy  -> Lazy+           Str _ -> s+    a' = case us of+           Abs        -> Abs+           Use Many _ -> markReusedDmd a+           Use One  _ -> a++-- Peels one call level from the demand, and also returns+-- whether it was unsaturated (separately for strictness and usage)+peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell)+-- Exploiting the fact that+-- on the strictness side      C(B) = B+-- and on the usage side       C(U) = U+peelCallDmd (JD {sd = s, ud = u})+  = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us })+  where+    (s', ss) = case s of+                 SCall s' -> (s',       Str ())+                 HyperStr -> (HyperStr, Str ())+                 _        -> (HeadStr,  Lazy)+    (u', us) = case u of+                 UCall c u' -> (u',   Use c    ())+                 _          -> (Used, Use Many ())+       -- The _ cases for usage includes UHead which seems a bit wrong+       -- because the body isn't used at all!+       -- c.f. the Abs case in toCleanDmd++-- Peels that multiple nestings of calls clean demand and also returns+-- whether it was unsaturated (separately for strictness and usage+-- see Note [Demands from unsaturated function calls]+peelManyCalls :: Int -> CleanDemand -> DmdShell+peelManyCalls n (JD { sd = str, ud = abs })+  = JD { sd = go_str n str, ud = go_abs n abs }+  where+    go_str :: Int -> StrDmd -> Str ()  -- True <=> unsaturated, defer+    go_str 0 _          = Str ()+    go_str _ HyperStr   = Str () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr)+    go_str n (SCall d') = go_str (n-1) d'+    go_str _ _          = Lazy++    go_abs :: Int -> UseDmd -> Use ()      -- Many <=> unsaturated, or at least+    go_abs 0 _              = Use One ()   --          one UCall Many in the demand+    go_abs n (UCall One d') = go_abs (n-1) d'+    go_abs _ _              = Use Many ()++{-+Note [Demands from unsaturated function calls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Consider a demand transformer d1 -> d2 -> r for f.+If a sufficiently detailed demand is fed into this transformer,+e.g <C(C(S)), C1(C1(S))> arising from "f x1 x2" in a strict, use-once context,+then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for+the free variable environment) and furthermore the result information r is the+one we want to use.++An anonymous lambda is also an unsaturated function all (needs one argument,+none given), so this applies to that case as well.++But the demand fed into f might be less than <C(C(S)), C1(C1(S))>. There are a few cases:+ * Not enough demand on the strictness side:+   - In that case, we need to zap all strictness in the demand on arguments and+     free variables.+   - Furthermore, we remove CPR information. It could be left, but given the incoming+     demand is not enough to evaluate so far we just do not bother.+   - And finally termination information: If r says that f diverges for sure,+     then this holds when the demand guarantees that two arguments are going to+     be passed. If the demand is lower, we may just as well converge.+     If we were tracking definite convegence, than that would still hold under+     a weaker demand than expected by the demand transformer.+ * Not enough demand from the usage side: The missing usage can be expanded+   using UCall Many, therefore this is subsumed by the third case:+ * At least one of the uses has a cardinality of Many.+   - Even if f puts a One demand on any of its argument or free variables, if+     we call f multiple times, we may evaluate this argument or free variable+     multiple times. So forget about any occurrence of "One" in the demand.++In dmdTransformSig, we call peelManyCalls to find out if we are in any of these+cases, and then call postProcessUnsat to reduce the demand appropriately.++Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use+peelCallDmd, which peels only one level, but also returns the demand put on the+body of the function.+-}++peelFV :: DmdType -> Var -> (DmdType, Demand)+peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)+                               (DmdType fv' ds res, dmd)+  where+  fv' = fv `delVarEnv` id+  -- See Note [Default demand on free variables]+  dmd  = lookupVarEnv fv id `orElse` defaultDmd res++addDemand :: Demand -> DmdType -> DmdType+addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res++findIdDemand :: DmdType -> Var -> Demand+findIdDemand (DmdType fv _ res) id+  = lookupVarEnv fv id `orElse` defaultDmd res++{-+Note [Default demand on free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the variable is not mentioned in the environment of a demand type,+its demand is taken to be a result demand of the type.+    For the strictness component,+     if the result demand is a Diverges, then we use HyperStr+                                         else we use Lazy+    For the usage component, we use Absent.+So we use either absDmd or botDmd.++Also note the equations for lubDivergence (resp. bothDivergence) noted there.++Note [Always analyse in virgin pass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Tricky point: make sure that we analyse in the 'virgin' pass. Consider+   rec { f acc x True  = f (...rec { g y = ...g... }...)+         f acc x False = acc }+In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type.+That might mean that we analyse the sub-expression containing the+E = "...rec g..." stuff in a bottom demand.  Suppose we *didn't analyse*+E, but just returned botType.++Then in the *next* (non-virgin) iteration for 'f', we might analyse E+in a weaker demand, and that will trigger doing a fixpoint iteration+for g.  But *because it's not the virgin pass* we won't start g's+iteration at bottom.  Disaster.  (This happened in $sfibToList' of+nofib/spectral/fibheaps.)++So in the virgin pass we make sure that we do analyse the expression+at least once, to initialise its signatures.++Note [Analyzing with lazy demand and lambdas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The insight for analyzing lambdas follows from the fact that for+strictness S = C(L). This polymorphic expansion is critical for+cardinality analysis of the following example:++{-# NOINLINE build #-}+build g = (g (:) [], g (:) [])++h c z = build (\x ->+                let z1 = z ++ z+                 in if c+                    then \y -> x (y ++ z1)+                    else \y -> x (z1 ++ y))++One can see that `build` assigns to `g` demand <L,C(C1(U))>.+Therefore, when analyzing the lambda `(\x -> ...)`, we+expect each lambda \y -> ... to be annotated as "one-shot"+one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a+demand <C(C(..), C(C1(U))>.++This is achieved by, first, converting the lazy demand L into the+strict S by the second clause of the analysis.++Note [Analysing with absent demand]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we analyse an expression with demand <L,A>.  The "A" means+"absent", so this expression will never be needed.  What should happen?+There are several wrinkles:++* We *do* want to analyse the expression regardless.+  Reason: Note [Always analyse in virgin pass]++  But we can post-process the results to ignore all the usage+  demands coming back. This is done by postProcessDmdType.++* In a previous incarnation of GHC we needed to be extra careful in the+  case of an *unlifted type*, because unlifted values are evaluated+  even if they are not used.  Example (see #9254):+     f :: (() -> (# Int#, () #)) -> ()+          -- Strictness signature is+          --    <C(S(LS)), 1*C1(U(A,1*U()))>+          -- I.e. calls k, but discards first component of result+     f k = case k () of (# _, r #) -> r++     g :: Int -> ()+     g y = f (\n -> (# case y of I# y2 -> y2, n #))++  Here f's strictness signature says (correctly) that it calls its+  argument function and ignores the first component of its result.+  This is correct in the sense that it'd be fine to (say) modify the+  function so that always returned 0# in the first component.++  But in function g, we *will* evaluate the 'case y of ...', because+  it has type Int#.  So 'y' will be evaluated.  So we must record this+  usage of 'y', else 'g' will say 'y' is absent, and will w/w so that+  'y' is bound to an aBSENT_ERROR thunk.++  However, the argument of toCleanDmd always satisfies the let/app+  invariant; so if it is unlifted it is also okForSpeculation, and so+  can be evaluated in a short finite time -- and that rules out nasty+  cases like the one above.  (I'm not quite sure why this was a+  problem in an earlier version of GHC, but it isn't now.)+++************************************************************************+*                                                                      *+                     Demand signatures+*                                                                      *+************************************************************************++In a let-bound Id we record its strictness info.+In principle, this strictness info is a demand transformer, mapping+a demand on the Id into a DmdType, which gives+        a) the free vars of the Id's value+        b) the Id's arguments+        c) an indication of the result of applying+           the Id to its arguments++However, in fact we store in the Id an extremely emascuated demand+transfomer, namely++                a single DmdType+(Nevertheless we dignify StrictSig as a distinct type.)++This DmdType gives the demands unleashed by the Id when it is applied+to as many arguments as are given in by the arg demands in the DmdType.+Also see Note [Nature of result demand] for the meaning of a Divergence in a+strictness signature.++If an Id is applied to less arguments than its arity, it means that+the demand on the function at a call site is weaker than the vanilla+call demand, used for signature inference. Therefore we place a top+demand on all arguments. Otherwise, the demand is specified by Id's+signature.++For example, the demand transformer described by the demand signature+        StrictSig (DmdType {x -> <S,1*U>} <L,A><L,U(U,U)>m)+says that when the function is applied to two arguments, it+unleashes demand <S,1*U> on the free var x, <L,A> on the first arg,+and <L,U(U,U)> on the second, then returning a constructor.++If this same function is applied to one arg, all we can say is that it+uses x with <L,U>, and its arg with demand <L,U>.++Note [Understanding DmdType and StrictSig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Demand types are sound approximations of an expression's semantics relative to+the incoming demand we put the expression under. Consider the following+expression:++    \x y -> x `seq` (y, 2*x)++Here is a table with demand types resulting from different incoming demands we+put that expression under. Note the monotonicity; a stronger incoming demand+yields a more precise demand type:++    incoming demand                  |  demand type+    ----------------------------------------------------+    <S           ,HU              >  |  <L,U><L,U>{}+    <C(C(S     )),C1(C1(U       ))>  |  <S,U><L,U>{}+    <C(C(S(S,L))),C1(C1(U(1*U,A)))>  |  <S,1*HU><L,A>{}++Note that in the first example, the depth of the demand type was *higher* than+the arity of the incoming call demand due to the anonymous lambda.+The converse is also possible and happens when we unleash demand signatures.+In @f x y@, the incoming call demand on f has arity 2. But if all we have is a+demand signature with depth 1 for @f@ (which we can safely unleash, see below),+the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1.++So: Demand types are elicited by putting an expression under an incoming (call)+demand, the arity of which can be lower or higher than the depth of the+resulting demand type.+In contrast, a demand signature summarises a function's semantics *without*+immediately specifying the incoming demand it was produced under. Despite StrSig+being a newtype wrapper around DmdType, it actually encodes two things:++  * The threshold (i.e., minimum arity) to unleash the signature+  * A demand type that is sound to unleash when the minimum arity requirement is+    met.++Here comes the subtle part: The threshold is encoded in the wrapped demand+type's depth! So in mkStrictSigForArity we make sure to trim the list of+argument demands to the given threshold arity. Call sites will make sure that+this corresponds to the arity of the call demand that elicited the wrapped+demand type. See also Note [What are demand signatures?] in GHC.Core.Op.DmdAnal.++Besides trimming argument demands, mkStrictSigForArity will also trim CPR+information if necessary.+-}++-- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe+-- to unleash. Better construct this through 'mkStrictSigForArity'.+-- See Note [Understanding DmdType and StrictSig]+newtype StrictSig = StrictSig DmdType+                  deriving( Eq )++instance Outputable StrictSig where+   ppr (StrictSig ty) = ppr ty++-- Used for printing top-level strictness pragmas in interface files+pprIfaceStrictSig :: StrictSig -> SDoc+pprIfaceStrictSig (StrictSig (DmdType _ dmds res))+  = hcat (map ppr dmds) <> ppr res++-- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig'+-- unleashable at that arity. See Note [Understanding DmdType and StrictSig]+mkStrictSigForArity :: Arity -> DmdType -> StrictSig+mkStrictSigForArity arity dmd_ty = StrictSig (ensureArgs arity dmd_ty)++mkClosedStrictSig :: [Demand] -> Divergence -> StrictSig+mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res)++splitStrictSig :: StrictSig -> ([Demand], Divergence)+splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)++increaseStrictSigArity :: Int -> StrictSig -> StrictSig+-- ^ Add extra arguments to a strictness signature.+-- In contrast to 'etaExpandStrictSig', this /prepends/ additional argument+-- demands and leaves CPR info intact.+increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res))+  | isTopDmdType dmd_ty = sig+  | arity_increase == 0 = sig+  | arity_increase < 0  = WARN( True, text "increaseStrictSigArity:"+                                  <+> text "negative arity increase"+                                  <+> ppr arity_increase )+                          nopSig+  | otherwise           = StrictSig (DmdType env dmds' res)+  where+    dmds' = replicate arity_increase topDmd ++ dmds++etaExpandStrictSig :: Arity -> StrictSig -> StrictSig+-- ^ We are expanding (\x y. e) to (\x y z. e z).+-- In contrast to 'increaseStrictSigArity', this /appends/ extra arg demands if+-- necessary, potentially destroying the signature's CPR property.+etaExpandStrictSig arity (StrictSig dmd_ty)+  | arity < dmdTypeDepth dmd_ty+  -- an arity decrease must zap the whole signature, because it was possibly+  -- computed for a higher incoming call demand.+  = nopSig+  | otherwise+  = StrictSig $ ensureArgs arity dmd_ty++isTopSig :: StrictSig -> Bool+isTopSig (StrictSig ty) = isTopDmdType ty++hasDemandEnvSig :: StrictSig -> Bool+hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env)++strictSigDmdEnv :: StrictSig -> DmdEnv+strictSigDmdEnv (StrictSig (DmdType env _ _)) = env++-- | True if the signature diverges or throws an exception+isBottomingSig :: StrictSig -> Bool+isBottomingSig (StrictSig (DmdType _ _ res)) = isBotDiv res++nopSig, botSig :: StrictSig+nopSig = StrictSig nopDmdType+botSig = StrictSig botDmdType++cprProdSig :: Arity -> StrictSig+cprProdSig _arity = nopSig++seqStrictSig :: StrictSig -> ()+seqStrictSig (StrictSig ty) = seqDmdType ty++dmdTransformSig :: StrictSig -> CleanDemand -> DmdType+-- (dmdTransformSig fun_sig dmd) considers a call to a function whose+-- signature is fun_sig, with demand dmd.  We return the demand+-- that the function places on its context (eg its args)+dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd+  = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty+    -- see Note [Demands from unsaturated function calls]++dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType+-- Same as dmdTransformSig but for a data constructor (worker),+-- which has a special kind of demand transformer.+-- If the constructor is saturated, we feed the demand on+-- the result into the constructor arguments.+dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res))+                             (JD { sd = str, ud = abs })+  | Just str_dmds <- go_str arity str+  , Just abs_dmds <- go_abs arity abs+  = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res+                -- Must remember whether it's a product, hence con_res, not TopRes++  | otherwise   -- Not saturated+  = nopDmdType+  where+    go_str 0 dmd        = splitStrProdDmd arity dmd+    go_str n (SCall s') = go_str (n-1) s'+    go_str n HyperStr   = go_str (n-1) HyperStr+    go_str _ _          = Nothing++    go_abs 0 dmd            = splitUseProdDmd arity dmd+    go_abs n (UCall One u') = go_abs (n-1) u'+    go_abs _ _              = Nothing++dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType+-- Like dmdTransformDataConSig, we have a special demand transformer+-- for dictionary selectors.  If the selector is saturated (ie has one+-- argument: the dictionary), we feed the demand on the result into+-- the indicated dictionary component.+dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd+   | (cd',defer_use) <- peelCallDmd cd+   , Just jds <- splitProdDmd_maybe dict_dmd+   = postProcessUnsat defer_use $+     DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topDiv+   | otherwise+   = nopDmdType              -- See Note [Demand transformer for a dictionary selector]+  where+    enhance cd old | isAbsDmd old = old+                   | otherwise    = mkOnceUsedDmd cd  -- This is the one!++dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args"++{-+Note [Demand transformer for a dictionary selector]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd'+into the appropriate field of the dictionary. What *is* the appropriate field?+We just look at the strictness signature of the class op, which will be+something like: U(AAASAAAAA).  Then replace the 'S' by the demand 'd'.++For single-method classes, which are represented by newtypes the signature+of 'op' won't look like U(...), so the splitProdDmd_maybe will fail.+That's fine: if we are doing strictness analysis we are also doing inlining,+so we'll have inlined 'op' into a cast.  So we can bale out in a conservative+way, returning nopDmdType.++It is (just.. #8329) possible to be running strictness analysis *without*+having inlined class ops from single-method classes.  Suppose you are using+ghc --make; and the first module has a local -O0 flag.  So you may load a class+without interface pragmas, ie (currently) without an unfolding for the class+ops.   Now if a subsequent module in the --make sweep has a local -O flag+you might do strictness analysis, but there is no inlining for the class op.+This is weird, so I'm not worried about whether this optimises brilliantly; but+it should not fall over.+-}++argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]]+-- See Note [Computing one-shot info]+argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args+  | unsaturated_call = []+  | otherwise = go arg_ds+  where+    unsaturated_call = arg_ds `lengthExceeds` n_val_args++    go []               = []+    go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds++    -- Avoid list tail like [ [], [], [] ]+    cons [] [] = []+    cons a  as = a:as++-- saturatedByOneShots n C1(C1(...)) = True,+--   <=>+-- there are at least n nested C1(..) calls+-- See Note [Demand on the worker] in GHC.Core.Op.WorkWrap+saturatedByOneShots :: Int -> Demand -> Bool+saturatedByOneShots n (JD { ud = usg })+  = case usg of+      Use _ arg_usg -> go n arg_usg+      _             -> False+  where+    go 0 _             = True+    go n (UCall One u) = go (n-1) u+    go _ _             = False++argOneShots :: Demand          -- depending on saturation+            -> [OneShotInfo]+argOneShots (JD { ud = usg })+  = case usg of+      Use _ arg_usg -> go arg_usg+      _             -> []+  where+    go (UCall One  u) = OneShotLam : go u+    go (UCall Many u) = NoOneShotInfo : go u+    go _              = []++{- Note [Computing one-shot info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a call+    f (\pqr. e1) (\xyz. e2) e3+where f has usage signature+    C1(C(C1(U))) C1(U) U+Then argsOneShots returns a [[OneShotInfo]] of+    [[OneShot,NoOneShotInfo,OneShot],  [OneShot]]+The occurrence analyser propagates this one-shot infor to the+binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal.+-}++-- | Returns true if an application to n args+-- would diverge or throw an exception+-- See Note [Unsaturated applications]+appIsBottom :: StrictSig -> Int -> Bool+appIsBottom (StrictSig (DmdType _ ds res)) n+            | isBotDiv res                   = not $ lengthExceeds ds n+appIsBottom _                              _ = False++{-+Note [Unsaturated applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a function having bottom as its demand result is applied to a less+number of arguments than its syntactic arity, we cannot say for sure+that it is going to diverge. This is the reason why we use the+function appIsBottom, which, given a strictness signature and a number+of arguments, says conservatively if the function is going to diverge+or not.+-}++zapUsageEnvSig :: StrictSig -> StrictSig+-- Remove the usage environment from the demand+zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r++zapUsageDemand :: Demand -> Demand+-- Remove the usage info, but not the strictness info, from the demand+zapUsageDemand = kill_usage $ KillFlags+    { kf_abs         = True+    , kf_used_once   = True+    , kf_called_once = True+    }++-- | Remove all 1* information (but not C1 information) from the demand+zapUsedOnceDemand :: Demand -> Demand+zapUsedOnceDemand = kill_usage $ KillFlags+    { kf_abs         = False+    , kf_used_once   = True+    , kf_called_once = False+    }++-- | Remove all 1* information (but not C1 information) from the strictness+--   signature+zapUsedOnceSig :: StrictSig -> StrictSig+zapUsedOnceSig (StrictSig (DmdType env ds r))+    = StrictSig (DmdType env (map zapUsedOnceDemand ds) r)++data KillFlags = KillFlags+    { kf_abs         :: Bool+    , kf_used_once   :: Bool+    , kf_called_once :: Bool+    }++kill_usage :: KillFlags -> Demand -> Demand+kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u}++zap_musg :: KillFlags -> ArgUse -> ArgUse+zap_musg kfs Abs+  | kf_abs kfs = useTop+  | otherwise  = Abs+zap_musg kfs (Use c u)+  | kf_used_once kfs = Use Many (zap_usg kfs u)+  | otherwise        = Use c    (zap_usg kfs u)++zap_usg :: KillFlags -> UseDmd -> UseDmd+zap_usg kfs (UCall c u)+    | kf_called_once kfs = UCall Many (zap_usg kfs u)+    | otherwise          = UCall c    (zap_usg kfs u)+zap_usg kfs (UProd us)   = UProd (map (zap_musg kfs) us)+zap_usg _   u            = u++-- If the argument is a used non-newtype dictionary, give it strict+-- demand. Also split the product type & demand and recur in order to+-- similarly strictify the argument's contained used non-newtype+-- superclass dictionaries. We use the demand as our recursive measure+-- to guarantee termination.+strictifyDictDmd :: Type -> Demand -> Demand+strictifyDictDmd ty dmd = case getUseDmd dmd of+  Use n _ |+    Just (tycon, _arg_tys, _data_con, inst_con_arg_tys)+      <- splitDataProductType_maybe ty,+    not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary+    -> seqDmd `bothDmd` -- main idea: ensure it's strict+       case splitProdDmd_maybe dmd of+         -- superclass cycles should not be a problem, since the demand we are+         -- consuming would also have to be infinite in order for us to diverge+         Nothing -> dmd -- no components have interesting demand, so stop+                        -- looking for superclass dicts+         Just dmds+           | all (not . isAbsDmd) dmds -> evalDmd+             -- abstract to strict w/ arbitrary component use, since this+             -- smells like reboxing; results in CBV boxed+             --+             -- TODO revisit this if we ever do boxity analysis+           | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of+               JD {sd = s,ud = a} -> JD (Str s) (Use n a)+             -- TODO could optimize with an aborting variant of zipWith since+             -- the superclass dicts are always a prefix+  _ -> dmd -- unused or not a dictionary++strictifyDmd :: Demand -> Demand+strictifyDmd dmd@(JD { sd = str })+  = dmd { sd = str `bothArgStr` Str HeadStr }++{-+Note [HyperStr and Use demands]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The information "HyperStr" needs to be in the strictness signature, and not in+the demand signature, because we still want to know about the demand on things. Consider++    f (x,y) True  = error (show x)+    f (x,y) False = x+1++The signature of f should be <S(SL),1*U(1*U(U),A)><S,1*U>m. If we were not+distinguishing the uses on x and y in the True case, we could either not figure+out how deeply we can unpack x, or that we do not have to pass y.+++************************************************************************+*                                                                      *+                     Serialisation+*                                                                      *+************************************************************************+-}++instance Binary StrDmd where+  put_ bh HyperStr     = do putByte bh 0+  put_ bh HeadStr      = do putByte bh 1+  put_ bh (SCall s)    = do putByte bh 2+                            put_ bh s+  put_ bh (SProd sx)   = do putByte bh 3+                            put_ bh sx+  get bh = do+         h <- getByte bh+         case h of+           0 -> do return HyperStr+           1 -> do return HeadStr+           2 -> do s  <- get bh+                   return (SCall s)+           _ -> do sx <- get bh+                   return (SProd sx)++instance Binary ArgStr where+    put_ bh Lazy         = do+            putByte bh 0+    put_ bh (Str s)    = do+            putByte bh 1+            put_ bh s++    get  bh = do+            h <- getByte bh+            case h of+              0 -> return Lazy+              _ -> do s  <- get bh+                      return $ Str s++instance Binary Count where+    put_ bh One  = do putByte bh 0+    put_ bh Many = do putByte bh 1++    get  bh = do h <- getByte bh+                 case h of+                   0 -> return One+                   _ -> return Many++instance Binary ArgUse where+    put_ bh Abs          = do+            putByte bh 0+    put_ bh (Use c u)    = do+            putByte bh 1+            put_ bh c+            put_ bh u++    get  bh = do+            h <- getByte bh+            case h of+              0 -> return Abs+              _ -> do c  <- get bh+                      u  <- get bh+                      return $ Use c u++instance Binary UseDmd where+    put_ bh Used         = do+            putByte bh 0+    put_ bh UHead        = do+            putByte bh 1+    put_ bh (UCall c u)    = do+            putByte bh 2+            put_ bh c+            put_ bh u+    put_ bh (UProd ux)   = do+            putByte bh 3+            put_ bh ux++    get  bh = do+            h <- getByte bh+            case h of+              0 -> return $ Used+              1 -> return $ UHead+              2 -> do c <- get bh+                      u <- get bh+                      return (UCall c u)+              _ -> do ux <- get bh+                      return (UProd ux)++instance (Binary s, Binary u) => Binary (JointDmd s u) where+    put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y+    get  bh = do+              x <- get bh+              y <- get bh+              return $ JD { sd = x, ud = y }++instance Binary StrictSig where+    put_ bh (StrictSig aa) = do+            put_ bh aa+    get bh = do+          aa <- get bh+          return (StrictSig aa)++instance Binary DmdType where+  -- Ignore DmdEnv when spitting out the DmdType+  put_ bh (DmdType _ ds dr)+       = do put_ bh ds+            put_ bh dr+  get bh+      = do ds <- get bh+           dr <- get bh+           return (DmdType emptyDmdEnv ds dr)++instance Binary Divergence where+  put_ bh Dunno    = putByte bh 0+  put_ bh Diverges = putByte bh 1++  get bh = do { h <- getByte bh+              ; case h of+                  0 -> return Dunno+                  _ -> return Diverges }
+ compiler/GHC/Types/FieldLabel.hs view
@@ -0,0 +1,132 @@+{-+%+% (c) Adam Gundry 2013-2015+%++This module defines the representation of FieldLabels as stored in+TyCons.  As well as a selector name, these have some extra structure+to support the DuplicateRecordFields extension.++In the normal case (with NoDuplicateRecordFields), a datatype like++    data T = MkT { foo :: Int }++has++    FieldLabel { flLabel        = "foo"+               , flIsOverloaded = False+               , flSelector     = foo }.++In particular, the Name of the selector has the same string+representation as the label.  If DuplicateRecordFields+is enabled, however, the same declaration instead gives++    FieldLabel { flLabel        = "foo"+               , flIsOverloaded = True+               , flSelector     = $sel:foo:MkT }.++Now the name of the selector ($sel:foo:MkT) does not match the label of+the field (foo).  We must be careful not to show the selector name to+the user!  The point of mangling the selector name is to allow a+module to define the same field label in different datatypes:++    data T = MkT { foo :: Int }+    data U = MkU { foo :: Bool }++Now there will be two FieldLabel values for 'foo', one in T and one in+U.  They share the same label (FieldLabelString), but the selector+functions differ.++See also Note [Representing fields in AvailInfo] in GHC.Types.Avail.++Note [Why selector names include data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++As explained above, a selector name includes the name of the first+data constructor in the type, so that the same label can appear+multiple times in the same module.  (This is irrespective of whether+the first constructor has that field, for simplicity.)++We use a data constructor name, rather than the type constructor name,+because data family instances do not have a representation type+constructor name generated until relatively late in the typechecking+process.++Of course, datatypes with no constructors cannot have any fields.++-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE StandaloneDeriving #-}++module GHC.Types.FieldLabel+   ( FieldLabelString+   , FieldLabelEnv+   , FieldLbl(..)+   , FieldLabel+   , mkFieldLabelOccs+   )+where++import GhcPrelude++import GHC.Types.Name.Occurrence+import GHC.Types.Name++import FastString+import FastStringEnv+import Outputable+import Binary++import Data.Data++-- | Field labels are just represented as strings;+-- they are not necessarily unique (even within a module)+type FieldLabelString = FastString++-- | A map from labels to all the auxiliary information+type FieldLabelEnv = DFastStringEnv FieldLabel+++type FieldLabel = FieldLbl Name++-- | Fields in an algebraic record type+data FieldLbl a = FieldLabel {+      flLabel        :: FieldLabelString, -- ^ User-visible label of the field+      flIsOverloaded :: Bool,             -- ^ Was DuplicateRecordFields on+                                          --   in the defining module for this datatype?+      flSelector     :: a                 -- ^ Record selector function+    }+  deriving (Eq, Functor, Foldable, Traversable)+deriving instance Data a => Data (FieldLbl a)++instance Outputable a => Outputable (FieldLbl a) where+    ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl))++instance Binary a => Binary (FieldLbl a) where+    put_ bh (FieldLabel aa ab ac) = do+        put_ bh aa+        put_ bh ab+        put_ bh ac+    get bh = do+        ab <- get bh+        ac <- get bh+        ad <- get bh+        return (FieldLabel ab ac ad)+++-- | Record selector OccNames are built from the underlying field name+-- and the name of the first data constructor of the type, to support+-- duplicate record field names.+-- See Note [Why selector names include data constructors].+mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName+mkFieldLabelOccs lbl dc is_overloaded+  = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded+               , flSelector = sel_occ }+  where+    str     = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc+    sel_occ | is_overloaded = mkRecFldSelOcc str+            | otherwise     = mkVarOccFS lbl
+ compiler/GHC/Types/ForeignCall.hs view
@@ -0,0 +1,348 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[Foreign]{Foreign calls}+-}++{-# LANGUAGE DeriveDataTypeable #-}++module GHC.Types.ForeignCall (+        ForeignCall(..), isSafeForeignCall,+        Safety(..), playSafe, playInterruptible,++        CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,+        CCallSpec(..),+        CCallTarget(..), isDynamicTarget,+        CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,++        Header(..), CType(..),+    ) where++import GhcPrelude++import FastString+import Binary+import Outputable+import GHC.Types.Module+import GHC.Types.Basic ( SourceText, pprWithSourceText )++import Data.Char+import Data.Data++{-+************************************************************************+*                                                                      *+\subsubsection{Data types}+*                                                                      *+************************************************************************+-}++newtype ForeignCall = CCall CCallSpec+  deriving Eq++isSafeForeignCall :: ForeignCall -> Bool+isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe++-- We may need more clues to distinguish foreign calls+-- but this simple printer will do for now+instance Outputable ForeignCall where+  ppr (CCall cc)  = ppr cc++data Safety+  = PlaySafe            -- Might invoke Haskell GC, or do a call back, or+                        -- switch threads, etc.  So make sure things are+                        -- tidy before the call. Additionally, in the threaded+                        -- RTS we arrange for the external call to be executed+                        -- by a separate OS thread, i.e., _concurrently_ to the+                        -- execution of other Haskell threads.++  | PlayInterruptible   -- Like PlaySafe, but additionally+                        -- the worker thread running this foreign call may+                        -- be unceremoniously killed, so it must be scheduled+                        -- on an unbound thread.++  | PlayRisky           -- None of the above can happen; the call will return+                        -- without interacting with the runtime system at all+  deriving ( Eq, Show, Data )+        -- Show used just for Show Lex.Token, I think++instance Outputable Safety where+  ppr PlaySafe = text "safe"+  ppr PlayInterruptible = text "interruptible"+  ppr PlayRisky = text "unsafe"++playSafe :: Safety -> Bool+playSafe PlaySafe = True+playSafe PlayInterruptible = True+playSafe PlayRisky = False++playInterruptible :: Safety -> Bool+playInterruptible PlayInterruptible = True+playInterruptible _ = False++{-+************************************************************************+*                                                                      *+\subsubsection{Calling C}+*                                                                      *+************************************************************************+-}++data CExportSpec+  = CExportStatic               -- foreign export ccall foo :: ty+        SourceText              -- of the CLabelString.+                                -- See note [Pragma source text] in GHC.Types.Basic+        CLabelString            -- C Name of exported function+        CCallConv+  deriving Data++data CCallSpec+  =  CCallSpec  CCallTarget     -- What to call+                CCallConv       -- Calling convention to use.+                Safety+  deriving( Eq )++-- The call target:++-- | How to call a particular function in C-land.+data CCallTarget+  -- An "unboxed" ccall# to named function in a particular package.+  = StaticTarget+        SourceText                -- of the CLabelString.+                                  -- See note [Pragma source text] in GHC.Types.Basic+        CLabelString                    -- C-land name of label.++        (Maybe UnitId)              -- What package the function is in.+                                        -- If Nothing, then it's taken to be in the current package.+                                        -- Note: This information is only used for PrimCalls on Windows.+                                        --       See CLabel.labelDynamic and CoreToStg.coreToStgApp+                                        --       for the difference in representation between PrimCalls+                                        --       and ForeignCalls. If the CCallTarget is representing+                                        --       a regular ForeignCall then it's safe to set this to Nothing.++  -- The first argument of the import is the name of a function pointer (an Addr#).+  --    Used when importing a label as "foreign import ccall "dynamic" ..."+        Bool                            -- True => really a function+                                        -- False => a value; only+                                        -- allowed in CAPI imports+  | DynamicTarget++  deriving( Eq, Data )++isDynamicTarget :: CCallTarget -> Bool+isDynamicTarget DynamicTarget = True+isDynamicTarget _             = False++{-+Stuff to do with calling convention:++ccall:          Caller allocates parameters, *and* deallocates them.++stdcall:        Caller allocates parameters, callee deallocates.+                Function name has @N after it, where N is number of arg bytes+                e.g.  _Foo@8. This convention is x86 (win32) specific.++See: http://www.programmersheaven.com/2/Calling-conventions+-}++-- any changes here should be replicated in  the CallConv type in template haskell+data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv+  deriving (Eq, Data)++instance Outputable CCallConv where+  ppr StdCallConv = text "stdcall"+  ppr CCallConv   = text "ccall"+  ppr CApiConv    = text "capi"+  ppr PrimCallConv = text "prim"+  ppr JavaScriptCallConv = text "javascript"++defaultCCallConv :: CCallConv+defaultCCallConv = CCallConv++ccallConvToInt :: CCallConv -> Int+ccallConvToInt StdCallConv = 0+ccallConvToInt CCallConv   = 1+ccallConvToInt CApiConv    = panic "ccallConvToInt CApiConv"+ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"+ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv"++{-+Generate the gcc attribute corresponding to the given+calling convention (used by PprAbsC):+-}++ccallConvAttribute :: CCallConv -> SDoc+ccallConvAttribute StdCallConv       = text "__attribute__((__stdcall__))"+ccallConvAttribute CCallConv         = empty+ccallConvAttribute CApiConv          = empty+ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"+ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv"++type CLabelString = FastString          -- A C label, completely unencoded++pprCLabelString :: CLabelString -> SDoc+pprCLabelString lbl = ftext lbl++isCLabelString :: CLabelString -> Bool  -- Checks to see if this is a valid C label+isCLabelString lbl+  = all ok (unpackFS lbl)+  where+    ok c = isAlphaNum c || c == '_' || c == '.'+        -- The '.' appears in e.g. "foo.so" in the+        -- module part of a ExtName.  Maybe it should be separate++-- Printing into C files:++instance Outputable CExportSpec where+  ppr (CExportStatic _ str _) = pprCLabelString str++instance Outputable CCallSpec where+  ppr (CCallSpec fun cconv safety)+    = hcat [ whenPprDebug callconv, ppr_fun fun ]+    where+      callconv = text "{-" <> ppr cconv <> text "-}"++      gc_suf | playSafe safety = text "_GC"+             | otherwise       = empty++      ppr_fun (StaticTarget st _fn mPkgId isFun)+        = text (if isFun then "__pkg_ccall"+                         else "__pkg_ccall_value")+       <> gc_suf+       <+> (case mPkgId of+            Nothing -> empty+            Just pkgId -> ppr pkgId)+       <+> (pprWithSourceText st empty)++      ppr_fun DynamicTarget+        = text "__dyn_ccall" <> gc_suf <+> text "\"\""++-- The filename for a C header file+-- Note [Pragma source text] in GHC.Types.Basic+data Header = Header SourceText FastString+    deriving (Eq, Data)++instance Outputable Header where+    ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h)++-- | A C type, used in CAPI FFI calls+--+--  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@,+--        'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal',+--        'ApiAnnotation.AnnClose' @'\#-}'@,++-- For details on above see note [Api annotations] in ApiAnnotation+data CType = CType SourceText -- Note [Pragma source text] in GHC.Types.Basic+                   (Maybe Header) -- header to include for this type+                   (SourceText,FastString) -- the type itself+    deriving (Eq, Data)++instance Outputable CType where+    ppr (CType stp mh (stct,ct))+      = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc+        <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}"+        where hDoc = case mh of+                     Nothing -> empty+                     Just h -> ppr h++{-+************************************************************************+*                                                                      *+\subsubsection{Misc}+*                                                                      *+************************************************************************+-}++instance Binary ForeignCall where+    put_ bh (CCall aa) = put_ bh aa+    get bh = do aa <- get bh; return (CCall aa)++instance Binary Safety where+    put_ bh PlaySafe = do+            putByte bh 0+    put_ bh PlayInterruptible = do+            putByte bh 1+    put_ bh PlayRisky = do+            putByte bh 2+    get bh = do+            h <- getByte bh+            case h of+              0 -> do return PlaySafe+              1 -> do return PlayInterruptible+              _ -> do return PlayRisky++instance Binary CExportSpec where+    put_ bh (CExportStatic ss aa ab) = do+            put_ bh ss+            put_ bh aa+            put_ bh ab+    get bh = do+          ss <- get bh+          aa <- get bh+          ab <- get bh+          return (CExportStatic ss aa ab)++instance Binary CCallSpec where+    put_ bh (CCallSpec aa ab ac) = do+            put_ bh aa+            put_ bh ab+            put_ bh ac+    get bh = do+          aa <- get bh+          ab <- get bh+          ac <- get bh+          return (CCallSpec aa ab ac)++instance Binary CCallTarget where+    put_ bh (StaticTarget ss aa ab ac) = do+            putByte bh 0+            put_ bh ss+            put_ bh aa+            put_ bh ab+            put_ bh ac+    put_ bh DynamicTarget = do+            putByte bh 1+    get bh = do+            h <- getByte bh+            case h of+              0 -> do ss <- get bh+                      aa <- get bh+                      ab <- get bh+                      ac <- get bh+                      return (StaticTarget ss aa ab ac)+              _ -> do return DynamicTarget++instance Binary CCallConv where+    put_ bh CCallConv = do+            putByte bh 0+    put_ bh StdCallConv = do+            putByte bh 1+    put_ bh PrimCallConv = do+            putByte bh 2+    put_ bh CApiConv = do+            putByte bh 3+    put_ bh JavaScriptCallConv = do+            putByte bh 4+    get bh = do+            h <- getByte bh+            case h of+              0 -> do return CCallConv+              1 -> do return StdCallConv+              2 -> do return PrimCallConv+              3 -> do return CApiConv+              _ -> do return JavaScriptCallConv++instance Binary CType where+    put_ bh (CType s mh fs) = do put_ bh s+                                 put_ bh mh+                                 put_ bh fs+    get bh = do s  <- get bh+                mh <- get bh+                fs <- get bh+                return (CType s mh fs)++instance Binary Header where+    put_ bh (Header s h) = put_ bh s >> put_ bh h+    get bh = do s <- get bh+                h <- get bh+                return (Header s h)
+ compiler/GHC/Types/Id.hs view
@@ -0,0 +1,971 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[Id]{@Ids@: Value and constructor identifiers}+-}++{-# LANGUAGE CPP #-}++-- |+-- #name_types#+-- GHC uses several kinds of name internally:+--+-- * 'OccName.OccName': see "OccName#name_types"+--+-- * 'RdrName.RdrName': see "RdrName#name_types"+--+-- * 'Name.Name': see "Name#name_types"+--+-- * 'Id.Id' represents names that not only have a 'Name.Name' but also a+--   'GHC.Core.TyCo.Rep.Type' and some additional details (a 'IdInfo.IdInfo' and+--   one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that are added,+--   modified and inspected by various compiler passes. These 'Var.Var' names+--   may either be global or local, see "Var#globalvslocal"+--+-- * 'Var.Var': see "Var#name_types"++module GHC.Types.Id (+        -- * The main types+        Var, Id, isId,++        -- * In and Out variants+        InVar,  InId,+        OutVar, OutId,++        -- ** Simple construction+        mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,+        mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar,+        mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId,+        mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM,+        mkUserLocal, mkUserLocalOrCoVar,+        mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,+        mkWorkerId,++        -- ** Taking an Id apart+        idName, idType, idUnique, idInfo, idDetails,+        recordSelectorTyCon,++        -- ** Modifying an Id+        setIdName, setIdUnique, GHC.Types.Id.setIdType,+        setIdExported, setIdNotExported,+        globaliseId, localiseId,+        setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,+        zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,+        zapIdUsedOnceInfo, zapIdTailCallInfo,+        zapFragileIdInfo, zapIdStrictness, zapStableUnfolding,+        transferPolyIdInfo,++        -- ** Predicates on Ids+        isImplicitId, isDeadBinder,+        isStrictId,+        isExportedId, isLocalId, isGlobalId,+        isRecordSelector, isNaughtyRecordSelector,+        isPatSynRecordSelector,+        isDataConRecordSelector,+        isClassOpId_maybe, isDFunId,+        isPrimOpId, isPrimOpId_maybe,+        isFCallId, isFCallId_maybe,+        isDataConWorkId, isDataConWorkId_maybe,+        isDataConWrapId, isDataConWrapId_maybe,+        isDataConId_maybe,+        idDataCon,+        isConLikeId, isBottomingId, idIsFrom,+        hasNoBinding,++        -- ** Join variables+        JoinId, isJoinId, isJoinId_maybe, idJoinArity,+        asJoinId, asJoinId_maybe, zapJoinId,++        -- ** Inline pragma stuff+        idInlinePragma, setInlinePragma, modifyInlinePragma,+        idInlineActivation, setInlineActivation, idRuleMatchInfo,++        -- ** One-shot lambdas+        isOneShotBndr, isProbablyOneShotLambda,+        setOneShotLambda, clearOneShotLambda,+        updOneShotInfo, setIdOneShotInfo,+        isStateHackType, stateHackOneShot, typeOneShot,++        -- ** Reading 'IdInfo' fields+        idArity,+        idCallArity, idFunRepArity,+        idUnfolding, realIdUnfolding,+        idSpecialisation, idCoreRules, idHasRules,+        idCafInfo,+        idOneShotInfo, idStateHackOneShotInfo,+        idOccInfo,+        isNeverLevPolyId,++        -- ** Writing 'IdInfo' fields+        setIdUnfolding, setCaseBndrEvald,+        setIdArity,+        setIdCallArity,++        setIdSpecialisation,+        setIdCafInfo,+        setIdOccInfo, zapIdOccInfo,++        setIdDemandInfo,+        setIdStrictness,+        setIdCprInfo,++        idDemandInfo,+        idStrictness,+        idCprInfo,++    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Driver.Session+import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding,+                 isCompulsoryUnfolding, Unfolding( NoUnfolding ) )++import GHC.Types.Id.Info+import GHC.Types.Basic++-- Imported and re-exported+import GHC.Types.Var( Id, CoVar, JoinId,+            InId,  InVar,+            OutId, OutVar,+            idInfo, idDetails, setIdDetails, globaliseId,+            isId, isLocalId, isGlobalId, isExportedId )+import qualified GHC.Types.Var as Var++import GHC.Core.Type+import GHC.Types.RepType+import TysPrim+import GHC.Core.DataCon+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Types.Name+import GHC.Types.Module+import GHC.Core.Class+import {-# SOURCE #-} PrimOp (PrimOp)+import GHC.Types.ForeignCall+import Maybes+import GHC.Types.SrcLoc+import Outputable+import GHC.Types.Unique+import GHC.Types.Unique.Supply+import FastString+import Util++-- infixl so you can say (id `set` a `set` b)+infixl  1 `setIdUnfolding`,+          `setIdArity`,+          `setIdCallArity`,+          `setIdOccInfo`,+          `setIdOneShotInfo`,++          `setIdSpecialisation`,+          `setInlinePragma`,+          `setInlineActivation`,+          `idCafInfo`,++          `setIdDemandInfo`,+          `setIdStrictness`,+          `setIdCprInfo`,++          `asJoinId`,+          `asJoinId_maybe`++{-+************************************************************************+*                                                                      *+\subsection{Basic Id manipulation}+*                                                                      *+************************************************************************+-}++idName   :: Id -> Name+idName    = Var.varName++idUnique :: Id -> Unique+idUnique  = Var.varUnique++idType   :: Id -> Kind+idType    = Var.varType++setIdName :: Id -> Name -> Id+setIdName = Var.setVarName++setIdUnique :: Id -> Unique -> Id+setIdUnique = Var.setVarUnique++-- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and+-- reduce space usage+setIdType :: Id -> Type -> Id+setIdType id ty = seqType ty `seq` Var.setVarType id ty++setIdExported :: Id -> Id+setIdExported = Var.setIdExported++setIdNotExported :: Id -> Id+setIdNotExported = Var.setIdNotExported++localiseId :: Id -> Id+-- Make an Id with the same unique and type as the+-- incoming Id, but with an *Internal* Name and *LocalId* flavour+localiseId id+  | ASSERT( isId id ) isLocalId id && isInternalName name+  = id+  | otherwise+  = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id)+  where+    name = idName id++lazySetIdInfo :: Id -> IdInfo -> Id+lazySetIdInfo = Var.lazySetIdInfo++setIdInfo :: Id -> IdInfo -> Id+setIdInfo id info = info `seq` (lazySetIdInfo id info)+        -- Try to avoid space leaks by seq'ing++modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id+modifyIdInfo fn id = setIdInfo id (fn (idInfo id))++-- maybeModifyIdInfo tries to avoid unnecessary thrashing+maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id+maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info+maybeModifyIdInfo Nothing         id = id++{-+************************************************************************+*                                                                      *+\subsection{Simple Id construction}+*                                                                      *+************************************************************************++Absolutely all Ids are made by mkId.  It is just like Var.mkId,+but in addition it pins free-tyvar-info onto the Id's type,+where it can easily be found.++Note [Free type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~+At one time we cached the free type variables of the type of an Id+at the root of the type in a TyNote.  The idea was to avoid repeating+the free-type-variable calculation.  But it turned out to slow down+the compiler overall. I don't quite know why; perhaps finding free+type variables of an Id isn't all that common whereas applying a+substitution (which changes the free type variables) is more common.+Anyway, we removed it in March 2008.+-}++-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal"+mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id+mkGlobalId = Var.mkGlobalVar++-- | Make a global 'Id' without any extra information at all+mkVanillaGlobal :: Name -> Type -> Id+mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo++-- | Make a global 'Id' with no global information but some generic 'IdInfo'+mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id+mkVanillaGlobalWithInfo = mkGlobalId VanillaId+++-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal"+mkLocalId :: HasDebugCallStack => Name -> Type -> Id+mkLocalId name ty = ASSERT( not (isCoVarType ty) )+                    mkLocalIdWithInfo name ty vanillaIdInfo++-- | Make a local CoVar+mkLocalCoVar :: Name -> Type -> CoVar+mkLocalCoVar name ty+  = ASSERT( isCoVarType ty )+    Var.mkLocalVar CoVarId name ty vanillaIdInfo++-- | Like 'mkLocalId', but checks the type to see if it should make a covar+mkLocalIdOrCoVar :: Name -> Type -> Id+mkLocalIdOrCoVar name ty+  | isCoVarType ty = mkLocalCoVar name ty+  | otherwise      = mkLocalId    name ty++    -- proper ids only; no covars!+mkLocalIdWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id+mkLocalIdWithInfo name ty info = ASSERT( not (isCoVarType ty) )+                                 Var.mkLocalVar VanillaId name ty info+        -- Note [Free type variables]++-- | Create a local 'Id' that is marked as exported.+-- This prevents things attached to it from being removed as dead code.+-- See Note [Exported LocalIds]+mkExportedLocalId :: IdDetails -> Name -> Type -> Id+mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo+        -- Note [Free type variables]++mkExportedVanillaId :: Name -> Type -> Id+mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo+        -- Note [Free type variables]+++-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal")+-- that are created by the compiler out of thin air+mkSysLocal :: FastString -> Unique -> Type -> Id+mkSysLocal fs uniq ty = ASSERT( not (isCoVarType ty) )+                        mkLocalId (mkSystemVarName uniq fs) ty++-- | Like 'mkSysLocal', but checks to see if we have a covar type+mkSysLocalOrCoVar :: FastString -> Unique -> Type -> Id+mkSysLocalOrCoVar fs uniq ty+  = mkLocalIdOrCoVar (mkSystemVarName uniq fs) ty++mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id+mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty))++mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id+mkSysLocalOrCoVarM fs ty+  = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty))++-- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize+mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id+mkUserLocal occ uniq ty loc = ASSERT( not (isCoVarType ty) )+                              mkLocalId (mkInternalName uniq occ loc) ty++-- | Like 'mkUserLocal', but checks if we have a coercion type+mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id+mkUserLocalOrCoVar occ uniq ty loc+  = mkLocalIdOrCoVar (mkInternalName uniq occ loc) ty++{-+Make some local @Ids@ for a template @CoreExpr@.  These have bogus+@Uniques@, but that's OK because the templates are supposed to be+instantiated before use.+-}++-- | Workers get local names. "CoreTidy" will externalise these if necessary+mkWorkerId :: Unique -> Id -> Type -> Id+mkWorkerId uniq unwrkr ty+  = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty++-- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings+mkTemplateLocal :: Int -> Type -> Id+mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty+   -- "OrCoVar" since this is used in a superclass selector,+   -- and "~" and "~~" have coercion "superclasses".++-- | Create a template local for a series of types+mkTemplateLocals :: [Type] -> [Id]+mkTemplateLocals = mkTemplateLocalsNum 1++-- | Create a template local for a series of type, but start from a specified template local+mkTemplateLocalsNum :: Int -> [Type] -> [Id]+mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys++{- Note [Exported LocalIds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use mkExportedLocalId for things like+ - Dictionary functions (DFunId)+ - Wrapper and matcher Ids for pattern synonyms+ - Default methods for classes+ - Pattern-synonym matcher and builder Ids+ - etc++They marked as "exported" in the sense that they should be kept alive+even if apparently unused in other bindings, and not dropped as dead+code by the occurrence analyser.  (But "exported" here does not mean+"brought into lexical scope by an import declaration". Indeed these+things are always internal Ids that the user never sees.)++It's very important that they are *LocalIds*, not GlobalIds, for lots+of reasons:++ * We want to treat them as free variables for the purpose of+   dependency analysis (e.g. GHC.Core.FVs.exprFreeVars).++ * Look them up in the current substitution when we come across+   occurrences of them (in Subst.lookupIdSubst). Lacking this we+   can get an out-of-date unfolding, which can in turn make the+   simplifier go into an infinite loop (#9857)++ * Ensure that for dfuns that the specialiser does not float dict uses+   above their defns, which would prevent good simplifications happening.++ * The strictness analyser treats a occurrence of a GlobalId as+   imported and assumes it contains strictness in its IdInfo, which+   isn't true if the thing is bound in the same module as the+   occurrence.++In CoreTidy we must make all these LocalIds into GlobalIds, so that in+importing modules (in --make mode) we treat them as properly global.+That is what is happening in, say tidy_insts in GHC.Iface.Tidy.++************************************************************************+*                                                                      *+\subsection{Special Ids}+*                                                                      *+************************************************************************+-}++-- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise.+recordSelectorTyCon :: Id -> RecSelParent+recordSelectorTyCon id+  = case Var.idDetails id of+        RecSelId { sel_tycon = parent } -> parent+        _ -> panic "recordSelectorTyCon"+++isRecordSelector        :: Id -> Bool+isNaughtyRecordSelector :: Id -> Bool+isPatSynRecordSelector  :: Id -> Bool+isDataConRecordSelector  :: Id -> Bool+isPrimOpId              :: Id -> Bool+isFCallId               :: Id -> Bool+isDataConWorkId         :: Id -> Bool+isDataConWrapId         :: Id -> Bool+isDFunId                :: Id -> Bool++isClassOpId_maybe       :: Id -> Maybe Class+isPrimOpId_maybe        :: Id -> Maybe PrimOp+isFCallId_maybe         :: Id -> Maybe ForeignCall+isDataConWorkId_maybe   :: Id -> Maybe DataCon+isDataConWrapId_maybe   :: Id -> Maybe DataCon++isRecordSelector id = case Var.idDetails id of+                        RecSelId {}     -> True+                        _               -> False++isDataConRecordSelector id = case Var.idDetails id of+                        RecSelId {sel_tycon = RecSelData _} -> True+                        _               -> False++isPatSynRecordSelector id = case Var.idDetails id of+                        RecSelId {sel_tycon = RecSelPatSyn _} -> True+                        _               -> False++isNaughtyRecordSelector id = case Var.idDetails id of+                        RecSelId { sel_naughty = n } -> n+                        _                               -> False++isClassOpId_maybe id = case Var.idDetails id of+                        ClassOpId cls -> Just cls+                        _other        -> Nothing++isPrimOpId id = case Var.idDetails id of+                        PrimOpId _ -> True+                        _          -> False++isDFunId id = case Var.idDetails id of+                        DFunId {} -> True+                        _         -> False++isPrimOpId_maybe id = case Var.idDetails id of+                        PrimOpId op -> Just op+                        _           -> Nothing++isFCallId id = case Var.idDetails id of+                        FCallId _ -> True+                        _         -> False++isFCallId_maybe id = case Var.idDetails id of+                        FCallId call -> Just call+                        _            -> Nothing++isDataConWorkId id = case Var.idDetails id of+                        DataConWorkId _ -> True+                        _               -> False++isDataConWorkId_maybe id = case Var.idDetails id of+                        DataConWorkId con -> Just con+                        _                 -> Nothing++isDataConWrapId id = case Var.idDetails id of+                       DataConWrapId _ -> True+                       _               -> False++isDataConWrapId_maybe id = case Var.idDetails id of+                        DataConWrapId con -> Just con+                        _                 -> Nothing++isDataConId_maybe :: Id -> Maybe DataCon+isDataConId_maybe id = case Var.idDetails id of+                         DataConWorkId con -> Just con+                         DataConWrapId con -> Just con+                         _                 -> Nothing++isJoinId :: Var -> Bool+-- It is convenient in GHC.Core.Op.SetLevels.lvlMFE to apply isJoinId+-- to the free vars of an expression, so it's convenient+-- if it returns False for type variables+isJoinId id+  | isId id = case Var.idDetails id of+                JoinId {} -> True+                _         -> False+  | otherwise = False++isJoinId_maybe :: Var -> Maybe JoinArity+isJoinId_maybe id+ | isId id  = ASSERT2( isId id, ppr id )+              case Var.idDetails id of+                JoinId arity -> Just arity+                _            -> Nothing+ | otherwise = Nothing++idDataCon :: Id -> DataCon+-- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer.+--+-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker+idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id)++hasNoBinding :: Id -> Bool+-- ^ Returns @True@ of an 'Id' which may not have a+-- binding, even though it is defined in this module.++-- Data constructor workers used to be things of this kind, but+-- they aren't any more.  Instead, we inject a binding for+-- them at the CorePrep stage.+--+-- 'PrimOpId's also used to be of this kind. See Note [Primop wrappers] in PrimOp.hs.+-- for the history of this.+--+-- Note that CorePrep currently eta expands things no-binding things and this+-- can cause quite subtle bugs. See Note [Eta expansion of hasNoBinding things+-- in CorePrep] in CorePrep for details.+--+-- EXCEPT: unboxed tuples, which definitely have no binding+hasNoBinding id = case Var.idDetails id of+                        PrimOpId _       -> False   -- See Note [Primop wrappers] in PrimOp.hs+                        FCallId _        -> True+                        DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc+                        _                -> isCompulsoryUnfolding (idUnfolding id)+                                            -- See Note [Levity-polymorphic Ids]++isImplicitId :: Id -> Bool+-- ^ 'isImplicitId' tells whether an 'Id's info is implied by other+-- declarations, so we don't need to put its signature in an interface+-- file, even if it's mentioned in some other interface unfolding.+isImplicitId id+  = case Var.idDetails id of+        FCallId {}       -> True+        ClassOpId {}     -> True+        PrimOpId {}      -> True+        DataConWorkId {} -> True+        DataConWrapId {} -> True+                -- These are implied by their type or class decl;+                -- remember that all type and class decls appear in the interface file.+                -- The dfun id is not an implicit Id; it must *not* be omitted, because+                -- it carries version info for the instance decl+        _               -> False++idIsFrom :: Module -> Id -> Bool+idIsFrom mod id = nameIsLocalOrFrom mod (idName id)++{- Note [Levity-polymorphic Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some levity-polymorphic Ids must be applied and inlined, not left+un-saturated.  Example:+  unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b++This has a compulsory unfolding because we can't lambda-bind those+arguments.  But the compulsory unfolding may leave levity-polymorphic+lambdas if it is not applied to enough arguments; e.g. (#14561)+  bad :: forall (a :: TYPE r). a -> a+  bad = unsafeCoerce#++The desugar has special magic to detect such cases: GHC.HsToCore.Expr.badUseOfLevPolyPrimop.+And we want that magic to apply to levity-polymorphic compulsory-inline things.+The easiest way to do this is for hasNoBinding to return True of all things+that have compulsory unfolding.  Some Ids with a compulsory unfolding also+have a binding, but it does not harm to say they don't here, and its a very+simple way to fix #14561.+-}++isDeadBinder :: Id -> Bool+isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)+                  | otherwise = False   -- TyVars count as not dead++{-+************************************************************************+*                                                                      *+              Join variables+*                                                                      *+************************************************************************+-}++idJoinArity :: JoinId -> JoinArity+idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id)++asJoinId :: Id -> JoinArity -> JoinId+asJoinId id arity = WARN(not (isLocalId id),+                         text "global id being marked as join var:" <+> ppr id)+                    WARN(not (is_vanilla_or_join id),+                         ppr id <+> pprIdDetails (idDetails id))+                    id `setIdDetails` JoinId arity+  where+    is_vanilla_or_join id = case Var.idDetails id of+                              VanillaId -> True+                              JoinId {} -> True+                              _         -> False++zapJoinId :: Id -> Id+-- May be a regular id already+zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId)+                                 -- Core Lint may complain if still marked+                                 -- as AlwaysTailCalled+              | otherwise    = jid++asJoinId_maybe :: Id -> Maybe JoinArity -> Id+asJoinId_maybe id (Just arity) = asJoinId id arity+asJoinId_maybe id Nothing      = zapJoinId id++{-+************************************************************************+*                                                                      *+\subsection{IdInfo stuff}+*                                                                      *+************************************************************************+-}++        ---------------------------------+        -- ARITY+idArity :: Id -> Arity+idArity id = arityInfo (idInfo id)++setIdArity :: Id -> Arity -> Id+setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id++idCallArity :: Id -> Arity+idCallArity id = callArityInfo (idInfo id)++setIdCallArity :: Id -> Arity -> Id+setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id++idFunRepArity :: Id -> RepArity+idFunRepArity x = countFunRepArgs (idArity x) (idType x)++-- | Returns true if an application to n args would diverge+isBottomingId :: Var -> Bool+isBottomingId v+  | isId v    = isBottomingSig (idStrictness v)+  | otherwise = False++-- | Accesses the 'Id''s 'strictnessInfo'.+idStrictness :: Id -> StrictSig+idStrictness id = strictnessInfo (idInfo id)++setIdStrictness :: Id -> StrictSig -> Id+setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id++idCprInfo :: Id -> CprSig+idCprInfo id = cprInfo (idInfo id)++setIdCprInfo :: Id -> CprSig -> Id+setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id++zapIdStrictness :: Id -> Id+zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id++-- | This predicate says whether the 'Id' has a strict demand placed on it or+-- has a type such that it can always be evaluated strictly (i.e an+-- unlifted type, as of GHC 7.6).  We need to+-- check separately whether the 'Id' has a so-called \"strict type\" because if+-- the demand for the given @id@ hasn't been computed yet but @id@ has a strict+-- type, we still want @isStrictId id@ to be @True@.+isStrictId :: Id -> Bool+isStrictId id+  = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )+         not (isJoinId id) && (+           (isStrictType (idType id)) ||+           -- Take the best of both strictnesses - old and new+           (isStrictDmd (idDemandInfo id))+         )++        ---------------------------------+        -- UNFOLDING+idUnfolding :: Id -> Unfolding+-- Do not expose the unfolding of a loop breaker!+idUnfolding id+  | isStrongLoopBreaker (occInfo info) = NoUnfolding+  | otherwise                          = unfoldingInfo info+  where+    info = idInfo id++realIdUnfolding :: Id -> Unfolding+-- Expose the unfolding if there is one, including for loop breakers+realIdUnfolding id = unfoldingInfo (idInfo id)++setIdUnfolding :: Id -> Unfolding -> Id+setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id++idDemandInfo       :: Id -> Demand+idDemandInfo       id = demandInfo (idInfo id)++setIdDemandInfo :: Id -> Demand -> Id+setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id++setCaseBndrEvald :: StrictnessMark -> Id -> Id+-- Used for variables bound by a case expressions, both the case-binder+-- itself, and any pattern-bound variables that are argument of a+-- strict constructor.  It just marks the variable as already-evaluated,+-- so that (for example) a subsequent 'seq' can be dropped+setCaseBndrEvald str id+  | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding+  | otherwise          = id++        ---------------------------------+        -- SPECIALISATION++-- See Note [Specialisations and RULES in IdInfo] in GHC.Types.Id.Info++idSpecialisation :: Id -> RuleInfo+idSpecialisation id = ruleInfo (idInfo id)++idCoreRules :: Id -> [CoreRule]+idCoreRules id = ruleInfoRules (idSpecialisation id)++idHasRules :: Id -> Bool+idHasRules id = not (isEmptyRuleInfo (idSpecialisation id))++setIdSpecialisation :: Id -> RuleInfo -> Id+setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id++        ---------------------------------+        -- CAF INFO+idCafInfo :: Id -> CafInfo+idCafInfo id = cafInfo (idInfo id)++setIdCafInfo :: Id -> CafInfo -> Id+setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id++        ---------------------------------+        -- Occurrence INFO+idOccInfo :: Id -> OccInfo+idOccInfo id = occInfo (idInfo id)++setIdOccInfo :: Id -> OccInfo -> Id+setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id++zapIdOccInfo :: Id -> Id+zapIdOccInfo b = b `setIdOccInfo` noOccInfo++{-+        ---------------------------------+        -- INLINING+The inline pragma tells us to be very keen to inline this Id, but it's still+OK not to if optimisation is switched off.+-}++idInlinePragma :: Id -> InlinePragma+idInlinePragma id = inlinePragInfo (idInfo id)++setInlinePragma :: Id -> InlinePragma -> Id+setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id++modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id+modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id++idInlineActivation :: Id -> Activation+idInlineActivation id = inlinePragmaActivation (idInlinePragma id)++setInlineActivation :: Id -> Activation -> Id+setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act)++idRuleMatchInfo :: Id -> RuleMatchInfo+idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id)++isConLikeId :: Id -> Bool+isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id)++{-+        ---------------------------------+        -- ONE-SHOT LAMBDAS+-}++idOneShotInfo :: Id -> OneShotInfo+idOneShotInfo id = oneShotInfo (idInfo id)++-- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account+-- See Note [The state-transformer hack] in GHC.Core.Arity+idStateHackOneShotInfo :: Id -> OneShotInfo+idStateHackOneShotInfo id+    | isStateHackType (idType id) = stateHackOneShot+    | otherwise                   = idOneShotInfo id++-- | Returns whether the lambda associated with the 'Id' is certainly applied at most once+-- This one is the "business end", called externally.+-- It works on type variables as well as Ids, returning True+-- Its main purpose is to encapsulate the Horrible State Hack+-- See Note [The state-transformer hack] in GHC.Core.Arity+isOneShotBndr :: Var -> Bool+isOneShotBndr var+  | isTyVar var                              = True+  | OneShotLam <- idStateHackOneShotInfo var = True+  | otherwise                                = False++-- | Should we apply the state hack to values of this 'Type'?+stateHackOneShot :: OneShotInfo+stateHackOneShot = OneShotLam++typeOneShot :: Type -> OneShotInfo+typeOneShot ty+   | isStateHackType ty = stateHackOneShot+   | otherwise          = NoOneShotInfo++isStateHackType :: Type -> Bool+isStateHackType ty+  | hasNoStateHack unsafeGlobalDynFlags+  = False+  | otherwise+  = case tyConAppTyCon_maybe ty of+        Just tycon -> tycon == statePrimTyCon+        _          -> False+        -- This is a gross hack.  It claims that+        -- every function over realWorldStatePrimTy is a one-shot+        -- function.  This is pretty true in practice, and makes a big+        -- difference.  For example, consider+        --      a `thenST` \ r -> ...E...+        -- The early full laziness pass, if it doesn't know that r is one-shot+        -- will pull out E (let's say it doesn't mention r) to give+        --      let lvl = E in a `thenST` \ r -> ...lvl...+        -- When `thenST` gets inlined, we end up with+        --      let lvl = E in \s -> case a s of (r, s') -> ...lvl...+        -- and we don't re-inline E.+        --+        -- It would be better to spot that r was one-shot to start with, but+        -- I don't want to rely on that.+        --+        -- Another good example is in fill_in in PrelPack.hs.  We should be able to+        -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.++isProbablyOneShotLambda :: Id -> Bool+isProbablyOneShotLambda id = case idStateHackOneShotInfo id of+                               OneShotLam    -> True+                               NoOneShotInfo -> False++setOneShotLambda :: Id -> Id+setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id++clearOneShotLambda :: Id -> Id+clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id++setIdOneShotInfo :: Id -> OneShotInfo -> Id+setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id++updOneShotInfo :: Id -> OneShotInfo -> Id+-- Combine the info in the Id with new info+updOneShotInfo id one_shot+  | do_upd    = setIdOneShotInfo id one_shot+  | otherwise = id+  where+    do_upd = case (idOneShotInfo id, one_shot) of+                (NoOneShotInfo, _) -> True+                (OneShotLam,    _) -> False++-- The OneShotLambda functions simply fiddle with the IdInfo flag+-- But watch out: this may change the type of something else+--      f = \x -> e+-- If we change the one-shot-ness of x, f's type changes++zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id+zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id++zapLamIdInfo :: Id -> Id+zapLamIdInfo = zapInfo zapLamInfo++zapFragileIdInfo :: Id -> Id+zapFragileIdInfo = zapInfo zapFragileInfo++zapIdDemandInfo :: Id -> Id+zapIdDemandInfo = zapInfo zapDemandInfo++zapIdUsageInfo :: Id -> Id+zapIdUsageInfo = zapInfo zapUsageInfo++zapIdUsageEnvInfo :: Id -> Id+zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo++zapIdUsedOnceInfo :: Id -> Id+zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo++zapIdTailCallInfo :: Id -> Id+zapIdTailCallInfo = zapInfo zapTailCallInfo++zapStableUnfolding :: Id -> Id+zapStableUnfolding id+ | isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding+ | otherwise                              = id++{-+Note [transferPolyIdInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~+This transfer is used in three places:+        FloatOut (long-distance let-floating)+        GHC.Core.Op.Simplify.Utils.abstractFloats (short-distance let-floating)+        StgLiftLams (selectively lambda-lift local functions to top-level)++Consider the short-distance let-floating:++   f = /\a. let g = rhs in ...++Then if we float thus++   g' = /\a. rhs+   f = /\a. ...[g' a/g]....++we *do not* want to lose g's+  * strictness information+  * arity+  * inline pragma (though that is bit more debatable)+  * occurrence info++Mostly this is just an optimisation, but it's *vital* to+transfer the occurrence info.  Consider++   NonRec { f = /\a. let Rec { g* = ..g.. } in ... }++where the '*' means 'LoopBreaker'.  Then if we float we must get++   Rec { g'* = /\a. ...(g' a)... }+   NonRec { f = /\a. ...[g' a/g]....}++where g' is also marked as LoopBreaker.  If not, terrible things+can happen if we re-simplify the binding (and the Simplifier does+sometimes simplify a term twice); see #4345.++It's not so simple to retain+  * worker info+  * rules+so we simply discard those.  Sooner or later this may bite us.++If we abstract wrt one or more *value* binders, we must modify the+arity and strictness info before transferring it.  E.g.+      f = \x. e+-->+      g' = \y. \x. e+      + substitute (g' y) for g+Notice that g' has an arity one more than the original g+-}++transferPolyIdInfo :: Id        -- Original Id+                   -> [Var]     -- Abstract wrt these variables+                   -> Id        -- New Id+                   -> Id+transferPolyIdInfo old_id abstract_wrt new_id+  = modifyIdInfo transfer new_id+  where+    arity_increase = count isId abstract_wrt    -- Arity increases by the+                                                -- number of value binders++    old_info        = idInfo old_id+    old_arity       = arityInfo old_info+    old_inline_prag = inlinePragInfo old_info+    old_occ_info    = occInfo old_info+    new_arity       = old_arity + arity_increase+    new_occ_info    = zapOccTailCallInfo old_occ_info++    old_strictness  = strictnessInfo old_info+    new_strictness  = increaseStrictSigArity arity_increase old_strictness+    old_cpr         = cprInfo old_info++    transfer new_info = new_info `setArityInfo` new_arity+                                 `setInlinePragInfo` old_inline_prag+                                 `setOccInfo` new_occ_info+                                 `setStrictnessInfo` new_strictness+                                 `setCprInfo` old_cpr++isNeverLevPolyId :: Id -> Bool+isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo
+ compiler/GHC/Types/Id/Info.hs view
@@ -0,0 +1,652 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@}++(And a pretty good illustration of quite a few things wrong with+Haskell. [WDP 94/11])+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.Types.Id.Info (+        -- * The IdDetails type+        IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails,+        JoinArity, isJoinIdDetails_maybe,+        RecSelParent(..),++        -- * The IdInfo type+        IdInfo,         -- Abstract+        vanillaIdInfo, noCafIdInfo,++        -- ** The OneShotInfo type+        OneShotInfo(..),+        oneShotInfo, noOneShotInfo, hasNoOneShotInfo,+        setOneShotInfo,++        -- ** Zapping various forms of Info+        zapLamInfo, zapFragileInfo,+        zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,+        zapTailCallInfo, zapCallArityInfo, zapUnfolding,++        -- ** The ArityInfo type+        ArityInfo,+        unknownArity,+        arityInfo, setArityInfo, ppArityInfo,++        callArityInfo, setCallArityInfo,++        -- ** Demand and strictness Info+        strictnessInfo, setStrictnessInfo,+        cprInfo, setCprInfo,+        demandInfo, setDemandInfo, pprStrictness,++        -- ** Unfolding Info+        unfoldingInfo, setUnfoldingInfo,++        -- ** The InlinePragInfo type+        InlinePragInfo,+        inlinePragInfo, setInlinePragInfo,++        -- ** The OccInfo type+        OccInfo(..),+        isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker,+        occInfo, setOccInfo,++        InsideLam(..), OneBranch(..),++        TailCallInfo(..),+        tailCallInfo, isAlwaysTailCalled,++        -- ** The RuleInfo type+        RuleInfo(..),+        emptyRuleInfo,+        isEmptyRuleInfo, ruleInfoFreeVars,+        ruleInfoRules, setRuleInfoHead,+        ruleInfo, setRuleInfo,++        -- ** The CAFInfo type+        CafInfo(..),+        ppCafInfo, mayHaveCafRefs,+        cafInfo, setCafInfo,++        -- ** Tick-box Info+        TickBoxOp(..), TickBoxId,++        -- ** Levity info+        LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType,+        isNeverLevPolyIdInfo+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Core++import GHC.Core.Class+import {-# SOURCE #-} PrimOp (PrimOp)+import GHC.Types.Name+import GHC.Types.Var.Set+import GHC.Types.Basic+import GHC.Core.DataCon+import GHC.Core.TyCon+import GHC.Core.PatSyn+import GHC.Core.Type+import GHC.Types.ForeignCall+import Outputable+import GHC.Types.Module+import GHC.Types.Demand+import GHC.Types.Cpr+import Util++-- infixl so you can say (id `set` a `set` b)+infixl  1 `setRuleInfo`,+          `setArityInfo`,+          `setInlinePragInfo`,+          `setUnfoldingInfo`,+          `setOneShotInfo`,+          `setOccInfo`,+          `setCafInfo`,+          `setStrictnessInfo`,+          `setCprInfo`,+          `setDemandInfo`,+          `setNeverLevPoly`,+          `setLevityInfoWithType`++{-+************************************************************************+*                                                                      *+                     IdDetails+*                                                                      *+************************************************************************+-}++-- | Identifier Details+--+-- The 'IdDetails' of an 'Id' give stable, and necessary,+-- information about the Id.+data IdDetails+  = VanillaId++  -- | The 'Id' for a record selector+  | RecSelId+    { sel_tycon   :: RecSelParent+    , sel_naughty :: Bool       -- True <=> a "naughty" selector which can't actually exist, for example @x@ in:+                                --    data T = forall a. MkT { x :: a }+    }                           -- See Note [Naughty record selectors] in TcTyClsDecls++  | DataConWorkId DataCon       -- ^ The 'Id' is for a data constructor /worker/+  | DataConWrapId DataCon       -- ^ The 'Id' is for a data constructor /wrapper/++                                -- [the only reasons we need to know is so that+                                --  a) to support isImplicitId+                                --  b) when desugaring a RecordCon we can get+                                --     from the Id back to the data con]+  | ClassOpId Class             -- ^ The 'Id' is a superclass selector,+                                -- or class operation of a class++  | PrimOpId PrimOp             -- ^ The 'Id' is for a primitive operator+  | FCallId ForeignCall         -- ^ The 'Id' is for a foreign call.+                                -- Type will be simple: no type families, newtypes, etc++  | TickBoxOpId TickBoxOp       -- ^ The 'Id' is for a HPC tick box (both traditional and binary)++  | DFunId Bool                 -- ^ A dictionary function.+       -- Bool = True <=> the class has only one method, so may be+       --                  implemented with a newtype, so it might be bad+       --                  to be strict on this dictionary++  | CoVarId    -- ^ A coercion variable+               -- This only covers /un-lifted/ coercions, of type+               -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants+  | JoinId JoinArity           -- ^ An 'Id' for a join point taking n arguments+       -- Note [Join points] in GHC.Core++-- | Recursive Selector Parent+data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq+  -- Either `TyCon` or `PatSyn` depending+  -- on the origin of the record selector.+  -- For a data type family, this is the+  -- /instance/ 'TyCon' not the family 'TyCon'++instance Outputable RecSelParent where+  ppr p = case p of+            RecSelData ty_con -> ppr ty_con+            RecSelPatSyn ps   -> ppr ps++-- | Just a synonym for 'CoVarId'. Written separately so it can be+-- exported in the hs-boot file.+coVarDetails :: IdDetails+coVarDetails = CoVarId++-- | Check if an 'IdDetails' says 'CoVarId'.+isCoVarDetails :: IdDetails -> Bool+isCoVarDetails CoVarId = True+isCoVarDetails _       = False++isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity+isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity+isJoinIdDetails_maybe _                   = Nothing++instance Outputable IdDetails where+    ppr = pprIdDetails++pprIdDetails :: IdDetails -> SDoc+pprIdDetails VanillaId = empty+pprIdDetails other     = brackets (pp other)+ where+   pp VanillaId               = panic "pprIdDetails"+   pp (DataConWorkId _)       = text "DataCon"+   pp (DataConWrapId _)       = text "DataConWrapper"+   pp (ClassOpId {})          = text "ClassOp"+   pp (PrimOpId _)            = text "PrimOp"+   pp (FCallId _)             = text "ForeignCall"+   pp (TickBoxOpId _)         = text "TickBoxOp"+   pp (DFunId nt)             = text "DFunId" <> ppWhen nt (text "(nt)")+   pp (RecSelId { sel_naughty = is_naughty })+                              = brackets $ text "RecSel" <>+                                           ppWhen is_naughty (text "(naughty)")+   pp CoVarId                 = text "CoVarId"+   pp (JoinId arity)          = text "JoinId" <> parens (int arity)++{-+************************************************************************+*                                                                      *+\subsection{The main IdInfo type}+*                                                                      *+************************************************************************+-}++-- | Identifier Information+--+-- An 'IdInfo' gives /optional/ information about an 'Id'.  If+-- present it never lies, but it may not be present, in which case there+-- is always a conservative assumption which can be made.+--+-- Two 'Id's may have different info even though they have the same+-- 'Unique' (and are hence the same 'Id'); for example, one might lack+-- the properties attached to the other.+--+-- Most of the 'IdInfo' gives information about the value, or definition, of+-- the 'Id', independent of its usage. Exceptions to this+-- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'.+--+-- Performance note: when we update 'IdInfo', we have to reallocate this+-- entire record, so it is a good idea not to let this data structure get+-- too big.+data IdInfo+  = IdInfo {+        arityInfo       :: !ArityInfo,+        -- ^ 'Id' arity, as computed by 'GHC.Core.Arity'. Specifies how many+        -- arguments this 'Id' has to be applied to before it doesn any+        -- meaningful work.+        ruleInfo        :: RuleInfo,+        -- ^ Specialisations of the 'Id's function which exist.+        -- See Note [Specialisations and RULES in IdInfo]+        unfoldingInfo   :: Unfolding,+        -- ^ The 'Id's unfolding+        cafInfo         :: CafInfo,+        -- ^ 'Id' CAF info+        oneShotInfo     :: OneShotInfo,+        -- ^ Info about a lambda-bound variable, if the 'Id' is one+        inlinePragInfo  :: InlinePragma,+        -- ^ Any inline pragma attached to the 'Id'+        occInfo         :: OccInfo,+        -- ^ How the 'Id' occurs in the program+        strictnessInfo  :: StrictSig,+        -- ^ A strictness signature. Digests how a function uses its arguments+        -- if applied to at least 'arityInfo' arguments.+        cprInfo         :: CprSig,+        -- ^ Information on whether the function will ultimately return a+        -- freshly allocated constructor.+        demandInfo      :: Demand,+        -- ^ ID demand information+        callArityInfo   :: !ArityInfo,+        -- ^ How this is called. This is the number of arguments to which a+        -- binding can be eta-expanded without losing any sharing.+        -- n <=> all calls have at least n arguments+        levityInfo      :: LevityInfo+        -- ^ when applied, will this Id ever have a levity-polymorphic type?+    }++-- Setters++setRuleInfo :: IdInfo -> RuleInfo -> IdInfo+setRuleInfo       info sp = sp `seq` info { ruleInfo = sp }+setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo+setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }+setOccInfo :: IdInfo -> OccInfo -> IdInfo+setOccInfo        info oc = oc `seq` info { occInfo = oc }+        -- Try to avoid space leaks by seq'ing++setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo+setUnfoldingInfo info uf+  = -- We don't seq the unfolding, as we generate intermediate+    -- unfoldings which are just thrown away, so evaluating them is a+    -- waste of time.+    -- seqUnfolding uf `seq`+    info { unfoldingInfo = uf }++setArityInfo :: IdInfo -> ArityInfo -> IdInfo+setArityInfo      info ar  = info { arityInfo = ar  }+setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo+setCallArityInfo info ar  = info { callArityInfo = ar  }+setCafInfo :: IdInfo -> CafInfo -> IdInfo+setCafInfo        info caf = info { cafInfo = caf }++setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo+setOneShotInfo      info lb = {-lb `seq`-} info { oneShotInfo = lb }++setDemandInfo :: IdInfo -> Demand -> IdInfo+setDemandInfo info dd = dd `seq` info { demandInfo = dd }++setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo+setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd }++setCprInfo :: IdInfo -> CprSig -> IdInfo+setCprInfo info cpr = cpr `seq` info { cprInfo = cpr }++-- | Basic 'IdInfo' that carries no useful information whatsoever+vanillaIdInfo :: IdInfo+vanillaIdInfo+  = IdInfo {+            cafInfo             = vanillaCafInfo,+            arityInfo           = unknownArity,+            ruleInfo            = emptyRuleInfo,+            unfoldingInfo       = noUnfolding,+            oneShotInfo         = NoOneShotInfo,+            inlinePragInfo      = defaultInlinePragma,+            occInfo             = noOccInfo,+            demandInfo          = topDmd,+            strictnessInfo      = nopSig,+            cprInfo             = topCprSig,+            callArityInfo       = unknownArity,+            levityInfo          = NoLevityInfo+           }++-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references+noCafIdInfo :: IdInfo+noCafIdInfo  = vanillaIdInfo `setCafInfo`    NoCafRefs+        -- Used for built-in type Ids in GHC.Types.Id.Make.++{-+************************************************************************+*                                                                      *+\subsection[arity-IdInfo]{Arity info about an @Id@}+*                                                                      *+************************************************************************++For locally-defined Ids, the code generator maintains its own notion+of their arities; so it should not be asking...  (but other things+besides the code-generator need arity info!)+-}++-- | Arity Information+--+-- An 'ArityInfo' of @n@ tells us that partial application of this+-- 'Id' to up to @n-1@ value arguments does essentially no work.+--+-- That is not necessarily the same as saying that it has @n@ leading+-- lambdas, because coerces may get in the way.+--+-- The arity might increase later in the compilation process, if+-- an extra lambda floats up to the binding site.+type ArityInfo = Arity++-- | It is always safe to assume that an 'Id' has an arity of 0+unknownArity :: Arity+unknownArity = 0++ppArityInfo :: Int -> SDoc+ppArityInfo 0 = empty+ppArityInfo n = hsep [text "Arity", int n]++{-+************************************************************************+*                                                                      *+\subsection{Inline-pragma information}+*                                                                      *+************************************************************************+-}++-- | Inline Pragma Information+--+-- Tells when the inlining is active.+-- When it is active the thing may be inlined, depending on how+-- big it is.+--+-- If there was an @INLINE@ pragma, then as a separate matter, the+-- RHS will have been made to look small with a Core inline 'Note'+--+-- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves+-- entirely as a way to inhibit inlining until we want it+type InlinePragInfo = InlinePragma++{-+************************************************************************+*                                                                      *+               Strictness+*                                                                      *+************************************************************************+-}++pprStrictness :: StrictSig -> SDoc+pprStrictness sig = ppr sig++{-+************************************************************************+*                                                                      *+        RuleInfo+*                                                                      *+************************************************************************++Note [Specialisations and RULES in IdInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking, a GlobalId has an *empty* RuleInfo.  All their+RULES are contained in the globally-built rule-base.  In principle,+one could attach the to M.f the RULES for M.f that are defined in M.+But we don't do that for instance declarations and so we just treat+them all uniformly.++The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is+just for convenience really.++However, LocalIds may have non-empty RuleInfo.  We treat them+differently because:+  a) they might be nested, in which case a global table won't work+  b) the RULE might mention free variables, which we use to keep things alive++In GHC.Iface.Tidy, when the LocalId becomes a GlobalId, its RULES are stripped off+and put in the global list.+-}++-- | Rule Information+--+-- Records the specializations of this 'Id' that we know about+-- in the form of rewrite 'CoreRule's that target them+data RuleInfo+  = RuleInfo+        [CoreRule]+        DVarSet         -- Locally-defined free vars of *both* LHS and RHS+                        -- of rules.  I don't think it needs to include the+                        -- ru_fn though.+                        -- Note [Rule dependency info] in OccurAnal++-- | Assume that no specializations exist: always safe+emptyRuleInfo :: RuleInfo+emptyRuleInfo = RuleInfo [] emptyDVarSet++isEmptyRuleInfo :: RuleInfo -> Bool+isEmptyRuleInfo (RuleInfo rs _) = null rs++-- | Retrieve the locally-defined free variables of both the left and+-- right hand sides of the specialization rules+ruleInfoFreeVars :: RuleInfo -> DVarSet+ruleInfoFreeVars (RuleInfo _ fvs) = fvs++ruleInfoRules :: RuleInfo -> [CoreRule]+ruleInfoRules (RuleInfo rules _) = rules++-- | Change the name of the function the rule is keyed on on all of the 'CoreRule's+setRuleInfoHead :: Name -> RuleInfo -> RuleInfo+setRuleInfoHead fn (RuleInfo rules fvs)+  = RuleInfo (map (setRuleIdName fn) rules) fvs++{-+************************************************************************+*                                                                      *+\subsection[CG-IdInfo]{Code generator-related information}+*                                                                      *+************************************************************************+-}++-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.hs).++-- | Constant applicative form Information+--+-- Records whether an 'Id' makes Constant Applicative Form references+data CafInfo+        = MayHaveCafRefs                -- ^ Indicates that the 'Id' is for either:+                                        --+                                        -- 1. A function or static constructor+                                        --    that refers to one or more CAFs, or+                                        --+                                        -- 2. A real live CAF++        | NoCafRefs                     -- ^ A function or static constructor+                                        -- that refers to no CAFs.+        deriving (Eq, Ord)++-- | Assumes that the 'Id' has CAF references: definitely safe+vanillaCafInfo :: CafInfo+vanillaCafInfo = MayHaveCafRefs++mayHaveCafRefs :: CafInfo -> Bool+mayHaveCafRefs  MayHaveCafRefs = True+mayHaveCafRefs _               = False++instance Outputable CafInfo where+   ppr = ppCafInfo++ppCafInfo :: CafInfo -> SDoc+ppCafInfo NoCafRefs = text "NoCafRefs"+ppCafInfo MayHaveCafRefs = empty++{-+************************************************************************+*                                                                      *+\subsection{Bulk operations on IdInfo}+*                                                                      *+************************************************************************+-}++-- | This is used to remove information on lambda binders that we have+-- setup as part of a lambda group, assuming they will be applied all at once,+-- but turn out to be part of an unsaturated lambda as in e.g:+--+-- > (\x1. \x2. e) arg1+zapLamInfo :: IdInfo -> Maybe IdInfo+zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})+  | is_safe_occ occ && is_safe_dmd demand+  = Nothing+  | otherwise+  = Just (info {occInfo = safe_occ, demandInfo = topDmd})+  where+        -- The "unsafe" occ info is the ones that say I'm not in a lambda+        -- because that might not be true for an unsaturated lambda+    is_safe_occ occ | isAlwaysTailCalled occ           = False+    is_safe_occ (OneOcc { occ_in_lam = NotInsideLam }) = False+    is_safe_occ _other                                 = True++    safe_occ = case occ of+                 OneOcc{} -> occ { occ_in_lam = IsInsideLam+                                 , occ_tail   = NoTailCallInfo }+                 IAmALoopBreaker{}+                          -> occ { occ_tail   = NoTailCallInfo }+                 _other   -> occ++    is_safe_dmd dmd = not (isStrictDmd dmd)++-- | Remove all demand info on the 'IdInfo'+zapDemandInfo :: IdInfo -> Maybe IdInfo+zapDemandInfo info = Just (info {demandInfo = topDmd})++-- | Remove usage (but not strictness) info on the 'IdInfo'+zapUsageInfo :: IdInfo -> Maybe IdInfo+zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)})++-- | Remove usage environment info from the strictness signature on the 'IdInfo'+zapUsageEnvInfo :: IdInfo -> Maybe IdInfo+zapUsageEnvInfo info+    | hasDemandEnvSig (strictnessInfo info)+    = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)})+    | otherwise+    = Nothing++zapUsedOnceInfo :: IdInfo -> Maybe IdInfo+zapUsedOnceInfo info+    = Just $ info { strictnessInfo = zapUsedOnceSig    (strictnessInfo info)+                  , demandInfo     = zapUsedOnceDemand (demandInfo     info) }++zapFragileInfo :: IdInfo -> Maybe IdInfo+-- ^ Zap info that depends on free variables+zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf })+  = new_unf `seq`  -- The unfolding field is not (currently) strict, so we+                   -- force it here to avoid a (zapFragileUnfolding unf) thunk+                   -- which might leak space+    Just (info `setRuleInfo` emptyRuleInfo+               `setUnfoldingInfo` new_unf+               `setOccInfo`       zapFragileOcc occ)+  where+    new_unf = zapFragileUnfolding unf++zapFragileUnfolding :: Unfolding -> Unfolding+zapFragileUnfolding unf+ | isFragileUnfolding unf = noUnfolding+ | otherwise              = unf++zapUnfolding :: Unfolding -> Unfolding+-- Squash all unfolding info, preserving only evaluated-ness+zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding+                 | otherwise            = noUnfolding++zapTailCallInfo :: IdInfo -> Maybe IdInfo+zapTailCallInfo info+  = case occInfo info of+      occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ)+          | otherwise              -> Nothing+        where+          safe_occ = occ { occ_tail = NoTailCallInfo }++zapCallArityInfo :: IdInfo -> IdInfo+zapCallArityInfo info = setCallArityInfo info 0++{-+************************************************************************+*                                                                      *+\subsection{TickBoxOp}+*                                                                      *+************************************************************************+-}++type TickBoxId = Int++-- | Tick box for Hpc-style coverage+data TickBoxOp+   = TickBox Module {-# UNPACK #-} !TickBoxId++instance Outputable TickBoxOp where+    ppr (TickBox mod n)         = text "tick" <+> ppr (mod,n)++{-+************************************************************************+*                                                                      *+   Levity+*                                                                      *+************************************************************************++Note [Levity info]+~~~~~~~~~~~~~~~~~~++Ids store whether or not they can be levity-polymorphic at any amount+of saturation. This is helpful in optimizing the levity-polymorphism check+done in the desugarer, where we can usually learn that something is not+levity-polymorphic without actually figuring out its type. See+isExprLevPoly in GHC.Core.Utils for where this info is used. Storing+this is required to prevent perf/compiler/T5631 from blowing up.++-}++-- See Note [Levity info]+data LevityInfo = NoLevityInfo  -- always safe+                | NeverLevityPolymorphic+  deriving Eq++instance Outputable LevityInfo where+  ppr NoLevityInfo           = text "NoLevityInfo"+  ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic"++-- | Marks an IdInfo describing an Id that is never levity polymorphic (even when+-- applied). The Type is only there for checking that it's really never levity+-- polymorphic+setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo+setNeverLevPoly info ty+  = ASSERT2( not (resultIsLevPoly ty), ppr ty )+    info { levityInfo = NeverLevityPolymorphic }++setLevityInfoWithType :: IdInfo -> Type -> IdInfo+setLevityInfoWithType info ty+  | not (resultIsLevPoly ty)+  = info { levityInfo = NeverLevityPolymorphic }+  | otherwise+  = info++isNeverLevPolyIdInfo :: IdInfo -> Bool+isNeverLevPolyIdInfo info+  | NeverLevityPolymorphic <- levityInfo info = True+  | otherwise                                 = False
+ compiler/GHC/Types/Id/Info.hs-boot view
@@ -0,0 +1,11 @@+module GHC.Types.Id.Info where+import GhcPrelude+import Outputable+data IdInfo+data IdDetails++vanillaIdInfo :: IdInfo+coVarDetails :: IdDetails+isCoVarDetails :: IdDetails -> Bool+pprIdDetails :: IdDetails -> SDoc+
+ compiler/GHC/Types/Id/Make.hs view
@@ -0,0 +1,1708 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1998+++This module contains definitions for the IdInfo for things that+have a standard form, namely:++- data constructors+- record selectors+- method and superclass selectors+- primitive operations+-}++{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Types.Id.Make (+        mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs,++        mkPrimOpId, mkFCallId,++        unwrapNewTypeBody, wrapFamInstBody,+        DataConBoxer(..), vanillaDataConBoxer,+        mkDataConRep, mkDataConWorkId,++        -- And some particular Ids; see below for why they are wired in+        wiredInIds, ghcPrimIds,+        realWorldPrimId,+        voidPrimId, voidArgId,+        nullAddrId, seqId, lazyId, lazyIdKey,+        coercionTokenId, magicDictId, coerceId,+        proxyHashId, noinlineId, noinlineIdName,+        coerceName,++        -- Re-export error Ids+        module GHC.Core.Op.ConstantFold+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Core.Rules+import TysPrim+import TysWiredIn+import GHC.Core.Op.ConstantFold+import GHC.Core.Type+import GHC.Core.TyCo.Rep+import GHC.Core.FamInstEnv+import GHC.Core.Coercion+import TcType+import GHC.Core.Make+import GHC.Core.Utils  ( mkCast, mkDefaultCase )+import GHC.Core.Unfold+import GHC.Types.Literal+import GHC.Core.TyCon+import GHC.Core.Class+import GHC.Types.Name.Set+import GHC.Types.Name+import PrimOp+import GHC.Types.ForeignCall+import GHC.Core.DataCon+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Core+import GHC.Types.Unique+import GHC.Types.Unique.Supply+import PrelNames+import GHC.Types.Basic       hiding ( SuccessFlag(..) )+import Util+import GHC.Driver.Session+import Outputable+import FastString+import ListSetOps+import GHC.Types.Var (VarBndr(Bndr))+import qualified GHC.LanguageExtensions as LangExt++import Data.Maybe       ( maybeToList )++{-+************************************************************************+*                                                                      *+\subsection{Wired in Ids}+*                                                                      *+************************************************************************++Note [Wired-in Ids]+~~~~~~~~~~~~~~~~~~~+A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId')+rather than by looking it up its name in some environment or fetching+it from an interface file.++There are several reasons why an Id might appear in the wiredInIds:++* ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)]++* magicIds: see Note [magicIds]++* errorIds, defined in GHC.Core.Make.+  These error functions (e.g. rUNTIME_ERROR_ID) are wired in+  because the desugarer generates code that mentions them directly++In all cases except ghcPrimIds, there is a definition site in a+library module, which may be called (e.g. in higher order situations);+but the wired-in version means that the details are never read from+that module's interface file; instead, the full definition is right+here.++Note [ghcPrimIds (aka pseudoops)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The ghcPrimIds++  * Are exported from GHC.Prim++  * Can't be defined in Haskell, and hence no Haskell binding site,+    but have perfectly reasonable unfoldings in Core++  * Either have a CompulsoryUnfolding (hence always inlined), or+        of an EvaldUnfolding and void representation (e.g. void#)++  * Are (or should be) defined in primops.txt.pp as 'pseudoop'+    Reason: that's how we generate documentation for them++Note [magicIds]+~~~~~~~~~~~~~~~+The magicIds++  * Are exported from GHC.Magic++  * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs).+    This definition at least generates Haddock documentation for them.++  * May or may not have a CompulsoryUnfolding.++  * But have some special behaviour that can't be done via an+    unfolding from an interface file+-}++wiredInIds :: [Id]+wiredInIds+  =  magicIds+  ++ ghcPrimIds+  ++ errorIds           -- Defined in GHC.Core.Make++magicIds :: [Id]    -- See Note [magicIds]+magicIds = [lazyId, oneShotId, noinlineId]++ghcPrimIds :: [Id]  -- See Note [ghcPrimIds (aka pseudoops)]+ghcPrimIds+  = [ realWorldPrimId+    , voidPrimId+    , nullAddrId+    , seqId+    , magicDictId+    , coerceId+    , proxyHashId+    ]++{-+************************************************************************+*                                                                      *+\subsection{Data constructors}+*                                                                      *+************************************************************************++The wrapper for a constructor is an ordinary top-level binding that evaluates+any strict args, unboxes any args that are going to be flattened, and calls+the worker.++We're going to build a constructor that looks like:++        data (Data a, C b) =>  T a b = T1 !a !Int b++        T1 = /\ a b ->+             \d1::Data a, d2::C b ->+             \p q r -> case p of { p ->+                       case q of { q ->+                       Con T1 [a,b] [p,q,r]}}++Notice that++* d2 is thrown away --- a context in a data decl is used to make sure+  one *could* construct dictionaries at the site the constructor+  is used, but the dictionary isn't actually used.++* We have to check that we can construct Data dictionaries for+  the types a and Int.  Once we've done that we can throw d1 away too.++* We use (case p of q -> ...) to evaluate p, rather than "seq" because+  all that matters is that the arguments are evaluated.  "seq" is+  very careful to preserve evaluation order, which we don't need+  to be here.++  You might think that we could simply give constructors some strictness+  info, like PrimOps, and let CoreToStg do the let-to-case transformation.+  But we don't do that because in the case of primops and functions strictness+  is a *property* not a *requirement*.  In the case of constructors we need to+  do something active to evaluate the argument.++  Making an explicit case expression allows the simplifier to eliminate+  it in the (common) case where the constructor arg is already evaluated.++Note [Wrappers for data instance tycons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the case of data instances, the wrapper also applies the coercion turning+the representation type into the family instance type to cast the result of+the wrapper.  For example, consider the declarations++  data family Map k :: * -> *+  data instance Map (a, b) v = MapPair (Map a (Pair b v))++The tycon to which the datacon MapPair belongs gets a unique internal+name of the form :R123Map, and we call it the representation tycon.+In contrast, Map is the family tycon (accessible via+tyConFamInst_maybe). A coercion allows you to move between+representation and family type.  It is accessible from :R123Map via+tyConFamilyCoercion_maybe and has kind++  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}++The wrapper and worker of MapPair get the types++        -- Wrapper+  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v+  $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v)++        -- Worker+  MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v++This coercion is conditionally applied by wrapFamInstBody.++It's a bit more complicated if the data instance is a GADT as well!++   data instance T [a] where+        T1 :: forall b. b -> T [Maybe b]++Hence we translate to++        -- Wrapper+  $WT1 :: forall b. b -> T [Maybe b]+  $WT1 b v = T1 (Maybe b) b (Maybe b) v+                        `cast` sym (Co7T (Maybe b))++        -- Worker+  T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c++        -- Coercion from family type to representation type+  Co7T a :: T [a] ~ :R7T a++Newtype instances through an additional wrinkle into the mix. Consider the+following example (adapted from #15318, comment:2):++  data family T a+  newtype instance T [a] = MkT [a]++Within the newtype instance, there are three distinct types at play:++1. The newtype's underlying type, [a].+2. The instance's representation type, TList a (where TList is the+   representation tycon).+3. The family type, T [a].++We need two coercions in order to cast from (1) to (3):++(a) A newtype coercion axiom:++      axiom coTList a :: TList a ~ [a]++    (Where TList is the representation tycon of the newtype instance.)++(b) A data family instance coercion axiom:++      axiom coT a :: T [a] ~ TList a++When we translate the newtype instance to Core, we obtain:++    -- Wrapper+  $WMkT :: forall a. [a] -> T [a]+  $WMkT a x = MkT a x |> Sym (coT a)++    -- Worker+  MkT :: forall a. [a] -> TList [a]+  MkT a x = x |> Sym (coTList a)++Unlike for data instances, the worker for a newtype instance is actually an+executable function which expands to a cast, but otherwise, the general+strategy is essentially the same as for data instances. Also note that we have+a wrapper, which is unusual for a newtype, but we make GHC produce one anyway+for symmetry with the way data instances are handled.++Note [Newtype datacons]+~~~~~~~~~~~~~~~~~~~~~~~+The "data constructor" for a newtype should always be vanilla.  At one+point this wasn't true, because the newtype arising from+     class C a => D a+looked like+       newtype T:D a = D:D (C a)+so the data constructor for T:C had a single argument, namely the+predicate (C a).  But now we treat that as an ordinary argument, not+part of the theta-type, so all is well.++Note [Newtype workers]+~~~~~~~~~~~~~~~~~~~~~~+A newtype does not really have a worker. Instead, newtype constructors+just unfold into a cast. But we need *something* for, say, MkAge to refer+to. So, we do this:++* The Id used as the newtype worker will have a compulsory unfolding to+  a cast. See Note [Compulsory newtype unfolding]++* This Id is labeled as a DataConWrapId. We don't want to use a DataConWorkId,+  as those have special treatment in the back end.++* There is no top-level binding, because the compulsory unfolding+  means that it will be inlined (to a cast) at every call site.++We probably should have a NewtypeWorkId, but these Ids disappear as soon as+we desugar anyway, so it seems a step too far.++Note [Compulsory newtype unfolding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Newtype wrappers, just like workers, have compulsory unfoldings.+This is needed so that two optimizations involving newtypes have the same+effect whether a wrapper is present or not:++(1) Case-of-known constructor.+    See Note [beta-reduction in exprIsConApp_maybe].++(2) Matching against the map/coerce RULE. Suppose we have the RULE++    {-# RULE "map/coerce" map coerce = ... #-}++    As described in Note [Getting the map/coerce RULE to work],+    the occurrence of 'coerce' is transformed into:++    {-# RULE "map/coerce" forall (c :: T1 ~R# T2).+                          map ((\v -> v) `cast` c) = ... #-}++    We'd like 'map Age' to match the LHS. For this to happen, Age+    must be unfolded, otherwise we'll be stuck. This is tested in T16208.++It also allows for the posssibility of levity polymorphic newtypes+with wrappers (with -XUnliftedNewtypes):++  newtype N (a :: TYPE r) = MkN a++With -XUnliftedNewtypes, this is allowed -- even though MkN is levity-+polymorphic. It's OK because MkN evaporates in the compiled code, becoming+just a cast. That is, it has a compulsory unfolding. As long as its+argument is not levity-polymorphic (which it can't be, according to+Note [Levity polymorphism invariants] in GHC.Core), and it's saturated,+no levity-polymorphic code ends up in the code generator. The saturation+condition is effectively checked by Note [Detecting forced eta expansion]+in GHC.HsToCore.Expr.++However, if we make a *wrapper* for a newtype, we get into trouble.+The saturation condition is no longer checked (because hasNoBinding+returns False) and indeed we generate a forbidden levity-polymorphic+binding.++The solution is simple, though: just make the newtype wrappers+as ephemeral as the newtype workers. In other words, give the wrappers+compulsory unfoldings and no bindings. The compulsory unfolding is given+in wrap_unf in mkDataConRep, and the lack of a binding happens in+GHC.Iface.Tidy.getTyConImplicitBinds, where we say that a newtype has no+implicit bindings.++************************************************************************+*                                                                      *+\subsection{Dictionary selectors}+*                                                                      *+************************************************************************++Selecting a field for a dictionary.  If there is just one field, then+there's nothing to do.++Dictionary selectors may get nested forall-types.  Thus:++        class Foo a where+          op :: forall b. Ord b => a -> b -> b++Then the top-level type for op is++        op :: forall a. Foo a =>+              forall b. Ord b =>+              a -> b -> b++-}++mkDictSelId :: Name          -- Name of one of the *value* selectors+                             -- (dictionary superclass or method)+            -> Class -> Id+mkDictSelId name clas+  = mkGlobalId (ClassOpId clas) name sel_ty info+  where+    tycon          = classTyCon clas+    sel_names      = map idName (classAllSelIds clas)+    new_tycon      = isNewTyCon tycon+    [data_con]     = tyConDataCons tycon+    tyvars         = dataConUserTyVarBinders data_con+    n_ty_args      = length tyvars+    arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses+    val_index      = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name++    sel_ty = mkForAllTys tyvars $+             mkInvisFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $+             getNth arg_tys val_index++    base_info = noCafIdInfo+                `setArityInfo`          1+                `setStrictnessInfo`     strict_sig+                `setCprInfo`            topCprSig+                `setLevityInfoWithType` sel_ty++    info | new_tycon+         = base_info `setInlinePragInfo` alwaysInlinePragma+                     `setUnfoldingInfo`  mkInlineUnfoldingWithArity 1+                                           (mkDictSelRhs clas val_index)+                   -- See Note [Single-method classes] in TcInstDcls+                   -- for why alwaysInlinePragma++         | otherwise+         = base_info `setRuleInfo` mkRuleInfo [rule]+                   -- Add a magic BuiltinRule, but no unfolding+                   -- so that the rule is always available to fire.+                   -- See Note [ClassOp/DFun selection] in TcInstDcls++    -- This is the built-in rule that goes+    --      op (dfT d1 d2) --->  opT d1 d2+    rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS`+                                     occNameFS (getOccName name)+                       , ru_fn    = name+                       , ru_nargs = n_ty_args + 1+                       , ru_try   = dictSelRule val_index n_ty_args }++        -- The strictness signature is of the form U(AAAVAAAA) -> T+        -- where the V depends on which item we are selecting+        -- It's worth giving one, so that absence info etc is generated+        -- even if the selector isn't inlined++    strict_sig = mkClosedStrictSig [arg_dmd] topDiv+    arg_dmd | new_tycon = evalDmd+            | otherwise = mkManyUsedDmd $+                          mkProdDmd [ if name == sel_name then evalDmd else absDmd+                                    | sel_name <- sel_names ]++mkDictSelRhs :: Class+             -> Int         -- 0-indexed selector among (superclasses ++ methods)+             -> CoreExpr+mkDictSelRhs clas val_index+  = mkLams tyvars (Lam dict_id rhs_body)+  where+    tycon          = classTyCon clas+    new_tycon      = isNewTyCon tycon+    [data_con]     = tyConDataCons tycon+    tyvars         = dataConUnivTyVars data_con+    arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses++    the_arg_id     = getNth arg_ids val_index+    pred           = mkClassPred clas (mkTyVarTys tyvars)+    dict_id        = mkTemplateLocal 1 pred+    arg_ids        = mkTemplateLocalsNum 2 arg_tys++    rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars)+                                                   (Var dict_id)+             | otherwise = mkSingleAltCase (Var dict_id) dict_id (DataAlt data_con)+                                           arg_ids (varToCoreExpr the_arg_id)+                                -- varToCoreExpr needed for equality superclass selectors+                                --   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }++dictSelRule :: Int -> Arity -> RuleFun+-- Tries to persuade the argument to look like a constructor+-- application, using exprIsConApp_maybe, and then selects+-- from it+--       sel_i t1..tk (D t1..tk op1 ... opm) = opi+--+dictSelRule val_index n_ty_args _ id_unf _ args+  | (dict_arg : _) <- drop n_ty_args args+  , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg+  = Just (wrapFloats floats $ getNth con_args val_index)+  | otherwise+  = Nothing++{-+************************************************************************+*                                                                      *+        Data constructors+*                                                                      *+************************************************************************+-}++mkDataConWorkId :: Name -> DataCon -> Id+mkDataConWorkId wkr_name data_con+  | isNewTyCon tycon+  = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info+      -- See Note [Newtype workers]++  | otherwise+  = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info++  where+    tycon  = dataConTyCon data_con  -- The representation TyCon+    wkr_ty = dataConRepType data_con++        ----------- Workers for data types --------------+    alg_wkr_info = noCafIdInfo+                   `setArityInfo`          wkr_arity+                   `setStrictnessInfo`     wkr_sig+                   `setCprInfo`            mkCprSig wkr_arity (dataConCPR data_con)+                   `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,+                                                           -- even if arity = 0+                   `setLevityInfoWithType` wkr_ty+                     -- NB: unboxed tuples have workers, so we can't use+                     -- setNeverLevPoly++    wkr_arity = dataConRepArity data_con+    wkr_sig   = mkClosedStrictSig (replicate wkr_arity topDmd) topDiv+        --      Note [Data-con worker strictness]+        -- Notice that we do *not* say the worker Id is strict+        -- even if the data constructor is declared strict+        --      e.g.    data T = MkT !(Int,Int)+        -- Why?  Because the *wrapper* $WMkT is strict (and its unfolding has+        -- case expressions that do the evals) but the *worker* MkT itself is+        --  not. If we pretend it is strict then when we see+        --      case x of y -> MkT y+        -- the simplifier thinks that y is "sure to be evaluated" (because+        -- the worker MkT is strict) and drops the case.  No, the workerId+        -- MkT is not strict.+        --+        -- However, the worker does have StrictnessMarks.  When the simplifier+        -- sees a pattern+        --      case e of MkT x -> ...+        -- it uses the dataConRepStrictness of MkT to mark x as evaluated;+        -- but that's fine... dataConRepStrictness comes from the data con+        -- not from the worker Id.++        ----------- Workers for newtypes --------------+    univ_tvs = dataConUnivTyVars data_con+    arg_tys  = dataConRepArgTys  data_con  -- Should be same as dataConOrigArgTys+    nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo+                  `setArityInfo` 1      -- Arity 1+                  `setInlinePragInfo`     alwaysInlinePragma+                  `setUnfoldingInfo`      newtype_unf+                  `setLevityInfoWithType` wkr_ty+    id_arg1      = mkTemplateLocal 1 (head arg_tys)+    res_ty_args  = mkTyCoVarTys univ_tvs+    newtype_unf  = ASSERT2( isVanillaDataCon data_con &&+                            isSingleton arg_tys+                          , ppr data_con  )+                              -- Note [Newtype datacons]+                   mkCompulsoryUnfolding $+                   mkLams univ_tvs $ Lam id_arg1 $+                   wrapNewTypeBody tycon res_ty_args (Var id_arg1)++dataConCPR :: DataCon -> CprResult+dataConCPR con+  | isDataTyCon tycon     -- Real data types only; that is,+                          -- not unboxed tuples or newtypes+  , null (dataConExTyCoVars con)  -- No existentials+  , wkr_arity > 0+  , wkr_arity <= mAX_CPR_SIZE+  = conCpr (dataConTag con)+  | otherwise+  = topCpr+  where+    tycon     = dataConTyCon con+    wkr_arity = dataConRepArity con++    mAX_CPR_SIZE :: Arity+    mAX_CPR_SIZE = 10+    -- We do not treat very big tuples as CPR-ish:+    --      a) for a start we get into trouble because there aren't+    --         "enough" unboxed tuple types (a tiresome restriction,+    --         but hard to fix),+    --      b) more importantly, big unboxed tuples get returned mainly+    --         on the stack, and are often then allocated in the heap+    --         by the caller.  So doing CPR for them may in fact make+    --         things worse.++{-+-------------------------------------------------+--         Data constructor representation+--+-- This is where we decide how to wrap/unwrap the+-- constructor fields+--+--------------------------------------------------+-}++type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)+  -- Unbox: bind rep vars by decomposing src var++data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr))+  -- Box:   build src arg using these rep vars++-- | Data Constructor Boxer+newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))+                       -- Bind these src-level vars, returning the+                       -- rep-level vars to bind in the pattern++vanillaDataConBoxer :: DataConBoxer+-- No transformation on arguments needed+vanillaDataConBoxer = DCB (\_tys args -> return (args, []))++{-+Note [Inline partially-applied constructor wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We allow the wrapper to inline when partially applied to avoid+boxing values unnecessarily. For example, consider++   data Foo a = Foo !Int a++   instance Traversable Foo where+     traverse f (Foo i a) = Foo i <$> f a++This desugars to++   traverse f foo = case foo of+        Foo i# a -> let i = I# i#+                    in map ($WFoo i) (f a)++If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`.+But if we inline the wrapper, we get++   map (\a. case i of I# i# a -> Foo i# a) (f a)++and now case-of-known-constructor eliminates the redundant allocation.++-}++mkDataConRep :: DynFlags+             -> FamInstEnvs+             -> Name+             -> Maybe [HsImplBang]+                -- See Note [Bangs on imported data constructors]+             -> DataCon+             -> UniqSM DataConRep+mkDataConRep dflags fam_envs wrap_name mb_bangs data_con+  | not wrapper_reqd+  = return NoDataConRep++  | otherwise+  = do { wrap_args <- mapM newLocal wrap_arg_tys+       ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers)+                                 initial_wrap_app++       ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info+             wrap_info = noCafIdInfo+                         `setArityInfo`         wrap_arity+                             -- It's important to specify the arity, so that partial+                             -- applications are treated as values+                         `setInlinePragInfo`    wrap_prag+                         `setUnfoldingInfo`     wrap_unf+                         `setStrictnessInfo`    wrap_sig+                         `setCprInfo`           mkCprSig wrap_arity (dataConCPR data_con)+                             -- We need to get the CAF info right here because GHC.Iface.Tidy+                             -- does not tidy the IdInfo of implicit bindings (like the wrapper)+                             -- so it not make sure that the CAF info is sane+                         `setLevityInfoWithType` wrap_ty++             wrap_sig = mkClosedStrictSig wrap_arg_dmds topDiv++             wrap_arg_dmds =+               replicate (length theta) topDmd ++ map mk_dmd arg_ibangs+               -- Don't forget the dictionary arguments when building+               -- the strictness signature (#14290).++             mk_dmd str | isBanged str = evalDmd+                        | otherwise    = topDmd++             wrap_prag = alwaysInlinePragma `setInlinePragmaActivation`+                         activeDuringFinal+                         -- See Note [Activation for data constructor wrappers]++             -- The wrapper will usually be inlined (see wrap_unf), so its+             -- strictness and CPR info is usually irrelevant. But this is+             -- not always the case; GHC may choose not to inline it. In+             -- particular, the wrapper constructor is not inlined inside+             -- an INLINE rhs or when it is not applied to any arguments.+             -- See Note [Inline partially-applied constructor wrappers]+             -- Passing Nothing here allows the wrapper to inline when+             -- unsaturated.+             wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs+                        -- See Note [Compulsory newtype unfolding]+                      | otherwise        = mkInlineUnfolding wrap_rhs+             wrap_rhs = mkLams wrap_tvs $+                        mkLams wrap_args $+                        wrapFamInstBody tycon res_ty_args $+                        wrap_body++       ; return (DCR { dcr_wrap_id = wrap_id+                     , dcr_boxer   = mk_boxer boxers+                     , dcr_arg_tys = rep_tys+                     , dcr_stricts = rep_strs+                       -- For newtypes, dcr_bangs is always [HsLazy].+                       -- See Note [HsImplBangs for newtypes].+                     , dcr_bangs   = arg_ibangs }) }++  where+    (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty)+      = dataConFullSig data_con+    wrap_tvs     = dataConUserTyVars data_con+    res_ty_args  = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs++    tycon        = dataConTyCon data_con       -- The representation TyCon (not family)+    wrap_ty      = dataConUserType data_con+    ev_tys       = eqSpecPreds eq_spec ++ theta+    all_arg_tys  = ev_tys ++ orig_arg_tys+    ev_ibangs    = map (const HsLazy) ev_tys+    orig_bangs   = dataConSrcBangs data_con++    wrap_arg_tys = theta ++ orig_arg_tys+    wrap_arity   = count isCoVar ex_tvs + length wrap_arg_tys+             -- The wrap_args are the arguments *other than* the eq_spec+             -- Because we are going to apply the eq_spec args manually in the+             -- wrapper++    new_tycon = isNewTyCon tycon+    arg_ibangs+      | new_tycon+      = ASSERT( isSingleton orig_arg_tys )+        [HsLazy] -- See Note [HsImplBangs for newtypes]+      | otherwise+      = case mb_bangs of+          Nothing    -> zipWith (dataConSrcToImplBang dflags fam_envs)+                                orig_arg_tys orig_bangs+          Just bangs -> bangs++    (rep_tys_w_strs, wrappers)+      = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs))++    (unboxers, boxers) = unzip wrappers+    (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)++    wrapper_reqd =+        (not new_tycon+                     -- (Most) newtypes have only a worker, with the exception+                     -- of some newtypes written with GADT syntax. See below.+         && (any isBanged (ev_ibangs ++ arg_ibangs)+                     -- Some forcing/unboxing (includes eq_spec)+             || (not $ null eq_spec))) -- GADT+      || isFamInstTyCon tycon -- Cast result+      || dataConUserTyVarsArePermuted data_con+                     -- If the data type was written with GADT syntax and+                     -- orders the type variables differently from what the+                     -- worker expects, it needs a data con wrapper to reorder+                     -- the type variables.+                     -- See Note [Data con wrappers and GADT syntax].++    initial_wrap_app = Var (dataConWorkId data_con)+                       `mkTyApps`  res_ty_args+                       `mkVarApps` ex_tvs+                       `mkCoApps`  map (mkReflCo Nominal . eqSpecType) eq_spec++    mk_boxer :: [Boxer] -> DataConBoxer+    mk_boxer boxers = DCB (\ ty_args src_vars ->+                      do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars+                               subst1 = zipTvSubst univ_tvs ty_args+                               subst2 = extendTCvSubstList subst1 ex_tvs+                                                           (mkTyCoVarTys ex_vars)+                         ; (rep_ids, binds) <- go subst2 boxers term_vars+                         ; return (ex_vars ++ rep_ids, binds) } )++    go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])+    go subst (UnitBox : boxers) (src_var : src_vars)+      = do { (rep_ids2, binds) <- go subst boxers src_vars+           ; return (src_var : rep_ids2, binds) }+    go subst (Boxer boxer : boxers) (src_var : src_vars)+      = do { (rep_ids1, arg)  <- boxer subst+           ; (rep_ids2, binds) <- go subst boxers src_vars+           ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) }+    go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con)++    mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr+    mk_rep_app [] con_app+      = return con_app+    mk_rep_app ((wrap_arg, unboxer) : prs) con_app+      = do { (rep_ids, unbox_fn) <- unboxer wrap_arg+           ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)+           ; return (unbox_fn expr) }++{- Note [Activation for data constructor wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Activation on a data constructor wrapper allows it to inline only in Phase+0. This way rules have a chance to fire if they mention a data constructor on+the left+   RULE "foo"  f (K a b) = ...+Since the LHS of rules are simplified with InitialPhase, we won't+inline the wrapper on the LHS either.++On the other hand, this means that exprIsConApp_maybe must be able to deal+with wrappers so that case-of-constructor is not delayed; see+Note [exprIsConApp_maybe on data constructors with wrappers] for details.++It used to activate in phases 2 (afterInitial) and later, but it makes it+awkward to write a RULE[1] with a constructor on the left: it would work if a+constructor has no wrapper, but whether a constructor has a wrapper depends, for+instance, on the order of type argument of that constructors. Therefore changing+the order of type argument could make previously working RULEs fail.++See also https://gitlab.haskell.org/ghc/ghc/issues/15840 .+++Note [Bangs on imported data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs+from imported modules.++- Nothing <=> use HsSrcBangs+- Just bangs <=> use HsImplBangs++For imported types we can't work it all out from the HsSrcBangs,+because we want to be very sure to follow what the original module+(where the data type was declared) decided, and that depends on what+flags were enabled when it was compiled. So we record the decisions in+the interface file.++The HsImplBangs passed are in 1-1 correspondence with the+dataConOrigArgTys of the DataCon.++Note [Data con wrappers and unlifted types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   data T = MkT !Int#++We certainly do not want to make a wrapper+   $WMkT x = case x of y { DEFAULT -> MkT y }++For a start, it's still to generate a no-op.  But worse, since wrappers+are currently injected at TidyCore, we don't even optimise it away!+So the stupid case expression stays there.  This actually happened for+the Integer data type (see #1600 comment:66)!++Note [Data con wrappers and GADT syntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these two very similar data types:++  data T1 a b = MkT1 b++  data T2 a b where+    MkT2 :: forall b a. b -> T2 a b++Despite their similar appearance, T2 will have a data con wrapper but T1 will+not. What sets them apart? The types of their constructors, which are:++  MkT1 :: forall a b. b -> T1 a b+  MkT2 :: forall b a. b -> T2 a b++MkT2's use of GADT syntax allows it to permute the order in which `a` and `b`+would normally appear. See Note [DataCon user type variable binders] in GHC.Core.DataCon+for further discussion on this topic.++The worker data cons for T1 and T2, however, both have types such that `a` is+expected to come before `b` as arguments. Because MkT2 permutes this order, it+needs a data con wrapper to swizzle around the type variables to be in the+order the worker expects.++A somewhat surprising consequence of this is that *newtypes* can have data con+wrappers! After all, a newtype can also be written with GADT syntax:++  newtype T3 a b where+    MkT3 :: forall b a. b -> T3 a b++Again, this needs a wrapper data con to reorder the type variables. It does+mean that this newtype constructor requires another level of indirection when+being called, but the inliner should make swift work of that.++Note [HsImplBangs for newtypes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Most of the time, we use the dataConSrctoImplBang function to decide what+strictness/unpackedness to use for the fields of a data type constructor. But+there is an exception to this rule: newtype constructors. You might not think+that newtypes would pose a challenge, since newtypes are seemingly forbidden+from having strictness annotations in the first place. But consider this+(from #16141):++  {-# LANGUAGE StrictData #-}+  {-# OPTIONS_GHC -O #-}+  newtype T a b where+    MkT :: forall b a. Int -> T a b++Because StrictData (plus optimization) is enabled, invoking+dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#!+This would be disastrous, since the wrapper for `MkT` uses a coercion involving+Int, not Int#.++Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the+case of a newtype constructor, we simply hardcode its dcr_bangs field to+[HsLazy].+-}++-------------------------+newLocal :: Type -> UniqSM Var+newLocal ty = do { uniq <- getUniqueM+                 ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) }+                 -- We should not have "OrCoVar" here, this is a bug (#17545)+++-- | Unpack/Strictness decisions from source module.+--+-- This function should only ever be invoked for data constructor fields, and+-- never on the field of a newtype constructor.+-- See @Note [HsImplBangs for newtypes]@.+dataConSrcToImplBang+   :: DynFlags+   -> FamInstEnvs+   -> Type+   -> HsSrcBang+   -> HsImplBang++dataConSrcToImplBang dflags fam_envs arg_ty+                     (HsSrcBang ann unpk NoSrcStrict)+  | xopt LangExt.StrictData dflags -- StrictData => strict field+  = dataConSrcToImplBang dflags fam_envs arg_ty+                  (HsSrcBang ann unpk SrcStrict)+  | otherwise -- no StrictData => lazy field+  = HsLazy++dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)+  = HsLazy++dataConSrcToImplBang dflags fam_envs arg_ty+                     (HsSrcBang _ unpk_prag SrcStrict)+  | isUnliftedType arg_ty+  = HsLazy  -- For !Int#, say, use HsLazy+            -- See Note [Data con wrappers and unlifted types]++  | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas+          -- Don't unpack if we aren't optimising; rather arbitrarily,+          -- we use -fomit-iface-pragmas as the indication+  , let mb_co   = topNormaliseType_maybe fam_envs arg_ty+                     -- Unwrap type families and newtypes+        arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }+  , isUnpackableType dflags fam_envs arg_ty'+  , (rep_tys, _) <- dataConArgUnpack arg_ty'+  , case unpk_prag of+      NoSrcUnpack ->+        gopt Opt_UnboxStrictFields dflags+            || (gopt Opt_UnboxSmallStrictFields dflags+                && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields]+      srcUnpack -> isSrcUnpacked srcUnpack+  = case mb_co of+      Nothing     -> HsUnpack Nothing+      Just (co,_) -> HsUnpack (Just co)++  | otherwise -- Record the strict-but-no-unpack decision+  = HsStrict+++-- | Wrappers/Workers and representation following Unpack/Strictness+-- decisions+dataConArgRep+  :: Type+  -> HsImplBang+  -> ([(Type,StrictnessMark)] -- Rep types+     ,(Unboxer,Boxer))++dataConArgRep arg_ty HsLazy+  = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))++dataConArgRep arg_ty HsStrict+  = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))++dataConArgRep arg_ty (HsUnpack Nothing)+  | (rep_tys, wrappers) <- dataConArgUnpack arg_ty+  = (rep_tys, wrappers)++dataConArgRep _ (HsUnpack (Just co))+  | let co_rep_ty = coercionRKind co+  , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty+  = (rep_tys, wrapCo co co_rep_ty wrappers)+++-------------------------+wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)+wrapCo co rep_ty (unbox_rep, box_rep)  -- co :: arg_ty ~ rep_ty+  = (unboxer, boxer)+  where+    unboxer arg_id = do { rep_id <- newLocal rep_ty+                        ; (rep_ids, rep_fn) <- unbox_rep rep_id+                        ; let co_bind = NonRec rep_id (Var arg_id `Cast` co)+                        ; return (rep_ids, Let co_bind . rep_fn) }+    boxer = Boxer $ \ subst ->+            do { (rep_ids, rep_expr)+                    <- case box_rep of+                         UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty)+                                       ; return ([rep_id], Var rep_id) }+                         Boxer boxer -> boxer subst+               ; let sco = substCoUnchecked subst co+               ; return (rep_ids, rep_expr `Cast` mkSymCo sco) }++------------------------+seqUnboxer :: Unboxer+seqUnboxer v = return ([v], mkDefaultCase (Var v) v)++unitUnboxer :: Unboxer+unitUnboxer v = return ([v], \e -> e)++unitBoxer :: Boxer+unitBoxer = UnitBox++-------------------------+dataConArgUnpack+   :: Type+   ->  ( [(Type, StrictnessMark)]   -- Rep types+       , (Unboxer, Boxer) )++dataConArgUnpack arg_ty+  | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty+  , Just con <- tyConSingleAlgDataCon_maybe tc+      -- NB: check for an *algebraic* data type+      -- A recursive newtype might mean that+      -- 'arg_ty' is a newtype+  , let rep_tys = dataConInstArgTys con tc_args+  = ASSERT( null (dataConExTyCoVars con) )+      -- Note [Unpacking GADTs and existentials]+    ( rep_tys `zip` dataConRepStrictness con+    ,( \ arg_id ->+       do { rep_ids <- mapM newLocal rep_tys+          ; let unbox_fn body+                  = mkSingleAltCase (Var arg_id) arg_id+                             (DataAlt con) rep_ids body+          ; return (rep_ids, unbox_fn) }+     , Boxer $ \ subst ->+       do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys+          ; return (rep_ids, Var (dataConWorkId con)+                             `mkTyApps` (substTysUnchecked subst tc_args)+                             `mkVarApps` rep_ids ) } ) )+  | otherwise+  = pprPanic "dataConArgUnpack" (ppr arg_ty)+    -- An interface file specified Unpacked, but we couldn't unpack it++isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool+-- True if we can unpack the UNPACK the argument type+-- See Note [Recursive unboxing]+-- We look "deeply" inside rather than relying on the DataCons+-- we encounter on the way, because otherwise we might well+-- end up relying on ourselves!+isUnpackableType dflags fam_envs ty+  | Just data_con <- unpackable_type ty+  = ok_con_args emptyNameSet data_con+  | otherwise+  = False+  where+    ok_con_args dcs con+       | dc_name `elemNameSet` dcs+       = False+       | otherwise+       = all (ok_arg dcs')+             (dataConOrigArgTys con `zip` dataConSrcBangs con)+          -- NB: dataConSrcBangs gives the *user* request;+          -- We'd get a black hole if we used dataConImplBangs+       where+         dc_name = getName con+         dcs' = dcs `extendNameSet` dc_name++    ok_arg dcs (ty, bang)+      = not (attempt_unpack bang) || ok_ty dcs norm_ty+      where+        norm_ty = topNormaliseType fam_envs ty++    ok_ty dcs ty+      | Just data_con <- unpackable_type ty+      = ok_con_args dcs data_con+      | otherwise+      = True        -- NB True here, in contrast to False at top level++    attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)+      = xopt LangExt.StrictData dflags+    attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)+      = True+    attempt_unpack (HsSrcBang _  NoSrcUnpack SrcStrict)+      = True  -- Be conservative+    attempt_unpack (HsSrcBang _  NoSrcUnpack NoSrcStrict)+      = xopt LangExt.StrictData dflags -- Be conservative+    attempt_unpack _ = False++    unpackable_type :: Type -> Maybe DataCon+    -- Works just on a single level+    unpackable_type ty+      | Just (tc, _) <- splitTyConApp_maybe ty+      , Just data_con <- tyConSingleAlgDataCon_maybe tc+      , null (dataConExTyCoVars data_con)+          -- See Note [Unpacking GADTs and existentials]+      = Just data_con+      | otherwise+      = Nothing++{-+Note [Unpacking GADTs and existentials]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is nothing stopping us unpacking a data type with equality+components, like+  data Equal a b where+    Equal :: Equal a a++And it'd be fine to unpack a product type with existential components+too, but that would require a bit more plumbing, so currently we don't.++So for now we require: null (dataConExTyCoVars data_con)+See #14978++Note [Unpack one-wide fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The flag UnboxSmallStrictFields ensures that any field that can+(safely) be unboxed to a word-sized unboxed field, should be so unboxed.+For example:++    data A = A Int#+    newtype B = B A+    data C = C !B+    data D = D !C+    data E = E !()+    data F = F !D+    data G = G !F !F++All of these should have an Int# as their representation, except+G which should have two Int#s.++However++    data T = T !(S Int)+    data S = S !a++Here we can represent T with an Int#.++Note [Recursive unboxing]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data R = MkR {-# UNPACK #-} !S Int+  data S = MkS {-# UNPACK #-} !Int+The representation arguments of MkR are the *representation* arguments+of S (plus Int); the rep args of MkS are Int#.  This is all fine.++But be careful not to try to unbox this!+        data T = MkT {-# UNPACK #-} !T Int+Because then we'd get an infinite number of arguments.++Here is a more complicated case:+        data S = MkS {-# UNPACK #-} !T Int+        data T = MkT {-# UNPACK #-} !S Int+Each of S and T must decide independently whether to unpack+and they had better not both say yes. So they must both say no.++Also behave conservatively when there is no UNPACK pragma+        data T = MkS !T Int+with -funbox-strict-fields or -funbox-small-strict-fields+we need to behave as if there was an UNPACK pragma there.++But it's the *argument* type that matters. This is fine:+        data S = MkS S !Int+because Int is non-recursive.++************************************************************************+*                                                                      *+        Wrapping and unwrapping newtypes and type families+*                                                                      *+************************************************************************+-}++wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr+-- The wrapper for the data constructor for a newtype looks like this:+--      newtype T a = MkT (a,Int)+--      MkT :: forall a. (a,Int) -> T a+--      MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)+-- where CoT is the coercion TyCon associated with the newtype+--+-- The call (wrapNewTypeBody T [a] e) returns the+-- body of the wrapper, namely+--      e `cast` (CoT [a])+--+-- If a coercion constructor is provided in the newtype, then we use+-- it, otherwise the wrap/unwrap are both no-ops++wrapNewTypeBody tycon args result_expr+  = ASSERT( isNewTyCon tycon )+    mkCast result_expr (mkSymCo co)+  where+    co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []++-- When unwrapping, we do *not* apply any family coercion, because this will+-- be done via a CoPat by the type checker.  We have to do it this way as+-- computing the right type arguments for the coercion requires more than just+-- a splitting operation (cf, TcPat.tcConPat).++unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr+unwrapNewTypeBody tycon args result_expr+  = ASSERT( isNewTyCon tycon )+    mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [])++-- If the type constructor is a representation type of a data instance, wrap+-- the expression into a cast adjusting the expression type, which is an+-- instance of the representation type, to the corresponding instance of the+-- family instance type.+-- See Note [Wrappers for data instance tycons]+wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr+wrapFamInstBody tycon args body+  | Just co_con <- tyConFamilyCoercion_maybe tycon+  = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args []))+  | otherwise+  = body++{-+************************************************************************+*                                                                      *+\subsection{Primitive operations}+*                                                                      *+************************************************************************+-}++mkPrimOpId :: PrimOp -> Id+mkPrimOpId prim_op+  = id+  where+    (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op+    ty   = mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty)+    name = mkWiredInName gHC_PRIM (primOpOcc prim_op)+                         (mkPrimOpIdUnique (primOpTag prim_op))+                         (AnId id) UserSyntax+    id   = mkGlobalId (PrimOpId prim_op) name ty info++    -- PrimOps don't ever construct a product, but we want to preserve bottoms+    cpr+      | isBotDiv (snd (splitStrictSig strict_sig)) = botCpr+      | otherwise                                  = topCpr++    info = noCafIdInfo+           `setRuleInfo`           mkRuleInfo (maybeToList $ primOpRules name prim_op)+           `setArityInfo`          arity+           `setStrictnessInfo`     strict_sig+           `setCprInfo`            mkCprSig arity cpr+           `setInlinePragInfo`     neverInlinePragma+           `setLevityInfoWithType` res_ty+               -- We give PrimOps a NOINLINE pragma so that we don't+               -- get silly warnings from Desugar.dsRule (the inline_shadows_rule+               -- test) about a RULE conflicting with a possible inlining+               -- cf #7287++-- For each ccall we manufacture a separate CCallOpId, giving it+-- a fresh unique, a type that is correct for this particular ccall,+-- and a CCall structure that gives the correct details about calling+-- convention etc.+--+-- The *name* of this Id is a local name whose OccName gives the full+-- details of the ccall, type and all.  This means that the interface+-- file reader can reconstruct a suitable Id++mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id+mkFCallId dflags uniq fcall ty+  = ASSERT( noFreeVarsOfType ty )+    -- A CCallOpId should have no free type variables;+    -- when doing substitutions won't substitute over it+    mkGlobalId (FCallId fcall) name ty info+  where+    occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty))+    -- The "occurrence name" of a ccall is the full info about the+    -- ccall; it is encoded, but may have embedded spaces etc!++    name = mkFCallName uniq occ_str++    info = noCafIdInfo+           `setArityInfo`          arity+           `setStrictnessInfo`     strict_sig+           `setCprInfo`            topCprSig+           `setLevityInfoWithType` ty++    (bndrs, _) = tcSplitPiTys ty+    arity      = count isAnonTyCoBinder bndrs+    strict_sig = mkClosedStrictSig (replicate arity topDmd) topDiv+    -- the call does not claim to be strict in its arguments, since they+    -- may be lifted (foreign import prim) and the called code doesn't+    -- necessarily force them. See #11076.+{-+************************************************************************+*                                                                      *+\subsection{DictFuns and default methods}+*                                                                      *+************************************************************************++Note [Dict funs and default methods]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Dict funs and default methods are *not* ImplicitIds.  Their definition+involves user-written code, so we can't figure out their strictness etc+based on fixed info, as we can for constructors and record selectors (say).++NB: See also Note [Exported LocalIds] in GHC.Types.Id+-}++mkDictFunId :: Name      -- Name to use for the dict fun;+            -> [TyVar]+            -> ThetaType+            -> Class+            -> [Type]+            -> Id+-- Implements the DFun Superclass Invariant (see TcInstDcls)+-- See Note [Dict funs and default methods]++mkDictFunId dfun_name tvs theta clas tys+  = mkExportedLocalId (DFunId is_nt)+                      dfun_name+                      dfun_ty+  where+    is_nt = isNewTyCon (classTyCon clas)+    dfun_ty = mkDictFunTy tvs theta clas tys++mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type+mkDictFunTy tvs theta clas tys+ = mkSpecSigmaTy tvs theta (mkClassPred clas tys)++{-+************************************************************************+*                                                                      *+\subsection{Un-definable}+*                                                                      *+************************************************************************++These Ids can't be defined in Haskell.  They could be defined in+unfoldings in the wired-in GHC.Prim interface file, but we'd have to+ensure that they were definitely, definitely inlined, because there is+no curried identifier for them.  That's what mkCompulsoryUnfolding+does.  If we had a way to get a compulsory unfolding from an interface+file, we could do that, but we don't right now.++The type variables we use here are "open" type variables: this means+they can unify with both unlifted and lifted types.  Hence we provide+another gun with which to shoot yourself in the foot.+-}++nullAddrName, seqName,+   realWorldName, voidPrimIdName, coercionTokenName,+   magicDictName, coerceName, proxyName :: Name+nullAddrName      = mkWiredInIdName gHC_PRIM  (fsLit "nullAddr#")      nullAddrIdKey      nullAddrId+seqName           = mkWiredInIdName gHC_PRIM  (fsLit "seq")            seqIdKey           seqId+realWorldName     = mkWiredInIdName gHC_PRIM  (fsLit "realWorld#")     realWorldPrimIdKey realWorldPrimId+voidPrimIdName    = mkWiredInIdName gHC_PRIM  (fsLit "void#")          voidPrimIdKey      voidPrimId+coercionTokenName = mkWiredInIdName gHC_PRIM  (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId+magicDictName     = mkWiredInIdName gHC_PRIM  (fsLit "magicDict")      magicDictKey       magicDictId+coerceName        = mkWiredInIdName gHC_PRIM  (fsLit "coerce")         coerceKey          coerceId+proxyName         = mkWiredInIdName gHC_PRIM  (fsLit "proxy#")         proxyHashKey       proxyHashId++lazyIdName, oneShotName, noinlineIdName :: Name+lazyIdName        = mkWiredInIdName gHC_MAGIC (fsLit "lazy")           lazyIdKey          lazyId+oneShotName       = mkWiredInIdName gHC_MAGIC (fsLit "oneShot")        oneShotKey         oneShotId+noinlineIdName    = mkWiredInIdName gHC_MAGIC (fsLit "noinline")       noinlineIdKey      noinlineId++------------------------------------------------+proxyHashId :: Id+proxyHashId+  = pcMiscPrelId proxyName ty+       (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]+                    `setNeverLevPoly`  ty )+  where+    -- proxy# :: forall {k} (a:k). Proxy# k a+    --+    -- The visibility of the `k` binder is Inferred to match the type of the+    -- Proxy data constructor (#16293).+    [kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id+    kv_ty   = mkTyVarTy kv+    tv_ty   = mkTyVarTy tv+    ty      = mkInvForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty++------------------------------------------------+nullAddrId :: Id+-- nullAddr# :: Addr#+-- The reason it is here is because we don't provide+-- a way to write this literal in Haskell.+nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info+  where+    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma+                       `setUnfoldingInfo`  mkCompulsoryUnfolding (Lit nullAddrLit)+                       `setNeverLevPoly`   addrPrimTy++------------------------------------------------+seqId :: Id     -- See Note [seqId magic]+seqId = pcMiscPrelId seqName ty info+  where+    info = noCafIdInfo `setInlinePragInfo` inline_prag+                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs++    inline_prag+         = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter+                 NoSourceText 0+                  -- Make 'seq' not inline-always, so that simpleOptExpr+                  -- (see GHC.Core.Subst.simple_app) won't inline 'seq' on the+                  -- LHS of rules.  That way we can have rules for 'seq';+                  -- see Note [seqId magic]++    -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b+    ty  =+      mkInvForAllTy runtimeRep2TyVar+      $ mkSpecForAllTys [alphaTyVar, openBetaTyVar]+      $ mkVisFunTy alphaTy (mkVisFunTy openBetaTy openBetaTy)++    [x,y] = mkTemplateLocals [alphaTy, openBetaTy]+    rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $+          Case (Var x) x openBetaTy [(DEFAULT, [], Var y)]++------------------------------------------------+lazyId :: Id    -- See Note [lazyId magic]+lazyId = pcMiscPrelId lazyIdName ty info+  where+    info = noCafIdInfo `setNeverLevPoly` ty+    ty  = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy)++noinlineId :: Id -- See Note [noinlineId magic]+noinlineId = pcMiscPrelId noinlineIdName ty info+  where+    info = noCafIdInfo `setNeverLevPoly` ty+    ty  = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy)++oneShotId :: Id -- See Note [The oneShot function]+oneShotId = pcMiscPrelId oneShotName ty info+  where+    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma+                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs+    ty  = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar+                          , openAlphaTyVar, openBetaTyVar ]+                          (mkVisFunTy fun_ty fun_ty)+    fun_ty = mkVisFunTy openAlphaTy openBetaTy+    [body, x] = mkTemplateLocals [fun_ty, openAlphaTy]+    x' = setOneShotLambda x  -- Here is the magic bit!+    rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar+                 , openAlphaTyVar, openBetaTyVar+                 , body, x'] $+          Var body `App` Var x++--------------------------------------------------------------------------------+magicDictId :: Id  -- See Note [magicDictId magic]+magicDictId = pcMiscPrelId magicDictName ty info+  where+  info = noCafIdInfo `setInlinePragInfo` neverInlinePragma+                     `setNeverLevPoly`   ty+  ty   = mkSpecForAllTys [alphaTyVar] alphaTy++--------------------------------------------------------------------------------++coerceId :: Id+coerceId = pcMiscPrelId coerceName ty info+  where+    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma+                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs+    eqRTy     = mkTyConApp coercibleTyCon [ tYPE r , a, b ]+    eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ]+    ty        = mkForAllTys [ Bndr rv Inferred+                            , Bndr av Specified+                            , Bndr bv Specified+                            ] $+                mkInvisFunTy eqRTy $+                mkVisFunTy a b++    bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy+                        (\r -> [tYPE r, tYPE r])++    [r, a, b] = mkTyVarTys bndrs++    [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy]+    rhs = mkLams (bndrs ++ [eqR, x]) $+          mkWildCase (Var eqR) eqRTy b $+          [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))]++{-+Note [seqId magic]+~~~~~~~~~~~~~~~~~~+'GHC.Prim.seq' is special in several ways.++a) Its fixity is set in GHC.Iface.Load.ghcPrimIface++b) It has quite a bit of desugaring magic.+   See GHC.HsToCore.Utils.hs Note [Desugaring seq (1)] and (2) and (3)++c) There is some special rule handing: Note [User-defined RULES for seq]++Historical note:+    In TcExpr we used to need a special typing rule for 'seq', to handle calls+    whose second argument had an unboxed type, e.g.  x `seq` 3#++    However, with levity polymorphism we can now give seq the type seq ::+    forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b which handles this+    case without special treatment in the typechecker.++Note [User-defined RULES for seq]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Roman found situations where he had+      case (f n) of _ -> e+where he knew that f (which was strict in n) would terminate if n did.+Notice that the result of (f n) is discarded. So it makes sense to+transform to+      case n of _ -> e++Rather than attempt some general analysis to support this, I've added+enough support that you can do this using a rewrite rule:++  RULE "f/seq" forall n.  seq (f n) = seq n++You write that rule.  When GHC sees a case expression that discards+its result, it mentally transforms it to a call to 'seq' and looks for+a RULE.  (This is done in GHC.Core.Op.Simplify.trySeqRules.)  As usual, the+correctness of the rule is up to you.++VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2.+If we wrote+  RULE "f/seq" forall n e.  seq (f n) e = seq n e+with rule arity 2, then two bad things would happen:++  - The magical desugaring done in Note [seqId magic] item (b)+    for saturated application of 'seq' would turn the LHS into+    a case expression!++  - The code in GHC.Core.Op.Simplify.rebuildCase would need to actually supply+    the value argument, which turns out to be awkward.++See also: Note [User-defined RULES for seq] in GHC.Core.Op.Simplify.+++Note [lazyId magic]+~~~~~~~~~~~~~~~~~~~+lazy :: forall a?. a? -> a?   (i.e. works for unboxed types too)++'lazy' is used to make sure that a sub-expression, and its free variables,+are truly used call-by-need, with no code motion.  Key examples:++* pseq:    pseq a b = a `seq` lazy b+  We want to make sure that the free vars of 'b' are not evaluated+  before 'a', even though the expression is plainly strict in 'b'.++* catch:   catch a b = catch# (lazy a) b+  Again, it's clear that 'a' will be evaluated strictly (and indeed+  applied to a state token) but we want to make sure that any exceptions+  arising from the evaluation of 'a' are caught by the catch (see+  #11555).++Implementing 'lazy' is a bit tricky:++* It must not have a strictness signature: by being a built-in Id,+  all the info about lazyId comes from here, not from GHC.Base.hi.+  This is important, because the strictness analyser will spot it as+  strict!++* It must not have an unfolding: it gets "inlined" by a HACK in+  CorePrep. It's very important to do this inlining *after* unfoldings+  are exposed in the interface file.  Otherwise, the unfolding for+  (say) pseq in the interface file will not mention 'lazy', so if we+  inline 'pseq' we'll totally miss the very thing that 'lazy' was+  there for in the first place. See #3259 for a real world+  example.++* Suppose CorePrep sees (catch# (lazy e) b).  At all costs we must+  avoid using call by value here:+     case e of r -> catch# r b+  Avoiding that is the whole point of 'lazy'.  So in CorePrep (which+  generate the 'case' expression for a call-by-value call) we must+  spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let'+  instead.++* lazyId is defined in GHC.Base, so we don't *have* to inline it.  If it+  appears un-applied, we'll end up just calling it.++Note [noinlineId magic]+~~~~~~~~~~~~~~~~~~~~~~~+noinline :: forall a. a -> a++'noinline' is used to make sure that a function f is never inlined,+e.g., as in 'noinline f x'.  Ordinarily, the identity function with NOINLINE+could be used to achieve this effect; however, this has the unfortunate+result of leaving a (useless) call to noinline at runtime.  So we have+a little bit of magic to optimize away 'noinline' after we are done+running the simplifier.++'noinline' needs to be wired-in because it gets inserted automatically+when we serialize an expression to the interface format. See+Note [Inlining and hs-boot files] in GHC.CoreToIface++Note that noinline as currently implemented can hide some simplifications since+it hides strictness from the demand analyser. Specifically, the demand analyser+will treat 'noinline f x' as lazy in 'x', even if the demand signature of 'f'+specifies that it is strict in its argument. We considered fixing this this by adding a+special case to the demand analyser to address #16588. However, the special+case seemed like a large and expensive hammer to address a rare case and+consequently we rather opted to use a more minimal solution.++Note [The oneShot function]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the context of making left-folds fuse somewhat okish (see ticket #7994+and Note [Left folds via right fold]) it was determined that it would be useful+if library authors could explicitly tell the compiler that a certain lambda is+called at most once. The oneShot function allows that.++'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted+types as well (#10744); e.g.+   oneShot (\x:Int# -> x +# 1#)++Like most magic functions it has a compulsory unfolding, so there is no need+for a real definition somewhere. We have one in GHC.Magic for the convenience+of putting the documentation there.++It uses `setOneShotLambda` on the lambda's binder. That is the whole magic:++A typical call looks like+     oneShot (\y. e)+after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get+     (\f \x[oneshot]. f x) (\y. e)+ --> \x[oneshot]. ((\y.e) x)+ --> \x[oneshot] e[x/y]+which is what we want.++It is only effective if the one-shot info survives as long as possible; in+particular it must make it into the interface in unfoldings. See Note [Preserve+OneShotInfo] in GHC.Core.Op.Tidy.++Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot.+++Note [magicDictId magic]+~~~~~~~~~~~~~~~~~~~~~~~~~+The identifier `magicDict` is just a place-holder, which is used to+implement a primitive that we cannot define in Haskell but we can write+in Core.  It is declared with a place-holder type:++    magicDict :: forall a. a++The intention is that the identifier will be used in a very specific way,+to create dictionaries for classes with a single method.  Consider a class+like this:++   class C a where+     f :: T a++We are going to use `magicDict`, in conjunction with a built-in Prelude+rule, to cast values of type `T a` into dictionaries for `C a`.  To do+this, we define a function like this in the library:++  data WrapC a b = WrapC (C a => Proxy a -> b)++  withT :: (C a => Proxy a -> b)+        ->  T a -> Proxy a -> b+  withT f x y = magicDict (WrapC f) x y++The purpose of `WrapC` is to avoid having `f` instantiated.+Also, it avoids impredicativity, because `magicDict`'s type+cannot be instantiated with a forall.  The field of `WrapC` contains+a `Proxy` parameter which is used to link the type of the constraint,+`C a`, with the type of the `Wrap` value being made.++Next, we add a built-in Prelude rule (see GHC.Core.Op.ConstantFold),+which will replace the RHS of this definition with the appropriate+definition in Core.  The rewrite rule works as follows:++  magicDict @t (wrap @a @b f) x y+---->+  f (x `cast` co a) y++The `co` coercion is the newtype-coercion extracted from the type-class.+The type class is obtain by looking at the type of wrap.+++-------------------------------------------------------------+@realWorld#@ used to be a magic literal, \tr{void#}.  If things get+nasty as-is, change it back to a literal (@Literal@).++voidArgId is a Local Id used simply as an argument in functions+where we just want an arg to avoid having a thunk of unlifted type.+E.g.+        x = \ void :: Void# -> (# p, q #)++This comes up in strictness analysis++Note [evaldUnfoldings]+~~~~~~~~~~~~~~~~~~~~~~+The evaldUnfolding makes it look that some primitive value is+evaluated, which in turn makes Simplify.interestingArg return True,+which in turn makes INLINE things applied to said value likely to be+inlined.+-}++realWorldPrimId :: Id   -- :: State# RealWorld+realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy+                     (noCafIdInfo `setUnfoldingInfo` evaldUnfolding    -- Note [evaldUnfoldings]+                                  `setOneShotInfo` stateHackOneShot+                                  `setNeverLevPoly` realWorldStatePrimTy)++voidPrimId :: Id     -- Global constant :: Void#+voidPrimId  = pcMiscPrelId voidPrimIdName voidPrimTy+                (noCafIdInfo `setUnfoldingInfo` evaldUnfolding     -- Note [evaldUnfoldings]+                             `setNeverLevPoly`  voidPrimTy)++voidArgId :: Id       -- Local lambda-bound :: Void#+voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy++coercionTokenId :: Id         -- :: () ~ ()+coercionTokenId -- See Note [Coercion tokens] in CoreToStg.hs+  = pcMiscPrelId coercionTokenName+                 (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy])+                 noCafIdInfo++pcMiscPrelId :: Name -> Type -> IdInfo -> Id+pcMiscPrelId name ty info+  = mkVanillaGlobalWithInfo name ty info+    -- We lie and say the thing is imported; otherwise, we get into+    -- a mess with dependency analysis; e.g., core2stg may heave in+    -- random calls to GHCbase.unpackPS__.  If GHCbase is the module+    -- being compiled, then it's just a matter of luck if the definition+    -- will be in "the right place" to be in scope.
+ compiler/GHC/Types/Id/Make.hs-boot view
@@ -0,0 +1,15 @@+module GHC.Types.Id.Make where+import GHC.Types.Name( Name )+import GHC.Types.Var( Id )+import GHC.Core.Class( Class )+import {-# SOURCE #-} GHC.Core.DataCon( DataCon )+import {-# SOURCE #-} PrimOp( PrimOp )++data DataConBoxer++mkDataConWorkId :: Name -> DataCon -> Id+mkDictSelId     :: Name -> Class   -> Id++mkPrimOpId      :: PrimOp -> Id++magicDictId :: Id
+ compiler/GHC/Types/Literal.hs view
@@ -0,0 +1,847 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998++\section[Literal]{@Literal@: literals}+-}++{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Types.Literal+        (+        -- * Main data type+          Literal(..)           -- Exported to ParseIface+        , LitNumType(..)++        -- ** Creating Literals+        , mkLitInt, mkLitIntWrap, mkLitIntWrapC+        , mkLitWord, mkLitWordWrap, mkLitWordWrapC+        , mkLitInt64, mkLitInt64Wrap+        , mkLitWord64, mkLitWord64Wrap+        , mkLitFloat, mkLitDouble+        , mkLitChar, mkLitString+        , mkLitInteger, mkLitNatural+        , mkLitNumber, mkLitNumberWrap++        -- ** Operations on Literals+        , literalType+        , absentLiteralOf+        , pprLiteral+        , litNumIsSigned+        , litNumCheckRange++        -- ** Predicates on Literals and their contents+        , litIsDupable, litIsTrivial, litIsLifted+        , inCharRange+        , isZeroLit+        , litFitsInChar+        , litValue, isLitValue, isLitValue_maybe, mapLitValue++        -- ** Coercions+        , word2IntLit, int2WordLit+        , narrowLit+        , narrow8IntLit, narrow16IntLit, narrow32IntLit+        , narrow8WordLit, narrow16WordLit, narrow32WordLit+        , char2IntLit, int2CharLit+        , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit+        , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit+        ) where++#include "HsVersions.h"++import GhcPrelude++import TysPrim+import PrelNames+import GHC.Core.Type+import GHC.Core.TyCon+import Outputable+import FastString+import GHC.Types.Basic+import Binary+import Constants+import GHC.Platform+import GHC.Types.Unique.FM+import Util++import Data.ByteString (ByteString)+import Data.Int+import Data.Word+import Data.Char+import Data.Maybe ( isJust )+import Data.Data ( Data )+import Data.Proxy+import Numeric ( fromRat )++{-+************************************************************************+*                                                                      *+\subsection{Literals}+*                                                                      *+************************************************************************+-}++-- | So-called 'Literal's are one of:+--+-- * An unboxed numeric literal or floating-point literal which is presumed+--   to be surrounded by appropriate constructors (@Int#@, etc.), so that+--   the overall thing makes sense.+--+--   We maintain the invariant that the 'Integer' in the 'LitNumber'+--   constructor is actually in the (possibly target-dependent) range.+--   The mkLit{Int,Word}*Wrap smart constructors ensure this by applying+--   the target machine's wrapping semantics. Use these in situations+--   where you know the wrapping semantics are correct.+--+-- * The literal derived from the label mentioned in a \"foreign label\"+--   declaration ('LitLabel')+--+-- * A 'LitRubbish' to be used in place of values of 'UnliftedRep'+--   (i.e. 'MutVar#') when the the value is never used.+--+-- * A character+-- * A string+-- * The NULL pointer+--+data Literal+  = LitChar    Char             -- ^ @Char#@ - at least 31 bits. Create with+                                -- 'mkLitChar'++  | LitNumber !LitNumType !Integer Type+                                -- ^ Any numeric literal that can be+                                -- internally represented with an Integer.+                                -- See Note [Types of LitNumbers] below for the+                                -- Type field.++  | LitString  ByteString       -- ^ A string-literal: stored and emitted+                                -- UTF-8 encoded, we'll arrange to decode it+                                -- at runtime.  Also emitted with a @\'\\0\'@+                                -- terminator. Create with 'mkLitString'++  | LitNullAddr                 -- ^ The @NULL@ pointer, the only pointer value+                                -- that can be represented as a Literal. Create+                                -- with 'nullAddrLit'++  | LitRubbish                  -- ^ A nonsense value, used when an unlifted+                                -- binding is absent and has type+                                -- @forall (a :: 'TYPE' 'UnliftedRep'). a@.+                                -- May be lowered by code-gen to any possible+                                -- value. Also see Note [Rubbish literals]++  | LitFloat   Rational         -- ^ @Float#@. Create with 'mkLitFloat'+  | LitDouble  Rational         -- ^ @Double#@. Create with 'mkLitDouble'++  | LitLabel   FastString (Maybe Int) FunctionOrData+                                -- ^ A label literal. Parameters:+                                --+                                -- 1) The name of the symbol mentioned in the+                                --    declaration+                                --+                                -- 2) The size (in bytes) of the arguments+                                --    the label expects. Only applicable with+                                --    @stdcall@ labels. @Just x@ => @\<x\>@ will+                                --    be appended to label name when emitting+                                --    assembly.+                                --+                                -- 3) Flag indicating whether the symbol+                                --    references a function or a data+  deriving Data++-- | Numeric literal type+data LitNumType+  = LitNumInteger -- ^ @Integer@ (see Note [Integer literals])+  | LitNumNatural -- ^ @Natural@ (see Note [Natural literals])+  | LitNumInt     -- ^ @Int#@ - according to target machine+  | LitNumInt64   -- ^ @Int64#@ - exactly 64 bits+  | LitNumWord    -- ^ @Word#@ - according to target machine+  | LitNumWord64  -- ^ @Word64#@ - exactly 64 bits+  deriving (Data,Enum,Eq,Ord)++-- | Indicate if a numeric literal type supports negative numbers+litNumIsSigned :: LitNumType -> Bool+litNumIsSigned nt = case nt of+  LitNumInteger -> True+  LitNumNatural -> False+  LitNumInt     -> True+  LitNumInt64   -> True+  LitNumWord    -> False+  LitNumWord64  -> False++{-+Note [Integer literals]+~~~~~~~~~~~~~~~~~~~~~~~+An Integer literal is represented using, well, an Integer, to make it+easier to write RULEs for them. They also contain the Integer type, so+that e.g. literalType can return the right Type for them.++They only get converted into real Core,+    mkInteger [c1, c2, .., cn]+during the CorePrep phase, although GHC.Iface.Tidy looks ahead at what the+core will be, so that it can see whether it involves CAFs.++When we initially build an Integer literal, notably when+deserialising it from an interface file (see the Binary instance+below), we don't have convenient access to the mkInteger Id.  So we+just use an error thunk, and fill in the real Id when we do tcIfaceLit+in GHC.IfaceToCore.++Note [Natural literals]+~~~~~~~~~~~~~~~~~~~~~~~+Similar to Integer literals.++Note [String literals]+~~~~~~~~~~~~~~~~~~~~~~++String literals are UTF-8 encoded and stored into ByteStrings in the following+ASTs: Haskell, Core, Stg, Cmm. TH can also emit ByteString based string literals+with the BytesPrimL constructor (see #14741).++It wasn't true before as [Word8] was used in Cmm AST and in TH which was quite+bad for performance with large strings (see #16198 and #14741).++To include string literals into output objects, the assembler code generator has+to embed the UTF-8 encoded binary blob. See Note [Embedding large binary blobs]+for more details.++-}++instance Binary LitNumType where+   put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp))+   get bh = do+      h <- getByte bh+      return (toEnum (fromIntegral h))++instance Binary Literal where+    put_ bh (LitChar aa)     = do putByte bh 0; put_ bh aa+    put_ bh (LitString ab)   = do putByte bh 1; put_ bh ab+    put_ bh (LitNullAddr)    = do putByte bh 2+    put_ bh (LitFloat ah)    = do putByte bh 3; put_ bh ah+    put_ bh (LitDouble ai)   = do putByte bh 4; put_ bh ai+    put_ bh (LitLabel aj mb fod)+        = do putByte bh 5+             put_ bh aj+             put_ bh mb+             put_ bh fod+    put_ bh (LitNumber nt i _)+        = do putByte bh 6+             put_ bh nt+             put_ bh i+    put_ bh (LitRubbish)     = do putByte bh 7+    get bh = do+            h <- getByte bh+            case h of+              0 -> do+                    aa <- get bh+                    return (LitChar aa)+              1 -> do+                    ab <- get bh+                    return (LitString ab)+              2 -> do+                    return (LitNullAddr)+              3 -> do+                    ah <- get bh+                    return (LitFloat ah)+              4 -> do+                    ai <- get bh+                    return (LitDouble ai)+              5 -> do+                    aj <- get bh+                    mb <- get bh+                    fod <- get bh+                    return (LitLabel aj mb fod)+              6 -> do+                    nt <- get bh+                    i  <- get bh+                    -- Note [Types of LitNumbers]+                    let t = case nt of+                            LitNumInt     -> intPrimTy+                            LitNumInt64   -> int64PrimTy+                            LitNumWord    -> wordPrimTy+                            LitNumWord64  -> word64PrimTy+                            -- See Note [Integer literals]+                            LitNumInteger ->+                              panic "Evaluated the place holder for mkInteger"+                            -- and Note [Natural literals]+                            LitNumNatural ->+                              panic "Evaluated the place holder for mkNatural"+                    return (LitNumber nt i t)+              _ -> do+                    return (LitRubbish)++instance Outputable Literal where+    ppr = pprLiteral id++instance Eq Literal where+    a == b = compare a b == EQ++-- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in+-- 'TrieMap.CoreMap'.+instance Ord Literal where+    compare = cmpLit++{-+        Construction+        ~~~~~~~~~~~~+-}++{- Note [Word/Int underflow/overflow]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and+unsigned integral types): "All arithmetic is performed modulo 2^n, where n is+the number of bits in the type."++GHC stores Word# and Int# constant values as Integer. Core optimizations such+as constant folding must ensure that the Integer value remains in the valid+target Word/Int range (see #13172). The following functions are used to+ensure this.++Note that we *don't* warn the user about overflow. It's not done at runtime+either, and compilation of completely harmless things like+   ((124076834 :: Word32) + (2147483647 :: Word32))+doesn't yield a warning. Instead we simply squash the value into the *target*+Int/Word range.+-}++-- | Wrap a literal number according to its type+wrapLitNumber :: Platform -> Literal -> Literal+wrapLitNumber platform v@(LitNumber nt i t) = case nt of+  LitNumInt -> case platformWordSize platform of+    PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t+    PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t+  LitNumWord -> case platformWordSize platform of+    PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t+    PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t+  LitNumInt64   -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t+  LitNumWord64  -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t+  LitNumInteger -> v+  LitNumNatural -> v+wrapLitNumber _ x = x++-- | Create a numeric 'Literal' of the given type+mkLitNumberWrap :: Platform -> LitNumType -> Integer -> Type -> Literal+mkLitNumberWrap platform nt i t = wrapLitNumber platform (LitNumber nt i t)++-- | Check that a given number is in the range of a numeric literal+litNumCheckRange :: Platform -> LitNumType -> Integer -> Bool+litNumCheckRange platform nt i = case nt of+     LitNumInt     -> platformInIntRange platform i+     LitNumWord    -> platformInWordRange platform i+     LitNumInt64   -> inInt64Range i+     LitNumWord64  -> inWord64Range i+     LitNumNatural -> i >= 0+     LitNumInteger -> True++-- | Create a numeric 'Literal' of the given type+mkLitNumber :: Platform -> LitNumType -> Integer -> Type -> Literal+mkLitNumber platform nt i t =+  ASSERT2(litNumCheckRange platform nt i, integer i)+  (LitNumber nt i t)++-- | Creates a 'Literal' of type @Int#@+mkLitInt :: Platform -> Integer -> Literal+mkLitInt platform x = ASSERT2( platformInIntRange platform x,  integer x )+                       (mkLitIntUnchecked x)++-- | Creates a 'Literal' of type @Int#@.+--   If the argument is out of the (target-dependent) range, it is wrapped.+--   See Note [Word/Int underflow/overflow]+mkLitIntWrap :: Platform -> Integer -> Literal+mkLitIntWrap platform i = wrapLitNumber platform $ mkLitIntUnchecked i++-- | Creates a 'Literal' of type @Int#@ without checking its range.+mkLitIntUnchecked :: Integer -> Literal+mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy++-- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating+--   overflow. That is, if the argument is out of the (target-dependent) range+--   the argument is wrapped and the overflow flag will be set.+--   See Note [Word/Int underflow/overflow]+mkLitIntWrapC :: Platform -> Integer -> (Literal, Bool)+mkLitIntWrapC platform i = (n, i /= i')+  where+    n@(LitNumber _ i' _) = mkLitIntWrap platform i++-- | Creates a 'Literal' of type @Word#@+mkLitWord :: Platform -> Integer -> Literal+mkLitWord platform x = ASSERT2( platformInWordRange platform x, integer x )+                        (mkLitWordUnchecked x)++-- | Creates a 'Literal' of type @Word#@.+--   If the argument is out of the (target-dependent) range, it is wrapped.+--   See Note [Word/Int underflow/overflow]+mkLitWordWrap :: Platform -> Integer -> Literal+mkLitWordWrap platform i = wrapLitNumber platform $ mkLitWordUnchecked i++-- | Creates a 'Literal' of type @Word#@ without checking its range.+mkLitWordUnchecked :: Integer -> Literal+mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy++-- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating+--   carry. That is, if the argument is out of the (target-dependent) range+--   the argument is wrapped and the carry flag will be set.+--   See Note [Word/Int underflow/overflow]+mkLitWordWrapC :: Platform -> Integer -> (Literal, Bool)+mkLitWordWrapC platform i = (n, i /= i')+  where+    n@(LitNumber _ i' _) = mkLitWordWrap platform i++-- | Creates a 'Literal' of type @Int64#@+mkLitInt64 :: Integer -> Literal+mkLitInt64  x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x)++-- | Creates a 'Literal' of type @Int64#@.+--   If the argument is out of the range, it is wrapped.+mkLitInt64Wrap :: Platform -> Integer -> Literal+mkLitInt64Wrap platform i = wrapLitNumber platform $ mkLitInt64Unchecked i++-- | Creates a 'Literal' of type @Int64#@ without checking its range.+mkLitInt64Unchecked :: Integer -> Literal+mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy++-- | Creates a 'Literal' of type @Word64#@+mkLitWord64 :: Integer -> Literal+mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x)++-- | Creates a 'Literal' of type @Word64#@.+--   If the argument is out of the range, it is wrapped.+mkLitWord64Wrap :: Platform -> Integer -> Literal+mkLitWord64Wrap platform i = wrapLitNumber platform $ mkLitWord64Unchecked i++-- | Creates a 'Literal' of type @Word64#@ without checking its range.+mkLitWord64Unchecked :: Integer -> Literal+mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy++-- | Creates a 'Literal' of type @Float#@+mkLitFloat :: Rational -> Literal+mkLitFloat = LitFloat++-- | Creates a 'Literal' of type @Double#@+mkLitDouble :: Rational -> Literal+mkLitDouble = LitDouble++-- | Creates a 'Literal' of type @Char#@+mkLitChar :: Char -> Literal+mkLitChar = LitChar++-- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to+-- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@+mkLitString :: String -> Literal+-- stored UTF-8 encoded+mkLitString s = LitString (bytesFS $ mkFastString s)++mkLitInteger :: Integer -> Type -> Literal+mkLitInteger x ty = LitNumber LitNumInteger x ty++mkLitNatural :: Integer -> Type -> Literal+mkLitNatural x ty = ASSERT2( inNaturalRange x,  integer x )+                    (LitNumber LitNumNatural x ty)++inNaturalRange :: Integer -> Bool+inNaturalRange x = x >= 0++inInt64Range, inWord64Range :: Integer -> Bool+inInt64Range x  = x >= toInteger (minBound :: Int64) &&+                  x <= toInteger (maxBound :: Int64)+inWord64Range x = x >= toInteger (minBound :: Word64) &&+                  x <= toInteger (maxBound :: Word64)++inCharRange :: Char -> Bool+inCharRange c =  c >= '\0' && c <= chr tARGET_MAX_CHAR++-- | Tests whether the literal represents a zero of whatever type it is+isZeroLit :: Literal -> Bool+isZeroLit (LitNumber _ 0 _) = True+isZeroLit (LitFloat  0)     = True+isZeroLit (LitDouble 0)     = True+isZeroLit _                 = False++-- | Returns the 'Integer' contained in the 'Literal', for when that makes+-- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'.+litValue  :: Literal -> Integer+litValue l = case isLitValue_maybe l of+   Just x  -> x+   Nothing -> pprPanic "litValue" (ppr l)++-- | Returns the 'Integer' contained in the 'Literal', for when that makes+-- sense, i.e. for 'Char' and numbers.+isLitValue_maybe  :: Literal -> Maybe Integer+isLitValue_maybe (LitChar   c)     = Just $ toInteger $ ord c+isLitValue_maybe (LitNumber _ i _) = Just i+isLitValue_maybe _                 = Nothing++-- | Apply a function to the 'Integer' contained in the 'Literal', for when that+-- makes sense, e.g. for 'Char' and numbers.+-- For fixed-size integral literals, the result will be wrapped in accordance+-- with the semantics of the target type.+-- See Note [Word/Int underflow/overflow]+mapLitValue  :: Platform -> (Integer -> Integer) -> Literal -> Literal+mapLitValue _        f (LitChar   c)      = mkLitChar (fchar c)+   where fchar = chr . fromInteger . f . toInteger . ord+mapLitValue platform f (LitNumber nt i t) = wrapLitNumber platform+                                                        (LitNumber nt (f i) t)+mapLitValue _        _ l                  = pprPanic "mapLitValue" (ppr l)++-- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',+-- 'Int', 'Word', 'LitInteger' and 'LitNatural'.+isLitValue  :: Literal -> Bool+isLitValue = isJust . isLitValue_maybe++{-+        Coercions+        ~~~~~~~~~+-}++narrow8IntLit, narrow16IntLit, narrow32IntLit,+  narrow8WordLit, narrow16WordLit, narrow32WordLit,+  char2IntLit, int2CharLit,+  float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,+  float2DoubleLit, double2FloatLit+  :: Literal -> Literal++word2IntLit, int2WordLit :: Platform -> Literal -> Literal+word2IntLit platform (LitNumber LitNumWord w _)+  -- Map Word range [max_int+1, max_word]+  -- to Int range   [min_int  , -1]+  -- Range [0,max_int] has the same representation with both Int and Word+  | w > platformMaxInt platform = mkLitInt platform (w - platformMaxWord platform - 1)+  | otherwise                   = mkLitInt platform w+word2IntLit _ l = pprPanic "word2IntLit" (ppr l)++int2WordLit platform (LitNumber LitNumInt i _)+  -- Map Int range [min_int  , -1]+  -- to Word range [max_int+1, max_word]+  -- Range [0,max_int] has the same representation with both Int and Word+  | i < 0     = mkLitWord platform (1 + platformMaxWord platform + i)+  | otherwise = mkLitWord platform i+int2WordLit _ l = pprPanic "int2WordLit" (ppr l)++-- | Narrow a literal number (unchecked result range)+narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal+narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t+narrowLit _ l                  = pprPanic "narrowLit" (ppr l)++narrow8IntLit   = narrowLit (Proxy :: Proxy Int8)+narrow16IntLit  = narrowLit (Proxy :: Proxy Int16)+narrow32IntLit  = narrowLit (Proxy :: Proxy Int32)+narrow8WordLit  = narrowLit (Proxy :: Proxy Word8)+narrow16WordLit = narrowLit (Proxy :: Proxy Word16)+narrow32WordLit = narrowLit (Proxy :: Proxy Word32)++char2IntLit (LitChar c)       = mkLitIntUnchecked (toInteger (ord c))+char2IntLit l                 = pprPanic "char2IntLit" (ppr l)+int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i))+int2CharLit l                 = pprPanic "int2CharLit" (ppr l)++float2IntLit (LitFloat f)      = mkLitIntUnchecked (truncate f)+float2IntLit l                 = pprPanic "float2IntLit" (ppr l)+int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i)+int2FloatLit l                 = pprPanic "int2FloatLit" (ppr l)++double2IntLit (LitDouble f)     = mkLitIntUnchecked (truncate f)+double2IntLit l                 = pprPanic "double2IntLit" (ppr l)+int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i)+int2DoubleLit l                 = pprPanic "int2DoubleLit" (ppr l)++float2DoubleLit (LitFloat  f) = LitDouble f+float2DoubleLit l             = pprPanic "float2DoubleLit" (ppr l)+double2FloatLit (LitDouble d) = LitFloat  d+double2FloatLit l             = pprPanic "double2FloatLit" (ppr l)++nullAddrLit :: Literal+nullAddrLit = LitNullAddr++-- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@.+rubbishLit :: Literal+rubbishLit = LitRubbish++{-+        Predicates+        ~~~~~~~~~~+-}++-- | True if there is absolutely no penalty to duplicating the literal.+-- False principally of strings.+--+-- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would+-- blow up code sizes. Not only this, it's also unsafe.+--+-- Consider a program that wants to traverse a string. One way it might do this+-- is to first compute the Addr# pointing to the end of the string, and then,+-- starting from the beginning, bump a pointer using eqAddr# to determine the+-- end. For instance,+--+-- @+-- -- Given pointers to the start and end of a string, count how many zeros+-- -- the string contains.+-- countZeros :: Addr# -> Addr# -> -> Int+-- countZeros start end = go start 0+--   where+--     go off n+--       | off `addrEq#` end = n+--       | otherwise         = go (off `plusAddr#` 1) n'+--       where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1+--                | otherwise                                 = n+-- @+--+-- Consider what happens if we considered strings to be trivial (and therefore+-- duplicable) and emitted a call like @countZeros "hello"# ("hello"#+-- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same+-- string, meaning that an iteration like the above would blow up terribly.+-- This is what happened in #12757.+--+-- Ultimately the solution here is to make primitive strings a bit more+-- structured, ensuring that the compiler can't inline in ways that will break+-- user code. One approach to this is described in #8472.+litIsTrivial :: Literal -> Bool+--      c.f. GHC.Core.Utils.exprIsTrivial+litIsTrivial (LitString _)      = False+litIsTrivial (LitNumber nt _ _) = case nt of+  LitNumInteger -> False+  LitNumNatural -> False+  LitNumInt     -> True+  LitNumInt64   -> True+  LitNumWord    -> True+  LitNumWord64  -> True+litIsTrivial _                  = True++-- | True if code space does not go bad if we duplicate this literal+litIsDupable :: Platform -> Literal -> Bool+--      c.f. GHC.Core.Utils.exprIsDupable+litIsDupable platform x = case x of+   (LitNumber nt i _) -> case nt of+      LitNumInteger -> platformInIntRange platform i+      LitNumNatural -> platformInWordRange platform i+      LitNumInt     -> True+      LitNumInt64   -> True+      LitNumWord    -> True+      LitNumWord64  -> True+   (LitString _) -> False+   _             -> True++litFitsInChar :: Literal -> Bool+litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound)+                               && i <= toInteger (ord maxBound)+litFitsInChar _                 = False++litIsLifted :: Literal -> Bool+litIsLifted (LitNumber nt _ _) = case nt of+  LitNumInteger -> True+  LitNumNatural -> True+  LitNumInt     -> False+  LitNumInt64   -> False+  LitNumWord    -> False+  LitNumWord64  -> False+litIsLifted _                  = False++{-+        Types+        ~~~~~++Note [Types of LitNumbers]+~~~~~~~~~~~~~~~~~~~~~~~~~~++A LitNumber's type is always known from its LitNumType:++  LitNumInteger -> Integer+  LitNumNatural -> Natural+  LitNumInt     -> Int# (intPrimTy)+  LitNumInt64   -> Int64# (int64PrimTy)+  LitNumWord    -> Word# (wordPrimTy)+  LitNumWord64  -> Word64# (word64PrimTy)++The reason why we have a Type field is because Integer and Natural types live+outside of GHC (in the libraries), so we have to get the actual Type via+lookupTyCon, tcIfaceTyConByName etc. that's too inconvenient in the call sites+of literalType, so we do that when creating these literals, and literalType+simply reads the field.++(But see also Note [Integer literals] and Note [Natural literals])+-}++-- | Find the Haskell 'Type' the literal occupies+literalType :: Literal -> Type+literalType LitNullAddr       = addrPrimTy+literalType (LitChar _)       = charPrimTy+literalType (LitString  _)    = addrPrimTy+literalType (LitFloat _)      = floatPrimTy+literalType (LitDouble _)     = doublePrimTy+literalType (LitLabel _ _ _)  = addrPrimTy+literalType (LitNumber _ _ t) = t -- Note [Types of LitNumbers]+literalType (LitRubbish)      = mkForAllTy a Inferred (mkTyVarTy a)+  where+    a = alphaTyVarUnliftedRep++absentLiteralOf :: TyCon -> Maybe Literal+-- Return a literal of the appropriate primitive+-- TyCon, to use as a placeholder when it doesn't matter+-- Rubbish literals are handled in GHC.Core.Op.WorkWrap.Lib, because+--  1. Looking at the TyCon is not enough, we need the actual type+--  2. This would need to return a type application to a literal+absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)++absent_lits :: UniqFM Literal+absent_lits = listToUFM [ (addrPrimTyConKey,    LitNullAddr)+                        , (charPrimTyConKey,    LitChar 'x')+                        , (intPrimTyConKey,     mkLitIntUnchecked 0)+                        , (int64PrimTyConKey,   mkLitInt64Unchecked 0)+                        , (wordPrimTyConKey,    mkLitWordUnchecked 0)+                        , (word64PrimTyConKey,  mkLitWord64Unchecked 0)+                        , (floatPrimTyConKey,   LitFloat 0)+                        , (doublePrimTyConKey,  LitDouble 0)+                        ]++{-+        Comparison+        ~~~~~~~~~~+-}++cmpLit :: Literal -> Literal -> Ordering+cmpLit (LitChar      a)     (LitChar       b)     = a `compare` b+cmpLit (LitString    a)     (LitString     b)     = a `compare` b+cmpLit (LitNullAddr)        (LitNullAddr)         = EQ+cmpLit (LitFloat     a)     (LitFloat      b)     = a `compare` b+cmpLit (LitDouble    a)     (LitDouble     b)     = a `compare` b+cmpLit (LitLabel     a _ _) (LitLabel      b _ _) = a `compare` b+cmpLit (LitNumber nt1 a _)  (LitNumber nt2  b _)+  | nt1 == nt2 = a   `compare` b+  | otherwise  = nt1 `compare` nt2+cmpLit (LitRubbish)         (LitRubbish)          = EQ+cmpLit lit1 lit2+  | litTag lit1 < litTag lit2 = LT+  | otherwise                 = GT++litTag :: Literal -> Int+litTag (LitChar      _)   = 1+litTag (LitString    _)   = 2+litTag (LitNullAddr)      = 3+litTag (LitFloat     _)   = 4+litTag (LitDouble    _)   = 5+litTag (LitLabel _ _ _)   = 6+litTag (LitNumber  {})    = 7+litTag (LitRubbish)       = 8++{-+        Printing+        ~~~~~~~~+* See Note [Printing of literals in Core]+-}++pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc+pprLiteral _       (LitChar c)     = pprPrimChar c+pprLiteral _       (LitString s)   = pprHsBytes s+pprLiteral _       (LitNullAddr)   = text "__NULL"+pprLiteral _       (LitFloat f)    = float (fromRat f) <> primFloatSuffix+pprLiteral _       (LitDouble d)   = double (fromRat d) <> primDoubleSuffix+pprLiteral add_par (LitNumber nt i _)+   = case nt of+       LitNumInteger -> pprIntegerVal add_par i+       LitNumNatural -> pprIntegerVal add_par i+       LitNumInt     -> pprPrimInt i+       LitNumInt64   -> pprPrimInt64 i+       LitNumWord    -> pprPrimWord i+       LitNumWord64  -> pprPrimWord64 i+pprLiteral add_par (LitLabel l mb fod) =+    add_par (text "__label" <+> b <+> ppr fod)+    where b = case mb of+              Nothing -> pprHsString l+              Just x  -> doubleQuotes (text (unpackFS l ++ '@':show x))+pprLiteral _       (LitRubbish)     = text "__RUBBISH"++pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc+-- See Note [Printing of literals in Core].+pprIntegerVal add_par i | i < 0     = add_par (integer i)+                        | otherwise = integer i++{-+Note [Printing of literals in Core]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The function `add_par` is used to wrap parenthesis around negative integers+(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring+an atomic thing (for example function application).++Although not all Core literals would be valid Haskell, we are trying to stay+as close as possible to Haskell syntax in the printing of Core, to make it+easier for a Haskell user to read Core.++To that end:+  * We do print parenthesis around negative `LitInteger`, because we print+  `LitInteger` using plain number literals (no prefix or suffix), and plain+  number literals in Haskell require parenthesis in contexts like function+  application (i.e. `1 - -1` is not valid Haskell).++  * We don't print parenthesis around other (negative) literals, because they+  aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's+  parser).++Literal         Output             Output if context requires+                                   an atom (if different)+-------         -------            ----------------------+LitChar         'a'#+LitString       "aaa"#+LitNullAddr     "__NULL"+LitInt          -1#+LitInt64        -1L#+LitWord          1##+LitWord64        1L##+LitFloat        -1.0#+LitDouble       -1.0##+LitInteger      -1                 (-1)+LitLabel        "__label" ...      ("__label" ...)+LitRubbish      "__RUBBISH"++Note [Rubbish literals]+~~~~~~~~~~~~~~~~~~~~~~~+During worker/wrapper after demand analysis, where an argument+is unused (absent) we do the following w/w split (supposing that+y is absent):++  f x y z = e+===>+  f x y z = $wf x z+  $wf x z = let y = <absent value>+            in e++Usually the binding for y is ultimately optimised away, and+even if not it should never be evaluated -- but that's the+way the w/w split starts off.++What is <absent value>?+* For lifted values <absent value> can be a call to 'error'.+* For primitive types like Int# or Word# we can use any random+  value of that type.+* But what about /unlifted/ but /boxed/ types like MutVar# or+  Array#?   We need a literal value of that type.++That is 'LitRubbish'.  Since we need a rubbish literal for+many boxed, unlifted types, we say that LitRubbish has type+  LitRubbish :: forall (a :: TYPE UnliftedRep). a++So we might see a w/w split like+  $wf x z = let y :: Array# Int = LitRubbish @(Array# Int)+            in e++Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted+heap pointers.++Here are the moving parts:++* We define LitRubbish as a constructor in GHC.Types.Literal.Literal++* It is given its polymorphic type by Literal.literalType++* GHC.Core.Op.WorkWrap.Lib.mk_absent_let introduces a LitRubbish for absent+  arguments of boxed, unlifted type.++* In CoreToSTG we convert (RubishLit @t) to just ().  STG is+  untyped, so it doesn't matter that it points to a lifted+  value. The important thing is that it is a heap pointer,+  which the garbage collector can follow if it encounters it.++  We considered maintaining LitRubbish in STG, and lowering+  it in the code generators, but it seems simpler to do it+  once and for all in CoreToSTG.++  In GHC.ByteCode.Asm we just lower it as a 0 literal, because+  it's all boxed and lifted to the host GC anyway.+-}
+ compiler/GHC/Types/Module.hs view
@@ -0,0 +1,1322 @@+{-+(c) The University of Glasgow, 2004-2006+++Module+~~~~~~~~~~+Simply the name of a module, represented as a FastString.+These are Uniquable, hence we can build Maps with Modules as+the keys.+-}++{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module GHC.Types.Module+    (+        -- * The ModuleName type+        ModuleName,+        pprModuleName,+        moduleNameFS,+        moduleNameString,+        moduleNameSlashes, moduleNameColons,+        moduleStableString,+        moduleFreeHoles,+        moduleIsDefinite,+        mkModuleName,+        mkModuleNameFS,+        stableModuleNameCmp,++        -- * The UnitId type+        ComponentId(..),+        ComponentDetails(..),+        UnitId(..),+        unitIdFS,+        unitIdKey,+        IndefUnitId(..),+        IndefModule(..),+        indefUnitIdToUnitId,+        indefModuleToModule,+        InstalledUnitId(..),+        toInstalledUnitId,+        ShHoleSubst,++        unitIdIsDefinite,+        unitIdString,+        unitIdFreeHoles,++        newUnitId,+        newIndefUnitId,+        newSimpleUnitId,+        hashUnitId,+        fsToUnitId,+        stringToUnitId,+        stableUnitIdCmp,++        -- * HOLE renaming+        renameHoleUnitId,+        renameHoleModule,+        renameHoleUnitId',+        renameHoleModule',++        -- * Generalization+        splitModuleInsts,+        splitUnitIdInsts,+        generalizeIndefUnitId,+        generalizeIndefModule,++        -- * Parsers+        parseModuleName,+        parseUnitId,+        parseComponentId,+        parseModuleId,+        parseModSubst,++        -- * Wired-in UnitIds+        -- $wired_in_packages+        primUnitId,+        integerUnitId,+        baseUnitId,+        rtsUnitId,+        thUnitId,+        mainUnitId,+        thisGhcUnitId,+        isHoleModule,+        interactiveUnitId, isInteractiveModule,+        wiredInUnitIds,++        -- * The Module type+        Module(Module),+        moduleUnitId, moduleName,+        pprModule,+        mkModule,+        mkHoleModule,+        stableModuleCmp,+        HasModule(..),+        ContainsModule(..),++        -- * Installed unit ids and modules+        InstalledModule(..),+        InstalledModuleEnv,+        installedModuleEq,+        installedUnitIdEq,+        installedUnitIdString,+        fsToInstalledUnitId,+        componentIdToInstalledUnitId,+        stringToInstalledUnitId,+        emptyInstalledModuleEnv,+        lookupInstalledModuleEnv,+        extendInstalledModuleEnv,+        filterInstalledModuleEnv,+        delInstalledModuleEnv,+        DefUnitId(..),++        -- * The ModuleLocation type+        ModLocation(..),+        addBootSuffix, addBootSuffix_maybe,+        addBootSuffixLocn, addBootSuffixLocnOut,++        -- * Module mappings+        ModuleEnv,+        elemModuleEnv, extendModuleEnv, extendModuleEnvList,+        extendModuleEnvList_C, plusModuleEnv_C,+        delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv,+        lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,+        moduleEnvKeys, moduleEnvElts, moduleEnvToList,+        unitModuleEnv, isEmptyModuleEnv,+        extendModuleEnvWith, filterModuleEnv,++        -- * ModuleName mappings+        ModuleNameEnv, DModuleNameEnv,++        -- * Sets of Modules+        ModuleSet,+        emptyModuleSet, mkModuleSet, moduleSetElts,+        extendModuleSet, extendModuleSetList, delModuleSet,+        elemModuleSet, intersectModuleSet, minusModuleSet, unionModuleSet,+        unitModuleSet+    ) where++import GhcPrelude++import Outputable+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM+import GHC.Types.Unique.DSet+import FastString+import Binary+import Util+import Data.List (sortBy, sort)+import Data.Ord+import Data.Version+import GHC.PackageDb+import Fingerprint++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS.Char8+import Encoding++import qualified Text.ParserCombinators.ReadP as Parse+import Text.ParserCombinators.ReadP (ReadP, (<++))+import Data.Char (isAlphaNum)+import Control.DeepSeq+import Data.Coerce+import Data.Data+import Data.Function+import Data.Map (Map)+import Data.Set (Set)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified FiniteMap as Map+import System.FilePath++import {-# SOURCE #-} GHC.Driver.Session (DynFlags)+import {-# SOURCE #-} GHC.Driver.Packages (improveUnitId, componentIdString, UnitInfoMap, getUnitInfoMap, displayInstalledUnitId, getPackageState)++-- Note [The identifier lexicon]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Unit IDs, installed package IDs, ABI hashes, package names,+-- versions, there are a *lot* of different identifiers for closely+-- related things.  What do they all mean? Here's what.  (See also+-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/packages/concepts )+--+-- THE IMPORTANT ONES+--+-- ComponentId: An opaque identifier provided by Cabal, which should+-- uniquely identify such things as the package name, the package+-- version, the name of the component, the hash of the source code+-- tarball, the selected Cabal flags, GHC flags, direct dependencies of+-- the component.  These are very similar to InstalledPackageId, but+-- an 'InstalledPackageId' implies that it identifies a package, while+-- a package may install multiple components with different+-- 'ComponentId's.+--      - Same as Distribution.Package.ComponentId+--+-- UnitId/InstalledUnitId: A ComponentId + a mapping from hole names+-- (ModuleName) to Modules.  This is how the compiler identifies instantiated+-- components, and also is the main identifier by which GHC identifies things.+--      - When Backpack is not being used, UnitId = ComponentId.+--        this means a useful fiction for end-users is that there are+--        only ever ComponentIds, and some ComponentIds happen to have+--        more information (UnitIds).+--      - Same as Language.Haskell.TH.Syntax:PkgName, see+--          https://gitlab.haskell.org/ghc/ghc/issues/10279+--      - The same as PackageKey in GHC 7.10 (we renamed it because+--        they don't necessarily identify packages anymore.)+--      - Same as -this-package-key/-package-name flags+--      - An InstalledUnitId corresponds to an actual package which+--        we have installed on disk.  It could be definite or indefinite,+--        but if it's indefinite, it has nothing instantiated (we+--        never install partially instantiated units.)+--+-- Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how+-- the compiler identifies modules (e.g. a Name is a Module + OccName)+--      - Same as Language.Haskell.TH.Syntax:Module+--+-- THE LESS IMPORTANT ONES+--+-- PackageName: The "name" field in a Cabal file, something like "lens".+--      - Same as Distribution.Package.PackageName+--      - DIFFERENT FROM Language.Haskell.TH.Syntax:PkgName, see+--          https://gitlab.haskell.org/ghc/ghc/issues/10279+--      - DIFFERENT FROM -package-name flag+--      - DIFFERENT FROM the 'name' field in an installed package+--        information.  This field could more accurately be described+--        as a munged package name: when it's for the main library+--        it is the same as the package name, but if it's an internal+--        library it's a munged combination of the package name and+--        the component name.+--+-- LEGACY ONES+--+-- InstalledPackageId: This is what we used to call ComponentId.+-- It's a still pretty useful concept for packages that have only+-- one library; in that case the logical InstalledPackageId =+-- ComponentId.  Also, the Cabal nix-local-build continues to+-- compute an InstalledPackageId which is then forcibly used+-- for all components in a package.  This means that if a dependency+-- from one component in a package changes, the InstalledPackageId+-- changes: you don't get as fine-grained dependency tracking,+-- but it means your builds are hermetic.  Eventually, Cabal will+-- deal completely in components and we can get rid of this.+--+-- PackageKey: This is what we used to call UnitId.  We ditched+-- "Package" from the name when we realized that you might want to+-- assign different "PackageKeys" to components from the same package.+-- (For a brief, non-released period of time, we also called these+-- UnitKeys).++{-+************************************************************************+*                                                                      *+\subsection{Module locations}+*                                                                      *+************************************************************************+-}++-- | Module Location+--+-- Where a module lives on the file system: the actual locations+-- of the .hs, .hi and .o files, if we have them+data ModLocation+   = ModLocation {+        ml_hs_file   :: Maybe FilePath,+                -- The source file, if we have one.  Package modules+                -- probably don't have source files.++        ml_hi_file   :: FilePath,+                -- Where the .hi file is, whether or not it exists+                -- yet.  Always of form foo.hi, even if there is an+                -- hi-boot file (we add the -boot suffix later)++        ml_obj_file  :: FilePath,+                -- Where the .o file is, whether or not it exists yet.+                -- (might not exist either because the module hasn't+                -- been compiled yet, or because it is part of a+                -- package with a .a file)+        ml_hie_file  :: FilePath+  } deriving Show++instance Outputable ModLocation where+   ppr = text . show++{-+For a module in another package, the hs_file and obj_file+components of ModLocation are undefined.++The locations specified by a ModLocation may or may not+correspond to actual files yet: for example, even if the object+file doesn't exist, the ModLocation still contains the path to+where the object file will reside if/when it is created.+-}++addBootSuffix :: FilePath -> FilePath+-- ^ Add the @-boot@ suffix to .hs, .hi and .o files+addBootSuffix path = path ++ "-boot"++addBootSuffix_maybe :: Bool -> FilePath -> FilePath+-- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@+addBootSuffix_maybe is_boot path+ | is_boot   = addBootSuffix path+ | otherwise = path++addBootSuffixLocn :: ModLocation -> ModLocation+-- ^ Add the @-boot@ suffix to all file paths associated with the module+addBootSuffixLocn locn+  = locn { ml_hs_file  = fmap addBootSuffix (ml_hs_file locn)+         , ml_hi_file  = addBootSuffix (ml_hi_file locn)+         , ml_obj_file = addBootSuffix (ml_obj_file locn)+         , ml_hie_file = addBootSuffix (ml_hie_file locn) }++addBootSuffixLocnOut :: ModLocation -> ModLocation+-- ^ Add the @-boot@ suffix to all output file paths associated with the+-- module, not including the input file itself+addBootSuffixLocnOut locn+  = locn { ml_hi_file  = addBootSuffix (ml_hi_file locn)+         , ml_obj_file = addBootSuffix (ml_obj_file locn)+         , ml_hie_file = addBootSuffix (ml_hie_file locn) }++{-+************************************************************************+*                                                                      *+\subsection{The name of a module}+*                                                                      *+************************************************************************+-}++-- | A ModuleName is essentially a simple string, e.g. @Data.List@.+newtype ModuleName = ModuleName FastString++instance Uniquable ModuleName where+  getUnique (ModuleName nm) = getUnique nm++instance Eq ModuleName where+  nm1 == nm2 = getUnique nm1 == getUnique nm2++instance Ord ModuleName where+  nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2++instance Outputable ModuleName where+  ppr = pprModuleName++instance Binary ModuleName where+  put_ bh (ModuleName fs) = put_ bh fs+  get bh = do fs <- get bh; return (ModuleName fs)++instance BinaryStringRep ModuleName where+  fromStringRep = mkModuleNameFS . mkFastStringByteString+  toStringRep   = bytesFS . moduleNameFS++instance Data ModuleName where+  -- don't traverse?+  toConstr _   = abstractConstr "ModuleName"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "ModuleName"++instance NFData ModuleName where+  rnf x = x `seq` ()++stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering+-- ^ Compares module names lexically, rather than by their 'Unique's+stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2++pprModuleName :: ModuleName -> SDoc+pprModuleName (ModuleName nm) =+    getPprStyle $ \ sty ->+    if codeStyle sty+        then ztext (zEncodeFS nm)+        else ftext nm++moduleNameFS :: ModuleName -> FastString+moduleNameFS (ModuleName mod) = mod++moduleNameString :: ModuleName -> String+moduleNameString (ModuleName mod) = unpackFS mod++-- | Get a string representation of a 'Module' that's unique and stable+-- across recompilations.+-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal"+moduleStableString :: Module -> String+moduleStableString Module{..} =+  "$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName++mkModuleName :: String -> ModuleName+mkModuleName s = ModuleName (mkFastString s)++mkModuleNameFS :: FastString -> ModuleName+mkModuleNameFS s = ModuleName s++-- |Returns the string version of the module name, with dots replaced by slashes.+--+moduleNameSlashes :: ModuleName -> String+moduleNameSlashes = dots_to_slashes . moduleNameString+  where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)++-- |Returns the string version of the module name, with dots replaced by colons.+--+moduleNameColons :: ModuleName -> String+moduleNameColons = dots_to_colons . moduleNameString+  where dots_to_colons = map (\c -> if c == '.' then ':' else c)++{-+************************************************************************+*                                                                      *+\subsection{A fully qualified module}+*                                                                      *+************************************************************************+-}++-- | A Module is a pair of a 'UnitId' and a 'ModuleName'.+--+-- Module variables (i.e. @<H>@) which can be instantiated to a+-- specific module at some later point in time are represented+-- with 'moduleUnitId' set to 'holeUnitId' (this allows us to+-- avoid having to make 'moduleUnitId' a partial operation.)+--+data Module = Module {+   moduleUnitId :: !UnitId,  -- pkg-1.0+   moduleName :: !ModuleName  -- A.B.C+  }+  deriving (Eq, Ord)++-- | Calculate the free holes of a 'Module'.  If this set is non-empty,+-- this module was defined in an indefinite library that had required+-- signatures.+--+-- If a module has free holes, that means that substitutions can operate on it;+-- if it has no free holes, substituting over a module has no effect.+moduleFreeHoles :: Module -> UniqDSet ModuleName+moduleFreeHoles m+    | isHoleModule m = unitUniqDSet (moduleName m)+    | otherwise = unitIdFreeHoles (moduleUnitId m)++-- | A 'Module' is definite if it has no free holes.+moduleIsDefinite :: Module -> Bool+moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles++-- | Create a module variable at some 'ModuleName'.+-- See Note [Representation of module/name variables]+mkHoleModule :: ModuleName -> Module+mkHoleModule = mkModule holeUnitId++instance Uniquable Module where+  getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n)++instance Outputable Module where+  ppr = pprModule++instance Binary Module where+  put_ bh (Module p n) = put_ bh p >> put_ bh n+  get bh = do p <- get bh; n <- get bh; return (Module p n)++instance Data Module where+  -- don't traverse?+  toConstr _   = abstractConstr "Module"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "Module"++instance NFData Module where+  rnf x = x `seq` ()++-- | This gives a stable ordering, as opposed to the Ord instance which+-- gives an ordering based on the 'Unique's of the components, which may+-- not be stable from run to run of the compiler.+stableModuleCmp :: Module -> Module -> Ordering+stableModuleCmp (Module p1 n1) (Module p2 n2)+   = (p1 `stableUnitIdCmp`  p2) `thenCmp`+     (n1 `stableModuleNameCmp` n2)++mkModule :: UnitId -> ModuleName -> Module+mkModule = Module++pprModule :: Module -> SDoc+pprModule mod@(Module p n)  = getPprStyle doc+ where+  doc sty+    | codeStyle sty =+        (if p == mainUnitId+                then empty -- never qualify the main package in code+                else ztext (zEncodeFS (unitIdFS p)) <> char '_')+            <> pprModuleName n+    | qualModule sty mod =+        if isHoleModule mod+            then angleBrackets (pprModuleName n)+            else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n+    | otherwise =+        pprModuleName n++class ContainsModule t where+    extractModule :: t -> Module++class HasModule m where+    getModule :: m Module++instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where+  fromDbModule (DbModule uid mod_name)  = mkModule uid mod_name+  fromDbModule (DbModuleVar mod_name)   = mkHoleModule mod_name+  fromDbUnitId (DbUnitId cid insts)     = newUnitId cid insts+  fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid)+  -- GHC never writes to the database, so it's not needed+  toDbModule = error "toDbModule: not implemented"+  toDbUnitId = error "toDbUnitId: not implemented"++{-+************************************************************************+*                                                                      *+\subsection{ComponentId}+*                                                                      *+************************************************************************+-}++-- | A 'ComponentId' consists of the package name, package version, component+-- ID, the transitive dependencies of the component, and other information to+-- uniquely identify the source code and build configuration of a component.+--+-- This used to be known as an 'InstalledPackageId', but a package can contain+-- multiple components and a 'ComponentId' uniquely identifies a component+-- within a package.  When a package only has one component, the 'ComponentId'+-- coincides with the 'InstalledPackageId'+data ComponentId = ComponentId+   { componentIdRaw     :: FastString             -- ^ Raw+   , componentIdDetails :: Maybe ComponentDetails -- ^ Cache of component details retrieved from the DB+   }++instance Eq ComponentId where+   a == b = componentIdRaw a == componentIdRaw b++instance Ord ComponentId where+   compare a b = compare (componentIdRaw a) (componentIdRaw b)++data ComponentDetails = ComponentDetails+   { componentPackageName    :: String+   , componentPackageVersion :: Version+   , componentName           :: Maybe String+   , componentSourcePkdId    :: String+   }++instance BinaryStringRep ComponentId where+  fromStringRep bs = ComponentId (mkFastStringByteString bs) Nothing+  toStringRep (ComponentId s _) = bytesFS s++instance Uniquable ComponentId where+  getUnique (ComponentId n _) = getUnique n++instance Outputable ComponentId where+  ppr cid@(ComponentId fs _) =+    getPprStyle $ \sty ->+      if debugStyle sty+         then ftext fs+         else text (componentIdString cid)++++{-+************************************************************************+*                                                                      *+\subsection{UnitId}+*                                                                      *+************************************************************************+-}++-- | A unit identifier identifies a (possibly partially) instantiated+-- library.  It is primarily used as part of 'Module', which in turn+-- is used in 'Name', which is used to give names to entities when+-- typechecking.+--+-- There are two possible forms for a 'UnitId'.  It can be a+-- 'DefiniteUnitId', in which case we just have a string that uniquely+-- identifies some fully compiled, installed library we have on disk.+-- However, when we are typechecking a library with missing holes,+-- we may need to instantiate a library on the fly (in which case+-- we don't have any on-disk representation.)  In that case, you+-- have an 'IndefiniteUnitId', which explicitly records the+-- instantiation, so that we can substitute over it.+data UnitId+    = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId+    |   DefiniteUnitId {-# UNPACK #-} !DefUnitId++unitIdFS :: UnitId -> FastString+unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x+unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x++unitIdKey :: UnitId -> Unique+unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x+unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x++-- | A unit identifier which identifies an indefinite+-- library (with holes) that has been *on-the-fly* instantiated+-- with a substitution 'indefUnitIdInsts'.  In fact, an indefinite+-- unit identifier could have no holes, but we haven't gotten+-- around to compiling the actual library yet.+--+-- An indefinite unit identifier pretty-prints to something like+-- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the+-- brackets enclose the module substitution).+data IndefUnitId+    = IndefUnitId {+        -- | A private, uniquely identifying representation of+        -- a UnitId.  This string is completely private to GHC+        -- and is just used to get a unique; in particular, we don't use it for+        -- symbols (indefinite libraries are not compiled).+        indefUnitIdFS :: FastString,+        -- | Cached unique of 'unitIdFS'.+        indefUnitIdKey :: Unique,+        -- | The component identity of the indefinite library that+        -- is being instantiated.+        indefUnitIdComponentId :: !ComponentId,+        -- | The sorted (by 'ModuleName') instantiations of this library.+        indefUnitIdInsts :: ![(ModuleName, Module)],+        -- | A cache of the free module variables of 'unitIdInsts'.+        -- This lets us efficiently tell if a 'UnitId' has been+        -- fully instantiated (free module variables are empty)+        -- and whether or not a substitution can have any effect.+        indefUnitIdFreeHoles :: UniqDSet ModuleName+    }++instance Eq IndefUnitId where+  u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2++instance Ord IndefUnitId where+  u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2++instance Binary IndefUnitId where+  put_ bh indef = do+    put_ bh (indefUnitIdComponentId indef)+    put_ bh (indefUnitIdInsts indef)+  get bh = do+    cid   <- get bh+    insts <- get bh+    let fs = hashUnitId cid insts+    return IndefUnitId {+            indefUnitIdComponentId = cid,+            indefUnitIdInsts = insts,+            indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),+            indefUnitIdFS = fs,+            indefUnitIdKey = getUnique fs+           }++-- | Create a new 'IndefUnitId' given an explicit module substitution.+newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId+newIndefUnitId cid insts =+    IndefUnitId {+        indefUnitIdComponentId = cid,+        indefUnitIdInsts = sorted_insts,+        indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),+        indefUnitIdFS = fs,+        indefUnitIdKey = getUnique fs+    }+  where+     fs = hashUnitId cid sorted_insts+     sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts++-- | Injects an 'IndefUnitId' (indefinite library which+-- was on-the-fly instantiated) to a 'UnitId' (either+-- an indefinite or definite library).+indefUnitIdToUnitId :: DynFlags -> IndefUnitId -> UnitId+indefUnitIdToUnitId dflags iuid =+    -- NB: suppose that we want to compare the indefinite+    -- unit id p[H=impl:H] against p+abcd (where p+abcd+    -- happens to be the existing, installed version of+    -- p[H=impl:H].  If we *only* wrap in p[H=impl:H]+    -- IndefiniteUnitId, they won't compare equal; only+    -- after improvement will the equality hold.+    improveUnitId (getUnitInfoMap dflags) $+        IndefiniteUnitId iuid++data IndefModule = IndefModule {+        indefModuleUnitId :: IndefUnitId,+        indefModuleName   :: ModuleName+    } deriving (Eq, Ord)++instance Outputable IndefModule where+  ppr (IndefModule uid m) =+    ppr uid <> char ':' <> ppr m++-- | Injects an 'IndefModule' to 'Module' (see also+-- 'indefUnitIdToUnitId'.+indefModuleToModule :: DynFlags -> IndefModule -> Module+indefModuleToModule dflags (IndefModule iuid mod_name) =+    mkModule (indefUnitIdToUnitId dflags iuid) mod_name++-- | An installed unit identifier identifies a library which has+-- been installed to the package database.  These strings are+-- provided to us via the @-this-unit-id@ flag.  The library+-- in question may be definite or indefinite; if it is indefinite,+-- none of the holes have been filled (we never install partially+-- instantiated libraries.)  Put another way, an installed unit id+-- is either fully instantiated, or not instantiated at all.+--+-- Installed unit identifiers look something like @p+af23SAj2dZ219@,+-- or maybe just @p@ if they don't use Backpack.+newtype InstalledUnitId =+    InstalledUnitId {+      -- | The full hashed unit identifier, including the component id+      -- and the hash.+      installedUnitIdFS :: FastString+    }++instance Binary InstalledUnitId where+  put_ bh (InstalledUnitId fs) = put_ bh fs+  get bh = do fs <- get bh; return (InstalledUnitId fs)++instance BinaryStringRep InstalledUnitId where+  fromStringRep bs = InstalledUnitId (mkFastStringByteString bs)+  -- GHC doesn't write to database+  toStringRep   = error "BinaryStringRep InstalledUnitId: not implemented"++instance Eq InstalledUnitId where+    uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2++instance Ord InstalledUnitId where+    u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2++instance Uniquable InstalledUnitId where+    getUnique = installedUnitIdKey++instance Outputable InstalledUnitId where+    ppr uid@(InstalledUnitId fs) =+        getPprStyle $ \sty ->+        sdocWithDynFlags $ \dflags ->+          case displayInstalledUnitId (getPackageState dflags) uid of+            Just str | not (debugStyle sty) -> text str+            _ -> ftext fs++installedUnitIdKey :: InstalledUnitId -> Unique+installedUnitIdKey = getUnique . installedUnitIdFS++-- | Lossy conversion to the on-disk 'InstalledUnitId' for a component.+toInstalledUnitId :: UnitId -> InstalledUnitId+toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid+toInstalledUnitId (IndefiniteUnitId indef) =+    componentIdToInstalledUnitId (indefUnitIdComponentId indef)++installedUnitIdString :: InstalledUnitId -> String+installedUnitIdString = unpackFS . installedUnitIdFS++instance Outputable IndefUnitId where+    ppr uid =+      -- getPprStyle $ \sty ->+      ppr cid <>+        (if not (null insts) -- pprIf+          then+            brackets (hcat+                (punctuate comma $+                    [ ppr modname <> text "=" <> ppr m+                    | (modname, m) <- insts]))+          else empty)+     where+      cid   = indefUnitIdComponentId uid+      insts = indefUnitIdInsts uid++-- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'.+data InstalledModule = InstalledModule {+   installedModuleUnitId :: !InstalledUnitId,+   installedModuleName :: !ModuleName+  }+  deriving (Eq, Ord)++instance Outputable InstalledModule where+  ppr (InstalledModule p n) =+    ppr p <> char ':' <> pprModuleName n++fsToInstalledUnitId :: FastString -> InstalledUnitId+fsToInstalledUnitId fs = InstalledUnitId fs++componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId+componentIdToInstalledUnitId (ComponentId fs _) = fsToInstalledUnitId fs++stringToInstalledUnitId :: String -> InstalledUnitId+stringToInstalledUnitId = fsToInstalledUnitId . mkFastString++-- | Test if a 'Module' corresponds to a given 'InstalledModule',+-- modulo instantiation.+installedModuleEq :: InstalledModule -> Module -> Bool+installedModuleEq imod mod =+    fst (splitModuleInsts mod) == imod++-- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId',+-- modulo instantiation.+installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool+installedUnitIdEq iuid uid =+    fst (splitUnitIdInsts uid) == iuid++-- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that+-- it only refers to a definite library; i.e., one we have generated+-- code for.+newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId }+    deriving (Eq, Ord)++instance Outputable DefUnitId where+    ppr (DefUnitId uid) = ppr uid++instance Binary DefUnitId where+    put_ bh (DefUnitId uid) = put_ bh uid+    get bh = do uid <- get bh; return (DefUnitId uid)++-- | A map keyed off of 'InstalledModule'+newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt)++emptyInstalledModuleEnv :: InstalledModuleEnv a+emptyInstalledModuleEnv = InstalledModuleEnv Map.empty++lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a+lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e++extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a+extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e)++filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a+filterInstalledModuleEnv f (InstalledModuleEnv e) =+  InstalledModuleEnv (Map.filterWithKey f e)++delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a+delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e)++-- Note [UnitId to InstalledUnitId improvement]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Just because a UnitId is definite (has no holes) doesn't+-- mean it's necessarily a InstalledUnitId; it could just be+-- that over the course of renaming UnitIds on the fly+-- while typechecking an indefinite library, we+-- ended up with a fully instantiated unit id with no hash,+-- since we haven't built it yet.  This is fine.+--+-- However, if there is a hashed unit id for this instantiation+-- in the package database, we *better use it*, because+-- that hashed unit id may be lurking in another interface,+-- and chaos will ensue if we attempt to compare the two+-- (the unitIdFS for a UnitId never corresponds to a Cabal-provided+-- hash of a compiled instantiated library).+--+-- There is one last niggle: improvement based on the package database means+-- that we might end up developing on a package that is not transitively+-- depended upon by the packages the user specified directly via command line+-- flags.  This could lead to strange and difficult to understand bugs if those+-- instantiations are out of date.  The solution is to only improve a+-- unit id if the new unit id is part of the 'preloadClosure'; i.e., the+-- closure of all the packages which were explicitly specified.++-- | Retrieve the set of free holes of a 'UnitId'.+unitIdFreeHoles :: UnitId -> UniqDSet ModuleName+unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x+-- Hashed unit ids are always fully instantiated+unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet++instance Show UnitId where+    show = unitIdString++-- | A 'UnitId' is definite if it has no free holes.+unitIdIsDefinite :: UnitId -> Bool+unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles++-- | Generate a uniquely identifying 'FastString' for a unit+-- identifier.  This is a one-way function.  You can rely on one special+-- property: if a unit identifier is in most general form, its 'FastString'+-- coincides with its 'ComponentId'.  This hash is completely internal+-- to GHC and is not used for symbol names or file paths.+hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString+hashUnitId cid sorted_holes =+    mkFastStringByteString+  . fingerprintUnitId (toStringRep cid)+  $ rawHashUnitId sorted_holes++-- | Generate a hash for a sorted module substitution.+rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint+rawHashUnitId sorted_holes =+    fingerprintByteString+  . BS.concat $ do+        (m, b) <- sorted_holes+        [ toStringRep m,                BS.Char8.singleton ' ',+          bytesFS (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':',+          toStringRep (moduleName b),   BS.Char8.singleton '\n']++fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString+fingerprintUnitId prefix (Fingerprint a b)+    = BS.concat+    $ [ prefix+      , BS.Char8.singleton '-'+      , BS.Char8.pack (toBase62Padded a)+      , BS.Char8.pack (toBase62Padded b) ]++-- | Create a new, un-hashed unit identifier.+newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId+newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug...+newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts++pprUnitId :: UnitId -> SDoc+pprUnitId (DefiniteUnitId uid) = ppr uid+pprUnitId (IndefiniteUnitId uid) = ppr uid++instance Eq UnitId where+  uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2++instance Uniquable UnitId where+  getUnique = unitIdKey++instance Ord UnitId where+  nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2++instance Data UnitId where+  -- don't traverse?+  toConstr _   = abstractConstr "UnitId"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "UnitId"++instance NFData UnitId where+  rnf x = x `seq` ()++stableUnitIdCmp :: UnitId -> UnitId -> Ordering+-- ^ Compares package ids lexically, rather than by their 'Unique's+stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2++instance Outputable UnitId where+   ppr pk = pprUnitId pk++-- Performance: would prefer to have a NameCache like thing+instance Binary UnitId where+  put_ bh (DefiniteUnitId def_uid) = do+    putByte bh 0+    put_ bh def_uid+  put_ bh (IndefiniteUnitId indef_uid) = do+    putByte bh 1+    put_ bh indef_uid+  get bh = do b <- getByte bh+              case b of+                0 -> fmap DefiniteUnitId   (get bh)+                _ -> fmap IndefiniteUnitId (get bh)++instance Binary ComponentId where+  put_ bh (ComponentId fs _) = put_ bh fs+  get bh = do { fs <- get bh; return (ComponentId fs Nothing) }++-- | Create a new simple unit identifier (no holes) from a 'ComponentId'.+newSimpleUnitId :: ComponentId -> UnitId+newSimpleUnitId (ComponentId fs _) = fsToUnitId fs++-- | Create a new simple unit identifier from a 'FastString'.  Internally,+-- this is primarily used to specify wired-in unit identifiers.+fsToUnitId :: FastString -> UnitId+fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId++stringToUnitId :: String -> UnitId+stringToUnitId = fsToUnitId . mkFastString++unitIdString :: UnitId -> String+unitIdString = unpackFS . unitIdFS++{-+************************************************************************+*                                                                      *+                        Hole substitutions+*                                                                      *+************************************************************************+-}++-- | Substitution on module variables, mapping module names to module+-- identifiers.+type ShHoleSubst = ModuleNameEnv Module++-- | Substitutes holes in a 'Module'.  NOT suitable for being called+-- directly on a 'nameModule', see Note [Representation of module/name variable].+-- @p[A=<A>]:B@ maps to @p[A=q():A]:B@ with @A=q():A@;+-- similarly, @<A>@ maps to @q():A@.+renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module+renameHoleModule dflags = renameHoleModule' (getUnitInfoMap dflags)++-- | Substitutes holes in a 'UnitId', suitable for renaming when+-- an include occurs; see Note [Representation of module/name variable].+--+-- @p[A=<A>]@ maps to @p[A=<B>]@ with @A=<B>@.+renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId+renameHoleUnitId dflags = renameHoleUnitId' (getUnitInfoMap dflags)++-- | Like 'renameHoleModule', but requires only 'UnitInfoMap'+-- so it can be used by "Packages".+renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module+renameHoleModule' pkg_map env m+  | not (isHoleModule m) =+        let uid = renameHoleUnitId' pkg_map env (moduleUnitId m)+        in mkModule uid (moduleName m)+  | Just m' <- lookupUFM env (moduleName m) = m'+  -- NB m = <Blah>, that's what's in scope.+  | otherwise = m++-- | Like 'renameHoleUnitId, but requires only 'UnitInfoMap'+-- so it can be used by "Packages".+renameHoleUnitId' :: UnitInfoMap -> ShHoleSubst -> UnitId -> UnitId+renameHoleUnitId' pkg_map env uid =+    case uid of+      (IndefiniteUnitId+        IndefUnitId{ indefUnitIdComponentId = cid+                   , indefUnitIdInsts       = insts+                   , indefUnitIdFreeHoles   = fh })+          -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env)+                then uid+                -- Functorially apply the substitution to the instantiation,+                -- then check the 'UnitInfoMap' to see if there is+                -- a compiled version of this 'UnitId' we can improve to.+                -- See Note [UnitId to InstalledUnitId] improvement+                else improveUnitId pkg_map $+                        newUnitId cid+                            (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts)+      _ -> uid++-- | Given a possibly on-the-fly instantiated module, split it into+-- a 'Module' that we definitely can find on-disk, as well as an+-- instantiation if we need to instantiate it on the fly.  If the+-- instantiation is @Nothing@ no on-the-fly renaming is needed.+splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule)+splitModuleInsts m =+    let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m)+    in (InstalledModule uid (moduleName m),+        fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid)++-- | See 'splitModuleInsts'.+splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId)+splitUnitIdInsts (IndefiniteUnitId iuid) =+    (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid)+splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing)++generalizeIndefUnitId :: IndefUnitId -> IndefUnitId+generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid+                                 , indefUnitIdInsts = insts } =+    newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts)++generalizeIndefModule :: IndefModule -> IndefModule+generalizeIndefModule (IndefModule uid n) = IndefModule (generalizeIndefUnitId uid) n++parseModuleName :: ReadP ModuleName+parseModuleName = fmap mkModuleName+                $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.")++parseUnitId :: ReadP UnitId+parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId+  where+    parseFullUnitId = do+        cid <- parseComponentId+        insts <- parseModSubst+        return (newUnitId cid insts)+    parseDefiniteUnitId = do+        s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+")+        return (stringToUnitId s)+    parseSimpleUnitId = do+        cid <- parseComponentId+        return (newSimpleUnitId cid)++parseComponentId :: ReadP ComponentId+parseComponentId = (flip ComponentId Nothing . mkFastString)  `fmap` Parse.munch1 abi_char+   where abi_char c = isAlphaNum c || c `elem` "-_."++parseModuleId :: ReadP Module+parseModuleId = parseModuleVar <++ parseModule+    where+      parseModuleVar = do+        _ <- Parse.char '<'+        modname <- parseModuleName+        _ <- Parse.char '>'+        return (mkHoleModule modname)+      parseModule = do+        uid <- parseUnitId+        _ <- Parse.char ':'+        modname <- parseModuleName+        return (mkModule uid modname)++parseModSubst :: ReadP [(ModuleName, Module)]+parseModSubst = Parse.between (Parse.char '[') (Parse.char ']')+      . flip Parse.sepBy (Parse.char ',')+      $ do k <- parseModuleName+           _ <- Parse.char '='+           v <- parseModuleId+           return (k, v)+++{-+Note [Wired-in packages]+~~~~~~~~~~~~~~~~~~~~~~~~++Certain packages are known to the compiler, in that we know about certain+entities that reside in these packages, and the compiler needs to+declare static Modules and Names that refer to these packages.  Hence+the wired-in packages can't include version numbers in their package UnitId,+since we don't want to bake the version numbers of these packages into GHC.++So here's the plan.  Wired-in packages are still versioned as+normal in the packages database, and you can still have multiple+versions of them installed. To the user, everything looks normal.++However, for each invocation of GHC, only a single instance of each wired-in+package will be recognised (the desired one is selected via+@-package@\/@-hide-package@), and GHC will internally pretend that it has the+*unversioned* 'UnitId', including in .hi files and object file symbols.++Unselected versions of wired-in packages will be ignored, as will any other+package that depends directly or indirectly on it (much as if you+had used @-ignore-package@).++The affected packages are compiled with, e.g., @-this-unit-id base@, so that+the symbols in the object files have the unversioned unit id in their name.++Make sure you change 'Packages.findWiredInPackages' if you add an entry here.++For `integer-gmp`/`integer-simple` we also change the base name to+`integer-wired-in`, but this is fundamentally no different.+See Note [The integer library] in PrelNames.+-}++integerUnitId, primUnitId,+  baseUnitId, rtsUnitId,+  thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId  :: UnitId+primUnitId        = fsToUnitId (fsLit "ghc-prim")+integerUnitId     = fsToUnitId (fsLit "integer-wired-in")+   -- See Note [The integer library] in PrelNames+baseUnitId        = fsToUnitId (fsLit "base")+rtsUnitId         = fsToUnitId (fsLit "rts")+thUnitId          = fsToUnitId (fsLit "template-haskell")+thisGhcUnitId     = fsToUnitId (fsLit "ghc")+interactiveUnitId = fsToUnitId (fsLit "interactive")++-- | This is the package Id for the current program.  It is the default+-- package Id if you don't specify a package name.  We don't add this prefix+-- to symbol names, since there can be only one main package per program.+mainUnitId      = fsToUnitId (fsLit "main")++-- | This is a fake package id used to provide identities to any un-implemented+-- signatures.  The set of hole identities is global over an entire compilation.+-- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead.+-- See Note [Representation of module/name variables]+holeUnitId :: UnitId+holeUnitId      = fsToUnitId (fsLit "hole")++isInteractiveModule :: Module -> Bool+isInteractiveModule mod = moduleUnitId mod == interactiveUnitId++-- Note [Representation of module/name variables]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- In our ICFP'16, we use <A> to represent module holes, and {A.T} to represent+-- name holes.  This could have been represented by adding some new cases+-- to the core data types, but this would have made the existing 'nameModule'+-- and 'moduleUnitId' partial, which would have required a lot of modifications+-- to existing code.+--+-- Instead, we adopted the following encoding scheme:+--+--      <A>   ===> hole:A+--      {A.T} ===> hole:A.T+--+-- This encoding is quite convenient, but it is also a bit dangerous too,+-- because if you have a 'hole:A' you need to know if it's actually a+-- 'Module' or just a module stored in a 'Name'; these two cases must be+-- treated differently when doing substitutions.  'renameHoleModule'+-- and 'renameHoleUnitId' assume they are NOT operating on a+-- 'Name'; 'NameShape' handles name substitutions exclusively.++isHoleModule :: Module -> Bool+isHoleModule mod = moduleUnitId mod == holeUnitId++wiredInUnitIds :: [UnitId]+wiredInUnitIds = [ primUnitId,+                       integerUnitId,+                       baseUnitId,+                       rtsUnitId,+                       thUnitId,+                       thisGhcUnitId ]++{-+************************************************************************+*                                                                      *+\subsection{@ModuleEnv@s}+*                                                                      *+************************************************************************+-}++-- | A map keyed off of 'Module's+newtype ModuleEnv elt = ModuleEnv (Map NDModule elt)++{-+Note [ModuleEnv performance and determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To prevent accidental reintroduction of nondeterminism the Ord instance+for Module was changed to not depend on Unique ordering and to use the+lexicographic order. This is potentially expensive, but when measured+there was no difference in performance.++To be on the safe side and not pessimize ModuleEnv uses nondeterministic+ordering on Module and normalizes by doing the lexicographic sort when+turning the env to a list.+See Note [Unique Determinism] for more information about the source of+nondeterminismand and Note [Deterministic UniqFM] for explanation of why+it matters for maps.+-}++newtype NDModule = NDModule { unNDModule :: Module }+  deriving Eq+  -- A wrapper for Module with faster nondeterministic Ord.+  -- Don't export, See [ModuleEnv performance and determinism]++instance Ord NDModule where+  compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) =+    (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp`+    (getUnique n1 `nonDetCmpUnique` getUnique n2)++filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a+filterModuleEnv f (ModuleEnv e) =+  ModuleEnv (Map.filterWithKey (f . unNDModule) e)++elemModuleEnv :: Module -> ModuleEnv a -> Bool+elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e++extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a+extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e)++extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a+                    -> ModuleEnv a+extendModuleEnvWith f (ModuleEnv e) m x =+  ModuleEnv (Map.insertWith f (NDModule m) x e)++extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a+extendModuleEnvList (ModuleEnv e) xs =+  ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e)++extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)]+                      -> ModuleEnv a+extendModuleEnvList_C f (ModuleEnv e) xs =+  ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e)++plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a+plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) =+  ModuleEnv (Map.unionWith f e1 e2)++delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a+delModuleEnvList (ModuleEnv e) ms =+  ModuleEnv (Map.deleteList (map NDModule ms) e)++delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a+delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e)++plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a+plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2)++lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a+lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e++lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a+lookupWithDefaultModuleEnv (ModuleEnv e) x m =+  Map.findWithDefault x (NDModule m) e++mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b+mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e)++mkModuleEnv :: [(Module, a)] -> ModuleEnv a+mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs])++emptyModuleEnv :: ModuleEnv a+emptyModuleEnv = ModuleEnv Map.empty++moduleEnvKeys :: ModuleEnv a -> [Module]+moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e+  -- See Note [ModuleEnv performance and determinism]++moduleEnvElts :: ModuleEnv a -> [a]+moduleEnvElts e = map snd $ moduleEnvToList e+  -- See Note [ModuleEnv performance and determinism]++moduleEnvToList :: ModuleEnv a -> [(Module, a)]+moduleEnvToList (ModuleEnv e) =+  sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e]+  -- See Note [ModuleEnv performance and determinism]++unitModuleEnv :: Module -> a -> ModuleEnv a+unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x)++isEmptyModuleEnv :: ModuleEnv a -> Bool+isEmptyModuleEnv (ModuleEnv e) = Map.null e++-- | A set of 'Module's+type ModuleSet = Set NDModule++mkModuleSet :: [Module] -> ModuleSet+mkModuleSet = Set.fromList . coerce++extendModuleSet :: ModuleSet -> Module -> ModuleSet+extendModuleSet s m = Set.insert (NDModule m) s++extendModuleSetList :: ModuleSet -> [Module] -> ModuleSet+extendModuleSetList s ms = foldl' (coerce . flip Set.insert) s ms++emptyModuleSet :: ModuleSet+emptyModuleSet = Set.empty++moduleSetElts :: ModuleSet -> [Module]+moduleSetElts = sort . coerce . Set.toList++elemModuleSet :: Module -> ModuleSet -> Bool+elemModuleSet = Set.member . coerce++intersectModuleSet :: ModuleSet -> ModuleSet -> ModuleSet+intersectModuleSet = coerce Set.intersection++minusModuleSet :: ModuleSet -> ModuleSet -> ModuleSet+minusModuleSet = coerce Set.difference++delModuleSet :: ModuleSet -> Module -> ModuleSet+delModuleSet = coerce (flip Set.delete)++unionModuleSet :: ModuleSet -> ModuleSet -> ModuleSet+unionModuleSet = coerce Set.union++unitModuleSet :: Module -> ModuleSet+unitModuleSet = coerce Set.singleton++{-+A ModuleName has a Unique, so we can build mappings of these using+UniqFM.+-}++-- | A map keyed off of 'ModuleName's (actually, their 'Unique's)+type ModuleNameEnv elt = UniqFM elt+++-- | A map keyed off of 'ModuleName's (actually, their 'Unique's)+-- Has deterministic folds and can be deterministically converted to a list+type DModuleNameEnv elt = UniqDFM elt
+ compiler/GHC/Types/Module.hs-boot view
@@ -0,0 +1,13 @@+module GHC.Types.Module where++import GhcPrelude++data Module+data ModuleName+data UnitId+data InstalledUnitId+data ComponentId++moduleName :: Module -> ModuleName+moduleUnitId :: Module -> UnitId+unitIdString :: UnitId -> String
+ compiler/GHC/Types/Name.hs view
@@ -0,0 +1,693 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[Name]{@Name@: to transmit name info from renamer to typechecker}+-}++{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms #-}++-- |+-- #name_types#+-- GHC uses several kinds of name internally:+--+-- * 'OccName.OccName': see "OccName#name_types"+--+-- * 'RdrName.RdrName': see "RdrName#name_types"+--+-- *  'Name.Name' is the type of names that have had their scoping and binding resolved. They+--   have an 'OccName.OccName' but also a 'Unique.Unique' that disambiguates Names that have+--   the same 'OccName.OccName' and indeed is used for all 'Name.Name' comparison. Names+--   also contain information about where they originated from, see "Name#name_sorts"+--+-- * 'Id.Id': see "Id#name_types"+--+-- * 'Var.Var': see "Var#name_types"+--+-- #name_sorts#+-- Names are one of:+--+--  * External, if they name things declared in other modules. Some external+--    Names are wired in, i.e. they name primitives defined in the compiler itself+--+--  * Internal, if they name things in the module being compiled. Some internal+--    Names are system names, if they are names manufactured by the compiler++module GHC.Types.Name (+        -- * The main types+        Name,                                   -- Abstract+        BuiltInSyntax(..),++        -- ** Creating 'Name's+        mkSystemName, mkSystemNameAt,+        mkInternalName, mkClonedInternalName, mkDerivedInternalName,+        mkSystemVarName, mkSysTvName,+        mkFCallName,+        mkExternalName, mkWiredInName,++        -- ** Manipulating and deconstructing 'Name's+        nameUnique, setNameUnique,+        nameOccName, nameNameSpace, nameModule, nameModule_maybe,+        setNameLoc,+        tidyNameOcc,+        localiseName,++        nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt,++        -- ** Predicates on 'Name's+        isSystemName, isInternalName, isExternalName,+        isTyVarName, isTyConName, isDataConName,+        isValName, isVarName,+        isWiredInName, isWiredIn, isBuiltInSyntax,+        isHoleName,+        wiredInNameTyThing_maybe,+        nameIsLocalOrFrom, nameIsHomePackage,+        nameIsHomePackageImport, nameIsFromExternalPackage,+        stableNameCmp,++        -- * Class 'NamedThing' and overloaded friends+        NamedThing(..),+        getSrcLoc, getSrcSpan, getOccString, getOccFS,++        pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified,+        nameStableString,++        -- Re-export the OccName stuff+        module GHC.Types.Name.Occurrence+    ) where++import GhcPrelude++import {-# SOURCE #-} GHC.Core.TyCo.Rep( TyThing )++import GHC.Types.Name.Occurrence+import GHC.Types.Module+import GHC.Types.SrcLoc+import GHC.Types.Unique+import Util+import Maybes+import Binary+import FastString+import Outputable++import Control.DeepSeq+import Data.Data++{-+************************************************************************+*                                                                      *+\subsection[Name-datatype]{The @Name@ datatype, and name construction}+*                                                                      *+************************************************************************+-}++-- | A unique, unambiguous name for something, containing information about where+-- that thing originated.+data Name = Name {+                n_sort :: NameSort,     -- What sort of name it is+                n_occ  :: !OccName,     -- Its occurrence name+                n_uniq :: {-# UNPACK #-} !Unique,+                n_loc  :: !SrcSpan      -- Definition site+            }++-- NOTE: we make the n_loc field strict to eliminate some potential+-- (and real!) space leaks, due to the fact that we don't look at+-- the SrcLoc in a Name all that often.++-- See Note [About the NameSorts]+data NameSort+  = External Module++  | WiredIn Module TyThing BuiltInSyntax+        -- A variant of External, for wired-in things++  | Internal            -- A user-defined Id or TyVar+                        -- defined in the module being compiled++  | System              -- A system-defined Id or TyVar.  Typically the+                        -- OccName is very uninformative (like 's')++instance Outputable NameSort where+  ppr (External _)    = text "external"+  ppr (WiredIn _ _ _) = text "wired-in"+  ppr  Internal       = text "internal"+  ppr  System         = text "system"++instance NFData Name where+  rnf Name{..} = rnf n_sort++instance NFData NameSort where+  rnf (External m) = rnf m+  rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` ()+    -- XXX this is a *lie*, we're not going to rnf the TyThing, but+    -- since the TyThings for WiredIn Names are all static they can't+    -- be hiding space leaks or errors.+  rnf Internal = ()+  rnf System = ()++-- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples,+-- which have special syntactic forms.  They aren't in scope+-- as such.+data BuiltInSyntax = BuiltInSyntax | UserSyntax++{-+Note [About the NameSorts]++1.  Initially, top-level Ids (including locally-defined ones) get External names,+    and all other local Ids get Internal names++2.  In any invocation of GHC, an External Name for "M.x" has one and only one+    unique.  This unique association is ensured via the Name Cache;+    see Note [The Name Cache] in GHC.Iface.Env.++3.  Things with a External name are given C static labels, so they finally+    appear in the .o file's symbol table.  They appear in the symbol table+    in the form M.n.  If originally-local things have this property they+    must be made @External@ first.++4.  In the tidy-core phase, a External that is not visible to an importer+    is changed to Internal, and a Internal that is visible is changed to External++5.  A System Name differs in the following ways:+        a) has unique attached when printing dumps+        b) unifier eliminates sys tyvars in favour of user provs where possible++    Before anything gets printed in interface files or output code, it's+    fed through a 'tidy' processor, which zaps the OccNames to have+    unique names; and converts all sys-locals to user locals+    If any desugarer sys-locals have survived that far, they get changed to+    "ds1", "ds2", etc.++Built-in syntax => It's a syntactic form, not "in scope" (e.g. [])++Wired-in thing  => The thing (Id, TyCon) is fully known to the compiler,+                   not read from an interface file.+                   E.g. Bool, True, Int, Float, and many others++All built-in syntax is for wired-in things.+-}++instance HasOccName Name where+  occName = nameOccName++nameUnique              :: Name -> Unique+nameOccName             :: Name -> OccName+nameNameSpace           :: Name -> NameSpace+nameModule              :: HasDebugCallStack => Name -> Module+nameSrcLoc              :: Name -> SrcLoc+nameSrcSpan             :: Name -> SrcSpan++nameUnique    name = n_uniq name+nameOccName   name = n_occ  name+nameNameSpace name = occNameSpace (n_occ name)+nameSrcLoc    name = srcSpanStart (n_loc name)+nameSrcSpan   name = n_loc  name++{-+************************************************************************+*                                                                      *+\subsection{Predicates on names}+*                                                                      *+************************************************************************+-}++isInternalName    :: Name -> Bool+isExternalName    :: Name -> Bool+isSystemName      :: Name -> Bool+isWiredInName     :: Name -> Bool++isWiredInName (Name {n_sort = WiredIn _ _ _}) = True+isWiredInName _                               = False++isWiredIn :: NamedThing thing => thing -> Bool+isWiredIn = isWiredInName . getName++wiredInNameTyThing_maybe :: Name -> Maybe TyThing+wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing+wiredInNameTyThing_maybe _                                   = Nothing++isBuiltInSyntax :: Name -> Bool+isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True+isBuiltInSyntax _                                           = False++isExternalName (Name {n_sort = External _})    = True+isExternalName (Name {n_sort = WiredIn _ _ _}) = True+isExternalName _                               = False++isInternalName name = not (isExternalName name)++isHoleName :: Name -> Bool+isHoleName = isHoleModule . nameModule++nameModule name =+  nameModule_maybe name `orElse`+  pprPanic "nameModule" (ppr (n_sort name) <+> ppr name)++nameModule_maybe :: Name -> Maybe Module+nameModule_maybe (Name { n_sort = External mod})    = Just mod+nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod+nameModule_maybe _                                  = Nothing++nameIsLocalOrFrom :: Module -> Name -> Bool+-- ^ Returns True if the name is+--   (a) Internal+--   (b) External but from the specified module+--   (c) External but from the 'interactive' package+--+-- The key idea is that+--    False means: the entity is defined in some other module+--                 you can find the details (type, fixity, instances)+--                     in some interface file+--                 those details will be stored in the EPT or HPT+--+--    True means:  the entity is defined in this module or earlier in+--                     the GHCi session+--                 you can find details (type, fixity, instances) in the+--                     TcGblEnv or TcLclEnv+--+-- The isInteractiveModule part is because successive interactions of a GHCi session+-- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come+-- from the magic 'interactive' package; and all the details are kept in the+-- TcLclEnv, TcGblEnv, NOT in the HPT or EPT.+-- See Note [The interactive package] in GHC.Driver.Types++nameIsLocalOrFrom from name+  | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod+  | otherwise                         = True++nameIsHomePackage :: Module -> Name -> Bool+-- True if the Name is defined in module of this package+nameIsHomePackage this_mod+  = \nm -> case n_sort nm of+              External nm_mod    -> moduleUnitId nm_mod == this_pkg+              WiredIn nm_mod _ _ -> moduleUnitId nm_mod == this_pkg+              Internal -> True+              System   -> False+  where+    this_pkg = moduleUnitId this_mod++nameIsHomePackageImport :: Module -> Name -> Bool+-- True if the Name is defined in module of this package+-- /other than/ the this_mod+nameIsHomePackageImport this_mod+  = \nm -> case nameModule_maybe nm of+              Nothing -> False+              Just nm_mod -> nm_mod /= this_mod+                          && moduleUnitId nm_mod == this_pkg+  where+    this_pkg = moduleUnitId this_mod++-- | Returns True if the Name comes from some other package: neither this+-- package nor the interactive package.+nameIsFromExternalPackage :: UnitId -> Name -> Bool+nameIsFromExternalPackage this_pkg name+  | Just mod <- nameModule_maybe name+  , moduleUnitId mod /= this_pkg    -- Not this package+  , not (isInteractiveModule mod)       -- Not the 'interactive' package+  = True+  | otherwise+  = False++isTyVarName :: Name -> Bool+isTyVarName name = isTvOcc (nameOccName name)++isTyConName :: Name -> Bool+isTyConName name = isTcOcc (nameOccName name)++isDataConName :: Name -> Bool+isDataConName name = isDataOcc (nameOccName name)++isValName :: Name -> Bool+isValName name = isValOcc (nameOccName name)++isVarName :: Name -> Bool+isVarName = isVarOcc . nameOccName++isSystemName (Name {n_sort = System}) = True+isSystemName _                        = False++{-+************************************************************************+*                                                                      *+\subsection{Making names}+*                                                                      *+************************************************************************+-}++-- | Create a name which is (for now at least) local to the current module and hence+-- does not need a 'Module' to disambiguate it from other 'Name's+mkInternalName :: Unique -> OccName -> SrcSpan -> Name+mkInternalName uniq occ loc = Name { n_uniq = uniq+                                   , n_sort = Internal+                                   , n_occ = occ+                                   , n_loc = loc }+        -- NB: You might worry that after lots of huffing and+        -- puffing we might end up with two local names with distinct+        -- uniques, but the same OccName.  Indeed we can, but that's ok+        --      * the insides of the compiler don't care: they use the Unique+        --      * when printing for -ddump-xxx you can switch on -dppr-debug to get the+        --        uniques if you get confused+        --      * for interface files we tidyCore first, which makes+        --        the OccNames distinct when they need to be++mkClonedInternalName :: Unique -> Name -> Name+mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc })+  = Name { n_uniq = uniq, n_sort = Internal+         , n_occ = occ, n_loc = loc }++mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name+mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc })+  = Name { n_uniq = uniq, n_sort = Internal+         , n_occ = derive_occ occ, n_loc = loc }++-- | Create a name which definitely originates in the given module+mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name+-- WATCH OUT! External Names should be in the Name Cache+-- (see Note [The Name Cache] in GHC.Iface.Env), so don't just call mkExternalName+-- with some fresh unique without populating the Name Cache+mkExternalName uniq mod occ loc+  = Name { n_uniq = uniq, n_sort = External mod,+           n_occ = occ, n_loc = loc }++-- | Create a name which is actually defined by the compiler itself+mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name+mkWiredInName mod occ uniq thing built_in+  = Name { n_uniq = uniq,+           n_sort = WiredIn mod thing built_in,+           n_occ = occ, n_loc = wiredInSrcSpan }++-- | Create a name brought into being by the compiler+mkSystemName :: Unique -> OccName -> Name+mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan++mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name+mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System+                                   , n_occ = occ, n_loc = loc }++mkSystemVarName :: Unique -> FastString -> Name+mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs)++mkSysTvName :: Unique -> FastString -> Name+mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs)++-- | Make a name for a foreign call+mkFCallName :: Unique -> String -> Name+mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan+   -- The encoded string completely describes the ccall++-- When we renumber/rename things, we need to be+-- able to change a Name's Unique to match the cached+-- one in the thing it's the name of.  If you know what I mean.+setNameUnique :: Name -> Unique -> Name+setNameUnique name uniq = name {n_uniq = uniq}++-- This is used for hsigs: we want to use the name of the originally exported+-- entity, but edit the location to refer to the reexport site+setNameLoc :: Name -> SrcSpan -> Name+setNameLoc name loc = name {n_loc = loc}++tidyNameOcc :: Name -> OccName -> Name+-- We set the OccName of a Name when tidying+-- In doing so, we change System --> Internal, so that when we print+-- it we don't get the unique by default.  It's tidy now!+tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal}+tidyNameOcc name                            occ = name { n_occ = occ }++-- | Make the 'Name' into an internal name, regardless of what it was to begin with+localiseName :: Name -> Name+localiseName n = n { n_sort = Internal }++{-+************************************************************************+*                                                                      *+\subsection{Hashing and comparison}+*                                                                      *+************************************************************************+-}++cmpName :: Name -> Name -> Ordering+cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2++-- | Compare Names lexicographically+-- This only works for Names that originate in the source code or have been+-- tidied.+stableNameCmp :: Name -> Name -> Ordering+stableNameCmp (Name { n_sort = s1, n_occ = occ1 })+              (Name { n_sort = s2, n_occ = occ2 })+  = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2)+    -- The ordinary compare on OccNames is lexicographic+  where+    -- Later constructors are bigger+    sort_cmp (External m1) (External m2)       = m1 `stableModuleCmp` m2+    sort_cmp (External {}) _                   = LT+    sort_cmp (WiredIn {}) (External {})        = GT+    sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2+    sort_cmp (WiredIn {})     _                = LT+    sort_cmp Internal         (External {})    = GT+    sort_cmp Internal         (WiredIn {})     = GT+    sort_cmp Internal         Internal         = EQ+    sort_cmp Internal         System           = LT+    sort_cmp System           System           = EQ+    sort_cmp System           _                = GT++{-+************************************************************************+*                                                                      *+\subsection[Name-instances]{Instance declarations}+*                                                                      *+************************************************************************+-}++-- | The same comments as for `Name`'s `Ord` instance apply.+instance Eq Name where+    a == b = case (a `compare` b) of { EQ -> True;  _ -> False }+    a /= b = case (a `compare` b) of { EQ -> False; _ -> True }++-- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which+-- means that the ordering is not stable across deserialization or rebuilds.+--+-- See `nonDetCmpUnique` for further information, and trac #15240 for a bug+-- caused by improper use of this instance.++-- For a deterministic lexicographic ordering, use `stableNameCmp`.+instance Ord Name where+    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }+    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }+    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }+    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }+    compare a b = cmpName a b++instance Uniquable Name where+    getUnique = nameUnique++instance NamedThing Name where+    getName n = n++instance Data Name where+  -- don't traverse?+  toConstr _   = abstractConstr "Name"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "Name"++{-+************************************************************************+*                                                                      *+\subsection{Binary}+*                                                                      *+************************************************************************+-}++-- | Assumes that the 'Name' is a non-binding one. See+-- 'GHC.Iface.Syntax.putIfaceTopBndr' and 'GHC.Iface.Syntax.getIfaceTopBndr' for+-- serializing binding 'Name's. See 'UserData' for the rationale for this+-- distinction.+instance Binary Name where+   put_ bh name =+      case getUserData bh of+        UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name++   get bh =+      case getUserData bh of+        UserData { ud_get_name = get_name } -> get_name bh++{-+************************************************************************+*                                                                      *+\subsection{Pretty printing}+*                                                                      *+************************************************************************+-}++instance Outputable Name where+    ppr name = pprName name++instance OutputableBndr Name where+    pprBndr _ name = pprName name+    pprInfixOcc  = pprInfixName+    pprPrefixOcc = pprPrefixName++pprName :: Name -> SDoc+pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ})+  = getPprStyle $ \ sty ->+    case sort of+      WiredIn mod _ builtin   -> pprExternal sty uniq mod occ True  builtin+      External mod            -> pprExternal sty uniq mod occ False UserSyntax+      System                  -> pprSystem sty uniq occ+      Internal                -> pprInternal sty uniq occ++-- | Print the string of Name unqualifiedly directly.+pprNameUnqualified :: Name -> SDoc+pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ++pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc+pprExternal sty uniq mod occ is_wired is_builtin+  | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ+        -- In code style, always qualify+        -- ToDo: maybe we could print all wired-in things unqualified+        --       in code style, to reduce symbol table bloat?+  | debugStyle sty = pp_mod <> ppr_occ_name occ+                     <> braces (hsep [if is_wired then text "(w)" else empty,+                                      pprNameSpaceBrief (occNameSpace occ),+                                      pprUnique uniq])+  | BuiltInSyntax <- is_builtin = ppr_occ_name occ  -- Never qualify builtin syntax+  | otherwise                   =+        if isHoleModule mod+            then case qualName sty mod occ of+                    NameUnqual -> ppr_occ_name occ+                    _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ)+            else pprModulePrefix sty mod occ <> ppr_occ_name occ+  where+    pp_mod = ppUnlessOption sdocSuppressModulePrefixes+               (ppr mod <> dot)++pprInternal :: PprStyle -> Unique -> OccName -> SDoc+pprInternal sty uniq occ+  | codeStyle sty  = pprUniqueAlways uniq+  | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ),+                                                       pprUnique uniq])+  | dumpStyle sty  = ppr_occ_name occ <> ppr_underscore_unique uniq+                        -- For debug dumps, we're not necessarily dumping+                        -- tidied code, so we need to print the uniques.+  | otherwise      = ppr_occ_name occ   -- User style++-- Like Internal, except that we only omit the unique in Iface style+pprSystem :: PprStyle -> Unique -> OccName -> SDoc+pprSystem sty uniq occ+  | codeStyle sty  = pprUniqueAlways uniq+  | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq+                     <> braces (pprNameSpaceBrief (occNameSpace occ))+  | otherwise      = ppr_occ_name occ <> ppr_underscore_unique uniq+                                -- If the tidy phase hasn't run, the OccName+                                -- is unlikely to be informative (like 's'),+                                -- so print the unique+++pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc+-- Print the "M." part of a name, based on whether it's in scope or not+-- See Note [Printing original names] in GHC.Driver.Types+pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $+    case qualName sty mod occ of              -- See Outputable.QualifyName:+      NameQual modname -> ppr modname <> dot       -- Name is in scope+      NameNotInScope1  -> ppr mod <> dot           -- Not in scope+      NameNotInScope2  -> ppr (moduleUnitId mod) <> colon     -- Module not in+                          <> ppr (moduleName mod) <> dot          -- scope either+      NameUnqual       -> empty                   -- In scope unqualified++pprUnique :: Unique -> SDoc+-- Print a unique unless we are suppressing them+pprUnique uniq+  = ppUnlessOption sdocSuppressUniques $+      pprUniqueAlways uniq++ppr_underscore_unique :: Unique -> SDoc+-- Print an underscore separating the name from its unique+-- But suppress it if we aren't printing the uniques anyway+ppr_underscore_unique uniq+  = ppUnlessOption sdocSuppressUniques $+      char '_' <> pprUniqueAlways uniq++ppr_occ_name :: OccName -> SDoc+ppr_occ_name occ = ftext (occNameFS occ)+        -- Don't use pprOccName; instead, just print the string of the OccName;+        -- we print the namespace in the debug stuff above++-- In code style, we Z-encode the strings.  The results of Z-encoding each FastString are+-- cached behind the scenes in the FastString implementation.+ppr_z_occ_name :: OccName -> SDoc+ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ))++-- Prints (if mod information is available) "Defined at <loc>" or+--  "Defined in <mod>" information for a Name.+pprDefinedAt :: Name -> SDoc+pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name++pprNameDefnLoc :: Name -> SDoc+-- Prints "at <loc>" or+--     or "in <mod>" depending on what info is available+pprNameDefnLoc name+  = case nameSrcLoc name of+         -- nameSrcLoc rather than nameSrcSpan+         -- It seems less cluttered to show a location+         -- rather than a span for the definition point+       RealSrcLoc s _ -> text "at" <+> ppr s+       UnhelpfulLoc s+         | isInternalName name || isSystemName name+         -> text "at" <+> ftext s+         | otherwise+         -> text "in" <+> quotes (ppr (nameModule name))+++-- | Get a string representation of a 'Name' that's unique and stable+-- across recompilations. Used for deterministic generation of binds for+-- derived instances.+-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String"+nameStableString :: Name -> String+nameStableString Name{..} =+  nameSortStableString n_sort ++ "$" ++ occNameString n_occ++nameSortStableString :: NameSort -> String+nameSortStableString System = "$_sys"+nameSortStableString Internal = "$_in"+nameSortStableString (External mod) = moduleStableString mod+nameSortStableString (WiredIn mod _ _) = moduleStableString mod++{-+************************************************************************+*                                                                      *+\subsection{Overloaded functions related to Names}+*                                                                      *+************************************************************************+-}++-- | A class allowing convenient access to the 'Name' of various datatypes+class NamedThing a where+    getOccName :: a -> OccName+    getName    :: a -> Name++    getOccName n = nameOccName (getName n)      -- Default method++instance NamedThing e => NamedThing (Located e) where+    getName = getName . unLoc++getSrcLoc           :: NamedThing a => a -> SrcLoc+getSrcSpan          :: NamedThing a => a -> SrcSpan+getOccString        :: NamedThing a => a -> String+getOccFS            :: NamedThing a => a -> FastString++getSrcLoc           = nameSrcLoc           . getName+getSrcSpan          = nameSrcSpan          . getName+getOccString        = occNameString        . getOccName+getOccFS            = occNameFS            . getOccName++pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc+-- See Outputable.pprPrefixVar, pprInfixVar;+-- add parens or back-quotes as appropriate+pprInfixName  n = pprInfixVar (isSymOcc (getOccName n)) (ppr n)++pprPrefixName :: NamedThing a => a -> SDoc+pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name)+ where+   name = getName thing
+ compiler/GHC/Types/Name.hs-boot view
@@ -0,0 +1,5 @@+module GHC.Types.Name where++import GhcPrelude ()++data Name
+ compiler/GHC/Types/Name/Cache.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}++-- | The Name Cache+module GHC.Types.Name.Cache+    ( lookupOrigNameCache+    , extendOrigNameCache+    , extendNameCache+    , initNameCache+    , NameCache(..), OrigNameCache+    ) where++import GhcPrelude++import GHC.Types.Module+import GHC.Types.Name+import GHC.Types.Unique.Supply+import TysWiredIn+import Util+import Outputable+import PrelNames++#include "HsVersions.h"++{-++Note [The Name Cache]+~~~~~~~~~~~~~~~~~~~~~+The Name Cache makes sure that, during any invocation of GHC, each+External Name "M.x" has one, and only one globally-agreed Unique.++* The first time we come across M.x we make up a Unique and record that+  association in the Name Cache.++* When we come across "M.x" again, we look it up in the Name Cache,+  and get a hit.++The functions newGlobalBinder, allocateGlobalBinder do the main work.+When you make an External name, you should probably be calling one+of them.+++Note [Built-in syntax and the OrigNameCache]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower+their cost we use two tricks,++  a. We specially encode tuple and sum Names in interface files' symbol tables+     to avoid having to look up their names while loading interface files.+     Namely these names are encoded as by their Uniques. We know how to get from+     a Unique back to the Name which it represents via the mapping defined in+     the SumTupleUniques module. See Note [Symbol table representation of names]+     in GHC.Iface.Binary and for details.++  b. We don't include them in the Orig name cache but instead parse their+     OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with+     them.++Why is the second measure necessary? Good question; afterall, 1) the parser+emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never+needs to looked-up during interface loading due to (a). It turns out that there+are two reasons why we might look up an Orig RdrName for built-in syntax,++  * If you use setRdrNameSpace on an Exact RdrName it may be+    turned into an Orig RdrName.++  * Template Haskell turns a BuiltInSyntax Name into a TH.NameG+    (GHC.HsToCore.Quote.globalVar), and parses a NameG into an Orig RdrName+    (GHC.ThToHs.thRdrName).  So, e.g. $(do { reify '(,); ... }) will+    go this route (#8954).++-}++-- | Per-module cache of original 'OccName's given 'Name's+type OrigNameCache   = ModuleEnv (OccEnv Name)++lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name+lookupOrigNameCache nc mod occ+  | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE+  , Just name <- isBuiltInOcc_maybe occ+  =     -- See Note [Known-key names], 3(c) in PrelNames+        -- Special case for tuples; there are too many+        -- of them to pre-populate the original-name cache+    Just name++  | otherwise+  = case lookupModuleEnv nc mod of+        Nothing      -> Nothing+        Just occ_env -> lookupOccEnv occ_env occ++extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache+extendOrigNameCache nc name+  = ASSERT2( isExternalName name, ppr name )+    extendNameCache nc (nameModule name) (nameOccName name) name++extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache+extendNameCache nc mod occ name+  = extendModuleEnvWith combine nc mod (unitOccEnv occ name)+  where+    combine _ occ_env = extendOccEnv occ_env occ name++-- | The NameCache makes sure that there is just one Unique assigned for+-- each original name; i.e. (module-name, occ-name) pair and provides+-- something of a lookup mechanism for those names.+data NameCache+ = NameCache {  nsUniqs :: !UniqSupply,+                -- ^ Supply of uniques+                nsNames :: !OrigNameCache+                -- ^ Ensures that one original name gets one unique+   }++-- | Return a function to atomically update the name cache.+initNameCache :: UniqSupply -> [Name] -> NameCache+initNameCache us names+  = NameCache { nsUniqs = us,+                nsNames = initOrigNames names }++initOrigNames :: [Name] -> OrigNameCache+initOrigNames names = foldl' extendOrigNameCache emptyModuleEnv names
+ compiler/GHC/Types/Name/Env.hs view
@@ -0,0 +1,175 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[NameEnv]{@NameEnv@: name environments}+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++module GHC.Types.Name.Env (+        -- * Var, Id and TyVar environments (maps)+        NameEnv,++        -- ** Manipulating these environments+        mkNameEnv, mkNameEnvWith,+        emptyNameEnv, isEmptyNameEnv,+        unitNameEnv, nameEnvElts,+        extendNameEnv_C, extendNameEnv_Acc, extendNameEnv,+        extendNameEnvList, extendNameEnvList_C,+        filterNameEnv, anyNameEnv,+        plusNameEnv, plusNameEnv_C, alterNameEnv,+        lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,+        elemNameEnv, mapNameEnv, disjointNameEnv,++        DNameEnv,++        emptyDNameEnv,+        lookupDNameEnv,+        delFromDNameEnv, filterDNameEnv,+        mapDNameEnv,+        adjustDNameEnv, alterDNameEnv, extendDNameEnv,+        -- ** Dependency analysis+        depAnal+    ) where++#include "HsVersions.h"++import GhcPrelude++import Digraph+import GHC.Types.Name+import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM+import Maybes++{-+************************************************************************+*                                                                      *+\subsection{Name environment}+*                                                                      *+************************************************************************+-}++{-+Note [depAnal determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~~+depAnal is deterministic provided it gets the nodes in a deterministic order.+The order of lists that get_defs and get_uses return doesn't matter, as these+are only used to construct the edges, and stronglyConnCompFromEdgedVertices is+deterministic even when the edges are not in deterministic order as explained+in Note [Deterministic SCC] in Digraph.+-}++depAnal :: forall node.+           (node -> [Name])      -- Defs+        -> (node -> [Name])      -- Uses+        -> [node]+        -> [SCC node]+-- Perform dependency analysis on a group of definitions,+-- where each definition may define more than one Name+--+-- The get_defs and get_uses functions are called only once per node+depAnal get_defs get_uses nodes+  = stronglyConnCompFromEdgedVerticesUniq graph_nodes+  where+    graph_nodes = (map mk_node keyed_nodes) :: [Node Int node]+    keyed_nodes = nodes `zip` [(1::Int)..]+    mk_node (node, key) =+      let !edges = (mapMaybe (lookupNameEnv key_map) (get_uses node))+      in DigraphNode node key edges++    key_map :: NameEnv Int   -- Maps a Name to the key of the decl that defines it+    key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node]++{-+************************************************************************+*                                                                      *+\subsection{Name environment}+*                                                                      *+************************************************************************+-}++-- | Name Environment+type NameEnv a = UniqFM a       -- Domain is Name++emptyNameEnv       :: NameEnv a+isEmptyNameEnv     :: NameEnv a -> Bool+mkNameEnv          :: [(Name,a)] -> NameEnv a+mkNameEnvWith      :: (a -> Name) -> [a] -> NameEnv a+nameEnvElts        :: NameEnv a -> [a]+alterNameEnv       :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a+extendNameEnv_C    :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a+extendNameEnv_Acc  :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b+extendNameEnv      :: NameEnv a -> Name -> a -> NameEnv a+plusNameEnv        :: NameEnv a -> NameEnv a -> NameEnv a+plusNameEnv_C      :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a+extendNameEnvList  :: NameEnv a -> [(Name,a)] -> NameEnv a+extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a+delFromNameEnv     :: NameEnv a -> Name -> NameEnv a+delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a+elemNameEnv        :: Name -> NameEnv a -> Bool+unitNameEnv        :: Name -> a -> NameEnv a+lookupNameEnv      :: NameEnv a -> Name -> Maybe a+lookupNameEnv_NF   :: NameEnv a -> Name -> a+filterNameEnv      :: (elt -> Bool) -> NameEnv elt -> NameEnv elt+anyNameEnv         :: (elt -> Bool) -> NameEnv elt -> Bool+mapNameEnv         :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2+disjointNameEnv    :: NameEnv a -> NameEnv a -> Bool++nameEnvElts x         = eltsUFM x+emptyNameEnv          = emptyUFM+isEmptyNameEnv        = isNullUFM+unitNameEnv x y       = unitUFM x y+extendNameEnv x y z   = addToUFM x y z+extendNameEnvList x l = addListToUFM x l+lookupNameEnv x y     = lookupUFM x y+alterNameEnv          = alterUFM+mkNameEnv     l       = listToUFM l+mkNameEnvWith f       = mkNameEnv . map (\a -> (f a, a))+elemNameEnv x y          = elemUFM x y+plusNameEnv x y          = plusUFM x y+plusNameEnv_C f x y      = plusUFM_C f x y+extendNameEnv_C f x y z  = addToUFM_C f x y z+mapNameEnv f x           = mapUFM f x+extendNameEnv_Acc x y z a b  = addToUFM_Acc x y z a b+extendNameEnvList_C x y z = addListToUFM_C x y z+delFromNameEnv x y      = delFromUFM x y+delListFromNameEnv x y  = delListFromUFM x y+filterNameEnv x y       = filterUFM x y+anyNameEnv f x          = foldUFM ((||) . f) False x+disjointNameEnv x y     = isNullUFM (intersectUFM x y)++lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n)++-- | Deterministic Name Environment+--+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why+-- we need DNameEnv.+type DNameEnv a = UniqDFM a++emptyDNameEnv :: DNameEnv a+emptyDNameEnv = emptyUDFM++lookupDNameEnv :: DNameEnv a -> Name -> Maybe a+lookupDNameEnv = lookupUDFM++delFromDNameEnv :: DNameEnv a -> Name -> DNameEnv a+delFromDNameEnv = delFromUDFM++filterDNameEnv :: (a -> Bool) -> DNameEnv a -> DNameEnv a+filterDNameEnv = filterUDFM++mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b+mapDNameEnv = mapUDFM++adjustDNameEnv :: (a -> a) -> DNameEnv a -> Name -> DNameEnv a+adjustDNameEnv = adjustUDFM++alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a+alterDNameEnv = alterUDFM++extendDNameEnv :: DNameEnv a -> Name -> a -> DNameEnv a+extendDNameEnv = addToUDFM
+ compiler/GHC/Types/Name/Occurrence.hs view
@@ -0,0 +1,927 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++-- |+-- #name_types#+-- GHC uses several kinds of name internally:+--+-- * 'OccName.OccName' represents names as strings with just a little more information:+--   the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or+--   data constructors+--+-- * 'RdrName.RdrName': see "RdrName#name_types"+--+-- * 'Name.Name': see "Name#name_types"+--+-- * 'Id.Id': see "Id#name_types"+--+-- * 'Var.Var': see "Var#name_types"++module GHC.Types.Name.Occurrence (+        -- * The 'NameSpace' type+        NameSpace, -- Abstract++        nameSpacesRelated,++        -- ** Construction+        -- $real_vs_source_data_constructors+        tcName, clsName, tcClsName, dataName, varName,+        tvName, srcDataName,++        -- ** Pretty Printing+        pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief,++        -- * The 'OccName' type+        OccName,        -- Abstract, instance of Outputable+        pprOccName,++        -- ** Construction+        mkOccName, mkOccNameFS,+        mkVarOcc, mkVarOccFS,+        mkDataOcc, mkDataOccFS,+        mkTyVarOcc, mkTyVarOccFS,+        mkTcOcc, mkTcOccFS,+        mkClsOcc, mkClsOccFS,+        mkDFunOcc,+        setOccNameSpace,+        demoteOccName,+        HasOccName(..),++        -- ** Derived 'OccName's+        isDerivedOccName,+        mkDataConWrapperOcc, mkWorkerOcc,+        mkMatcherOcc, mkBuilderOcc,+        mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc,+        mkNewTyCoOcc, mkClassOpAuxOcc,+        mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,+        mkClassDataConOcc, mkDictOcc, mkIPOcc,+        mkSpecOcc, mkForeignExportOcc, mkRepEqOcc,+        mkGenR, mkGen1R,+        mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,+        mkSuperDictSelOcc, mkSuperDictAuxOcc,+        mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,+        mkInstTyCoOcc, mkEqPredCoOcc,+        mkRecFldSelOcc,+        mkTyConRepOcc,++        -- ** Deconstruction+        occNameFS, occNameString, occNameSpace,++        isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,+        parenSymOcc, startsWithUnderscore,++        isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace,++        -- * The 'OccEnv' type+        OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv,+        lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,+        occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,+        extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv,+        alterOccEnv, pprOccEnv,++        -- * The 'OccSet' type+        OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet,+        extendOccSetList,+        unionOccSets, unionManyOccSets, minusOccSet, elemOccSet,+        isEmptyOccSet, intersectOccSet, intersectsOccSet,+        filterOccSet,++        -- * Tidying up+        TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv,+        tidyOccName, avoidClashesOccEnv, delTidyOccEnvList,++        -- FsEnv+        FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv+    ) where++import GhcPrelude++import Util+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import FastString+import FastStringEnv+import Outputable+import GHC.Utils.Lexeme+import Binary+import Control.DeepSeq+import Data.Char+import Data.Data++{-+************************************************************************+*                                                                      *+\subsection{Name space}+*                                                                      *+************************************************************************+-}++data NameSpace = VarName        -- Variables, including "real" data constructors+               | DataName       -- "Source" data constructors+               | TvName         -- Type variables+               | TcClsName      -- Type constructors and classes; Haskell has them+                                -- in the same name space for now.+               deriving( Eq, Ord )++-- Note [Data Constructors]+-- see also: Note [Data Constructor Naming] in GHC.Core.DataCon+--+-- $real_vs_source_data_constructors+-- There are two forms of data constructor:+--+--      [Source data constructors] The data constructors mentioned in Haskell source code+--+--      [Real data constructors] The data constructors of the representation type, which may not be the same as the source type+--+-- For example:+--+-- > data T = T !(Int, Int)+--+-- The source datacon has type @(Int, Int) -> T@+-- The real   datacon has type @Int -> Int -> T@+--+-- GHC chooses a representation based on the strictness etc.++tcName, clsName, tcClsName :: NameSpace+dataName, srcDataName      :: NameSpace+tvName, varName            :: NameSpace++-- Though type constructors and classes are in the same name space now,+-- the NameSpace type is abstract, so we can easily separate them later+tcName    = TcClsName           -- Type constructors+clsName   = TcClsName           -- Classes+tcClsName = TcClsName           -- Not sure which!++dataName    = DataName+srcDataName = DataName  -- Haskell-source data constructors should be+                        -- in the Data name space++tvName      = TvName+varName     = VarName++isDataConNameSpace :: NameSpace -> Bool+isDataConNameSpace DataName = True+isDataConNameSpace _        = False++isTcClsNameSpace :: NameSpace -> Bool+isTcClsNameSpace TcClsName = True+isTcClsNameSpace _         = False++isTvNameSpace :: NameSpace -> Bool+isTvNameSpace TvName = True+isTvNameSpace _      = False++isVarNameSpace :: NameSpace -> Bool     -- Variables or type variables, but not constructors+isVarNameSpace TvName  = True+isVarNameSpace VarName = True+isVarNameSpace _       = False++isValNameSpace :: NameSpace -> Bool+isValNameSpace DataName = True+isValNameSpace VarName  = True+isValNameSpace _        = False++pprNameSpace :: NameSpace -> SDoc+pprNameSpace DataName  = text "data constructor"+pprNameSpace VarName   = text "variable"+pprNameSpace TvName    = text "type variable"+pprNameSpace TcClsName = text "type constructor or class"++pprNonVarNameSpace :: NameSpace -> SDoc+pprNonVarNameSpace VarName = empty+pprNonVarNameSpace ns = pprNameSpace ns++pprNameSpaceBrief :: NameSpace -> SDoc+pprNameSpaceBrief DataName  = char 'd'+pprNameSpaceBrief VarName   = char 'v'+pprNameSpaceBrief TvName    = text "tv"+pprNameSpaceBrief TcClsName = text "tc"++-- demoteNameSpace lowers the NameSpace if possible.  We can not know+-- in advance, since a TvName can appear in an HsTyVar.+-- See Note [Demotion] in GHC.Rename.Env+demoteNameSpace :: NameSpace -> Maybe NameSpace+demoteNameSpace VarName = Nothing+demoteNameSpace DataName = Nothing+demoteNameSpace TvName = Nothing+demoteNameSpace TcClsName = Just DataName++{-+************************************************************************+*                                                                      *+\subsection[Name-pieces-datatypes]{The @OccName@ datatypes}+*                                                                      *+************************************************************************+-}++-- | Occurrence Name+--+-- In this context that means:+-- "classified (i.e. as a type name, value name, etc) but not qualified+-- and not yet resolved"+data OccName = OccName+    { occNameSpace  :: !NameSpace+    , occNameFS     :: !FastString+    }++instance Eq OccName where+    (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2++instance Ord OccName where+        -- Compares lexicographically, *not* by Unique of the string+    compare (OccName sp1 s1) (OccName sp2 s2)+        = (s1  `compare` s2) `thenCmp` (sp1 `compare` sp2)++instance Data OccName where+  -- don't traverse?+  toConstr _   = abstractConstr "OccName"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "OccName"++instance HasOccName OccName where+  occName = id++instance NFData OccName where+  rnf x = x `seq` ()++{-+************************************************************************+*                                                                      *+\subsection{Printing}+*                                                                      *+************************************************************************+-}++instance Outputable OccName where+    ppr = pprOccName++instance OutputableBndr OccName where+    pprBndr _ = ppr+    pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n)+    pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n)++pprOccName :: OccName -> SDoc+pprOccName (OccName sp occ)+  = getPprStyle $ \ sty ->+    if codeStyle sty+    then ztext (zEncodeFS occ)+    else pp_occ <> pp_debug sty+  where+    pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp)+                 | otherwise      = empty++    pp_occ = sdocOption sdocSuppressUniques $ \case+               True  -> text (strip_th_unique (unpackFS occ))+               False -> ftext occ++        -- See Note [Suppressing uniques in OccNames]+    strip_th_unique ('[' : c : _) | isAlphaNum c = []+    strip_th_unique (c : cs) = c : strip_th_unique cs+    strip_th_unique []       = []++{-+Note [Suppressing uniques in OccNames]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This is a hack to de-wobblify the OccNames that contain uniques from+Template Haskell that have been turned into a string in the OccName.+See Note [Unique OccNames from Template Haskell] in Convert.hs++************************************************************************+*                                                                      *+\subsection{Construction}+*                                                                      *+************************************************************************+-}++mkOccName :: NameSpace -> String -> OccName+mkOccName occ_sp str = OccName occ_sp (mkFastString str)++mkOccNameFS :: NameSpace -> FastString -> OccName+mkOccNameFS occ_sp fs = OccName occ_sp fs++mkVarOcc :: String -> OccName+mkVarOcc s = mkOccName varName s++mkVarOccFS :: FastString -> OccName+mkVarOccFS fs = mkOccNameFS varName fs++mkDataOcc :: String -> OccName+mkDataOcc = mkOccName dataName++mkDataOccFS :: FastString -> OccName+mkDataOccFS = mkOccNameFS dataName++mkTyVarOcc :: String -> OccName+mkTyVarOcc = mkOccName tvName++mkTyVarOccFS :: FastString -> OccName+mkTyVarOccFS fs = mkOccNameFS tvName fs++mkTcOcc :: String -> OccName+mkTcOcc = mkOccName tcName++mkTcOccFS :: FastString -> OccName+mkTcOccFS = mkOccNameFS tcName++mkClsOcc :: String -> OccName+mkClsOcc = mkOccName clsName++mkClsOccFS :: FastString -> OccName+mkClsOccFS = mkOccNameFS clsName++-- demoteOccName lowers the Namespace of OccName.+-- see Note [Demotion]+demoteOccName :: OccName -> Maybe OccName+demoteOccName (OccName space name) = do+  space' <- demoteNameSpace space+  return $ OccName space' name++-- Name spaces are related if there is a chance to mean the one when one writes+-- the other, i.e. variables <-> data constructors and type variables <-> type constructors+nameSpacesRelated :: NameSpace -> NameSpace -> Bool+nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2++otherNameSpace :: NameSpace -> NameSpace+otherNameSpace VarName = DataName+otherNameSpace DataName = VarName+otherNameSpace TvName = TcClsName+otherNameSpace TcClsName = TvName++++{- | Other names in the compiler add additional information to an OccName.+This class provides a consistent way to access the underlying OccName. -}+class HasOccName name where+  occName :: name -> OccName++{-+************************************************************************+*                                                                      *+                Environments+*                                                                      *+************************************************************************++OccEnvs are used mainly for the envts in ModIfaces.++Note [The Unique of an OccName]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+They are efficient, because FastStrings have unique Int# keys.  We assume+this key is less than 2^24, and indeed FastStrings are allocated keys+sequentially starting at 0.++So we can make a Unique using+        mkUnique ns key  :: Unique+where 'ns' is a Char representing the name space.  This in turn makes it+easy to build an OccEnv.+-}++instance Uniquable OccName where+      -- See Note [The Unique of an OccName]+  getUnique (OccName VarName   fs) = mkVarOccUnique  fs+  getUnique (OccName DataName  fs) = mkDataOccUnique fs+  getUnique (OccName TvName    fs) = mkTvOccUnique   fs+  getUnique (OccName TcClsName fs) = mkTcOccUnique   fs++newtype OccEnv a = A (UniqFM a)+  deriving Data++emptyOccEnv :: OccEnv a+unitOccEnv  :: OccName -> a -> OccEnv a+extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a+extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a+lookupOccEnv :: OccEnv a -> OccName -> Maybe a+mkOccEnv     :: [(OccName,a)] -> OccEnv a+mkOccEnv_C   :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a+elemOccEnv   :: OccName -> OccEnv a -> Bool+foldOccEnv   :: (a -> b -> b) -> b -> OccEnv a -> b+occEnvElts   :: OccEnv a -> [a]+extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a+extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b+plusOccEnv     :: OccEnv a -> OccEnv a -> OccEnv a+plusOccEnv_C   :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a+mapOccEnv      :: (a->b) -> OccEnv a -> OccEnv b+delFromOccEnv      :: OccEnv a -> OccName -> OccEnv a+delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a+filterOccEnv       :: (elt -> Bool) -> OccEnv elt -> OccEnv elt+alterOccEnv        :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt++emptyOccEnv      = A emptyUFM+unitOccEnv x y = A $ unitUFM x y+extendOccEnv (A x) y z = A $ addToUFM x y z+extendOccEnvList (A x) l = A $ addListToUFM x l+lookupOccEnv (A x) y = lookupUFM x y+mkOccEnv     l    = A $ listToUFM l+elemOccEnv x (A y)       = elemUFM x y+foldOccEnv a b (A c)     = foldUFM a b c+occEnvElts (A x)         = eltsUFM x+plusOccEnv (A x) (A y)   = A $ plusUFM x y+plusOccEnv_C f (A x) (A y)       = A $ plusUFM_C f x y+extendOccEnv_C f (A x) y z   = A $ addToUFM_C f x y z+extendOccEnv_Acc f g (A x) y z   = A $ addToUFM_Acc f g x y z+mapOccEnv f (A x)        = A $ mapUFM f x+mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l+delFromOccEnv (A x) y    = A $ delFromUFM x y+delListFromOccEnv (A x) y  = A $ delListFromUFM x y+filterOccEnv x (A y)       = A $ filterUFM x y+alterOccEnv fn (A y) k     = A $ alterUFM fn y k++instance Outputable a => Outputable (OccEnv a) where+    ppr x = pprOccEnv ppr x++pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc+pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env++type OccSet = UniqSet OccName++emptyOccSet       :: OccSet+unitOccSet        :: OccName -> OccSet+mkOccSet          :: [OccName] -> OccSet+extendOccSet      :: OccSet -> OccName -> OccSet+extendOccSetList  :: OccSet -> [OccName] -> OccSet+unionOccSets      :: OccSet -> OccSet -> OccSet+unionManyOccSets  :: [OccSet] -> OccSet+minusOccSet       :: OccSet -> OccSet -> OccSet+elemOccSet        :: OccName -> OccSet -> Bool+isEmptyOccSet     :: OccSet -> Bool+intersectOccSet   :: OccSet -> OccSet -> OccSet+intersectsOccSet  :: OccSet -> OccSet -> Bool+filterOccSet      :: (OccName -> Bool) -> OccSet -> OccSet++emptyOccSet       = emptyUniqSet+unitOccSet        = unitUniqSet+mkOccSet          = mkUniqSet+extendOccSet      = addOneToUniqSet+extendOccSetList  = addListToUniqSet+unionOccSets      = unionUniqSets+unionManyOccSets  = unionManyUniqSets+minusOccSet       = minusUniqSet+elemOccSet        = elementOfUniqSet+isEmptyOccSet     = isEmptyUniqSet+intersectOccSet   = intersectUniqSets+intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2))+filterOccSet      = filterUniqSet++{-+************************************************************************+*                                                                      *+\subsection{Predicates and taking them apart}+*                                                                      *+************************************************************************+-}++occNameString :: OccName -> String+occNameString (OccName _ s) = unpackFS s++setOccNameSpace :: NameSpace -> OccName -> OccName+setOccNameSpace sp (OccName _ occ) = OccName sp occ++isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool++isVarOcc (OccName VarName _) = True+isVarOcc _                   = False++isTvOcc (OccName TvName _) = True+isTvOcc _                  = False++isTcOcc (OccName TcClsName _) = True+isTcOcc _                     = False++-- | /Value/ 'OccNames's are those that are either in+-- the variable or data constructor namespaces+isValOcc :: OccName -> Bool+isValOcc (OccName VarName  _) = True+isValOcc (OccName DataName _) = True+isValOcc _                    = False++isDataOcc (OccName DataName _) = True+isDataOcc _                    = False++-- | Test if the 'OccName' is a data constructor that starts with+-- a symbol (e.g. @:@, or @[]@)+isDataSymOcc :: OccName -> Bool+isDataSymOcc (OccName DataName s) = isLexConSym s+isDataSymOcc _                    = False+-- Pretty inefficient!++-- | Test if the 'OccName' is that for any operator (whether+-- it is a data constructor or variable or whatever)+isSymOcc :: OccName -> Bool+isSymOcc (OccName DataName s)  = isLexConSym s+isSymOcc (OccName TcClsName s) = isLexSym s+isSymOcc (OccName VarName s)   = isLexSym s+isSymOcc (OccName TvName s)    = isLexSym s+-- Pretty inefficient!++parenSymOcc :: OccName -> SDoc -> SDoc+-- ^ Wrap parens around an operator+parenSymOcc occ doc | isSymOcc occ = parens doc+                    | otherwise    = doc++startsWithUnderscore :: OccName -> Bool+-- ^ Haskell 98 encourages compilers to suppress warnings about unused+-- names in a pattern if they start with @_@: this implements that test+startsWithUnderscore occ = headFS (occNameFS occ) == '_'++{-+************************************************************************+*                                                                      *+\subsection{Making system names}+*                                                                      *+************************************************************************++Here's our convention for splitting up the interface file name space:++   d...         dictionary identifiers+                (local variables, so no name-clash worries)++All of these other OccNames contain a mixture of alphabetic+and symbolic characters, and hence cannot possibly clash with+a user-written type or function name++   $f...        Dict-fun identifiers (from inst decls)+   $dmop        Default method for 'op'+   $pnC         n'th superclass selector for class C+   $wf          Worker for function 'f'+   $sf..        Specialised version of f+   D:C          Data constructor for dictionary for class C+   NTCo:T       Coercion connecting newtype T with its representation type+   TFCo:R       Coercion connecting a data family to its representation type R++In encoded form these appear as Zdfxxx etc++        :...            keywords (export:, letrec: etc.)+--- I THINK THIS IS WRONG!++This knowledge is encoded in the following functions.++@mk_deriv@ generates an @OccName@ from the prefix and a string.+NB: The string must already be encoded!+-}++-- | Build an 'OccName' derived from another 'OccName'.+--+-- Note that the pieces of the name are passed in as a @[FastString]@ so that+-- the whole name can be constructed with a single 'concatFS', minimizing+-- unnecessary intermediate allocations.+mk_deriv :: NameSpace+         -> FastString      -- ^ A prefix which distinguishes one sort of+                            -- derived name from another+         -> [FastString]    -- ^ The name we are deriving from in pieces which+                            -- will be concatenated.+         -> OccName+mk_deriv occ_sp sys_prefix str =+    mkOccNameFS occ_sp (concatFS $ sys_prefix : str)++isDerivedOccName :: OccName -> Bool+-- ^ Test for definitions internally generated by GHC.  This predicate+-- is used to suppress printing of internal definitions in some debug prints+isDerivedOccName occ =+   case occNameString occ of+     '$':c:_ | isAlphaNum c -> True   -- E.g.  $wfoo+     c:':':_ | isAlphaNum c -> True   -- E.g.  N:blah   newtype coercions+     _other                 -> False++isDefaultMethodOcc :: OccName -> Bool+isDefaultMethodOcc occ =+   case occNameString occ of+     '$':'d':'m':_ -> True+     _ -> False++-- | Is an 'OccName' one of a Typeable @TyCon@ or @Module@ binding?+-- This is needed as these bindings are renamed differently.+-- See Note [Grand plan for Typeable] in TcTypeable.+isTypeableBindOcc :: OccName -> Bool+isTypeableBindOcc occ =+   case occNameString occ of+     '$':'t':'c':_ -> True  -- mkTyConRepOcc+     '$':'t':'r':_ -> True  -- Module binding+     _ -> False++mkDataConWrapperOcc, mkWorkerOcc,+        mkMatcherOcc, mkBuilderOcc,+        mkDefaultMethodOcc,+        mkClassDataConOcc, mkDictOcc,+        mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc,+        mkGenR, mkGen1R,+        mkDataConWorkerOcc, mkNewTyCoOcc,+        mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,+        mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,+        mkTyConRepOcc+   :: OccName -> OccName++-- These derived variables have a prefix that no Haskell value could have+mkDataConWrapperOcc = mk_simple_deriv varName  "$W"+mkWorkerOcc         = mk_simple_deriv varName  "$w"+mkMatcherOcc        = mk_simple_deriv varName  "$m"+mkBuilderOcc        = mk_simple_deriv varName  "$b"+mkDefaultMethodOcc  = mk_simple_deriv varName  "$dm"+mkClassOpAuxOcc     = mk_simple_deriv varName  "$c"+mkDictOcc           = mk_simple_deriv varName  "$d"+mkIPOcc             = mk_simple_deriv varName  "$i"+mkSpecOcc           = mk_simple_deriv varName  "$s"+mkForeignExportOcc  = mk_simple_deriv varName  "$f"+mkRepEqOcc          = mk_simple_deriv tvName   "$r"   -- In RULES involving Coercible+mkClassDataConOcc   = mk_simple_deriv dataName "C:"     -- Data con for a class+mkNewTyCoOcc        = mk_simple_deriv tcName   "N:"   -- Coercion for newtypes+mkInstTyCoOcc       = mk_simple_deriv tcName   "D:"   -- Coercion for type functions+mkEqPredCoOcc       = mk_simple_deriv tcName   "$co"++-- Used in derived instances+mkCon2TagOcc        = mk_simple_deriv varName  "$con2tag_"+mkTag2ConOcc        = mk_simple_deriv varName  "$tag2con_"+mkMaxTagOcc         = mk_simple_deriv varName  "$maxtag_"++-- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable+mkTyConRepOcc occ = mk_simple_deriv varName prefix occ+  where+    prefix | isDataOcc occ = "$tc'"+           | otherwise     = "$tc"++-- Generic deriving mechanism+mkGenR   = mk_simple_deriv tcName "Rep_"+mkGen1R  = mk_simple_deriv tcName "Rep1_"++-- Overloaded record field selectors+mkRecFldSelOcc :: String -> OccName+mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s]++mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName+mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ]++-- Data constructor workers are made by setting the name space+-- of the data constructor OccName (which should be a DataName)+-- to VarName+mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ++mkSuperDictAuxOcc :: Int -> OccName -> OccName+mkSuperDictAuxOcc index cls_tc_occ+  = mk_deriv varName "$cp" [fsLit $ show index, occNameFS cls_tc_occ]++mkSuperDictSelOcc :: Int        -- ^ Index of superclass, e.g. 3+                  -> OccName    -- ^ Class, e.g. @Ord@+                  -> OccName    -- ^ Derived 'Occname', e.g. @$p3Ord@+mkSuperDictSelOcc index cls_tc_occ+  = mk_deriv varName "$p" [fsLit $ show index, occNameFS cls_tc_occ]++mkLocalOcc :: Unique            -- ^ Unique to combine with the 'OccName'+           -> OccName           -- ^ Local name, e.g. @sat@+           -> OccName           -- ^ Nice unique version, e.g. @$L23sat@+mkLocalOcc uniq occ+   = mk_deriv varName "$L" [fsLit $ show uniq, occNameFS occ]+        -- The Unique might print with characters+        -- that need encoding (e.g. 'z'!)++-- | Derive a name for the representation type constructor of a+-- @data@\/@newtype@ instance.+mkInstTyTcOcc :: String                 -- ^ Family name, e.g. @Map@+              -> OccSet                 -- ^ avoid these Occs+              -> OccName                -- ^ @R:Map@+mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str)++mkDFunOcc :: String             -- ^ Typically the class and type glommed together e.g. @OrdMaybe@.+                                -- Only used in debug mode, for extra clarity+          -> Bool               -- ^ Is this a hs-boot instance DFun?+          -> OccSet             -- ^ avoid these Occs+          -> OccName            -- ^ E.g. @$f3OrdMaybe@++-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real+-- thing when we compile the mother module. Reason: we don't know exactly+-- what the  mother module will call it.++mkDFunOcc info_str is_boot set+  = chooseUniqueOcc VarName (prefix ++ info_str) set+  where+    prefix | is_boot   = "$fx"+           | otherwise = "$f"++mkDataTOcc, mkDataCOcc+  :: OccName            -- ^ TyCon or data con string+  -> OccSet             -- ^ avoid these Occs+  -> OccName            -- ^ E.g. @$f3OrdMaybe@+-- data T = MkT ... deriving( Data ) needs definitions for+--      $tT   :: Data.Generics.Basics.DataType+--      $cMkT :: Data.Generics.Basics.Constr+mkDataTOcc occ = chooseUniqueOcc VarName ("$t" ++ occNameString occ)+mkDataCOcc occ = chooseUniqueOcc VarName ("$c" ++ occNameString occ)++{-+Sometimes we need to pick an OccName that has not already been used,+given a set of in-use OccNames.+-}++chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName+chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int)+  where+  loop occ n+   | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1)+   | otherwise            = occ++{-+We used to add a '$m' to indicate a method, but that gives rise to bad+error messages from the type checker when we print the function name or pattern+of an instance-decl binding.  Why? Because the binding is zapped+to use the method name in place of the selector name.+(See TcClassDcl.tcMethodBind)++The way it is now, -ddump-xx output may look confusing, but+you can always say -dppr-debug to get the uniques.++However, we *do* have to zap the first character to be lower case,+because overloaded constructors (blarg) generate methods too.+And convert to VarName space++e.g. a call to constructor MkFoo where+        data (Ord a) => Foo a = MkFoo a++If this is necessary, we do it by prefixing '$m'.  These+guys never show up in error messages.  What a hack.+-}++mkMethodOcc :: OccName -> OccName+mkMethodOcc occ@(OccName VarName _) = occ+mkMethodOcc occ                     = mk_simple_deriv varName "$m" occ++{-+************************************************************************+*                                                                      *+\subsection{Tidying them up}+*                                                                      *+************************************************************************++Before we print chunks of code we like to rename it so that+we don't have to print lots of silly uniques in it.  But we mustn't+accidentally introduce name clashes!  So the idea is that we leave the+OccName alone unless it accidentally clashes with one that is already+in scope; if so, we tack on '1' at the end and try again, then '2', and+so on till we find a unique one.++There's a wrinkle for operators.  Consider '>>='.  We can't use '>>=1'+because that isn't a single lexeme.  So we encode it to 'lle' and *then*+tack on the '1', if necessary.++Note [TidyOccEnv]+~~~~~~~~~~~~~~~~~+type TidyOccEnv = UniqFM Int++* Domain = The OccName's FastString. These FastStrings are "taken";+           make sure that we don't re-use++* Int, n = A plausible starting point for new guesses+           There is no guarantee that "FSn" is available;+           you must look that up in the TidyOccEnv.  But+           it's a good place to start looking.++* When looking for a renaming for "foo2" we strip off the "2" and start+  with "foo".  Otherwise if we tidy twice we get silly names like foo23.++  However, if it started with digits at the end, we always make a name+  with digits at the end, rather than shortening "foo2" to just "foo",+  even if "foo" is unused.  Reasons:+     - Plain "foo" might be used later+     - We use trailing digits to subtly indicate a unification variable+       in typechecker error message; see TypeRep.tidyTyVarBndr++We have to take care though! Consider a machine-generated module (#10370)+  module Foo where+     a1 = e1+     a2 = e2+     ...+     a2000 = e2000+Then "a1", "a2" etc are all marked taken.  But now if we come across "a7" again,+we have to do a linear search to find a free one, "a2001".  That might just be+acceptable once.  But if we now come across "a8" again, we don't want to repeat+that search.++So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for+starting the search; and we make sure to update the starting point for "a"+after we allocate a new one.+++Note [Tidying multiple names at once]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Consider++    > :t (id,id,id)++Every id contributes a type variable to the type signature, and all of them are+"a". If we tidy them one by one, we get++    (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a)++which is a bit unfortunate, as it unfairly renames only two of them. What we+would like to see is++    (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1)++To achieve this, the function avoidClashesOccEnv can be used to prepare the+TidyEnv, by “blocking” every name that occurs twice in the map. This way, none+of the "a"s will get the privilege of keeping this name, and all of them will+get a suitable number by tidyOccName.++This prepared TidyEnv can then be used with tidyOccName. See tidyTyCoVarBndrs+for an example where this is used.++This is #12382.++-}++type TidyOccEnv = UniqFM Int    -- The in-scope OccNames+  -- See Note [TidyOccEnv]++emptyTidyOccEnv :: TidyOccEnv+emptyTidyOccEnv = emptyUFM++initTidyOccEnv :: [OccName] -> TidyOccEnv       -- Initialise with names to avoid!+initTidyOccEnv = foldl' add emptyUFM+  where+    add env (OccName _ fs) = addToUFM env fs 1++delTidyOccEnvList :: TidyOccEnv -> [FastString] -> TidyOccEnv+delTidyOccEnvList = delListFromUFM++-- see Note [Tidying multiple names at once]+avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv+avoidClashesOccEnv env occs = go env emptyUFM occs+  where+    go env _        [] = env+    go env seenOnce ((OccName _ fs):occs)+      | fs `elemUFM` env      = go env seenOnce                  occs+      | fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce  occs+      | otherwise             = go env (addToUFM seenOnce fs ()) occs++tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)+tidyOccName env occ@(OccName occ_sp fs)+  | not (fs `elemUFM` env)+  = -- Desired OccName is free, so use it,+    -- and record in 'env' that it's no longer available+    (addToUFM env fs 1, occ)++  | otherwise+  = case lookupUFM env base1 of+       Nothing -> (addToUFM env base1 2, OccName occ_sp base1)+       Just n  -> find 1 n+  where+    base :: String  -- Drop trailing digits (see Note [TidyOccEnv])+    base  = dropWhileEndLE isDigit (unpackFS fs)+    base1 = mkFastString (base ++ "1")++    find !k !n+      = case lookupUFM env new_fs of+          Just {} -> find (k+1 :: Int) (n+k)+                       -- By using n+k, the n argument to find goes+                       --    1, add 1, add 2, add 3, etc which+                       -- moves at quadratic speed through a dense patch++          Nothing -> (new_env, OccName occ_sp new_fs)+       where+         new_fs = mkFastString (base ++ show n)+         new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1)+                     -- Update:  base1,  so that next time we'll start where we left off+                     --          new_fs, so that we know it is taken+                     -- If they are the same (n==1), the former wins+                     -- See Note [TidyOccEnv]+++{-+************************************************************************+*                                                                      *+                Binary instance+    Here rather than in GHC.Iface.Binary because OccName is abstract+*                                                                      *+************************************************************************+-}++instance Binary NameSpace where+    put_ bh VarName = do+            putByte bh 0+    put_ bh DataName = do+            putByte bh 1+    put_ bh TvName = do+            putByte bh 2+    put_ bh TcClsName = do+            putByte bh 3+    get bh = do+            h <- getByte bh+            case h of+              0 -> do return VarName+              1 -> do return DataName+              2 -> do return TvName+              _ -> do return TcClsName++instance Binary OccName where+    put_ bh (OccName aa ab) = do+            put_ bh aa+            put_ bh ab+    get bh = do+          aa <- get bh+          ab <- get bh+          return (OccName aa ab)
+ compiler/GHC/Types/Name/Occurrence.hs-boot view
@@ -0,0 +1,5 @@+module GHC.Types.Name.Occurrence where++import GhcPrelude ()++data OccName
+ compiler/GHC/Types/Name/Reader.hs view
@@ -0,0 +1,1387 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP, DeriveDataTypeable #-}++-- |+-- #name_types#+-- GHC uses several kinds of name internally:+--+-- * 'OccName.OccName': see "OccName#name_types"+--+-- * 'RdrName.RdrName' is the type of names that come directly from the parser. They+--   have not yet had their scoping and binding resolved by the renamer and can be+--   thought of to a first approximation as an 'OccName.OccName' with an optional module+--   qualifier+--+-- * 'Name.Name': see "Name#name_types"+--+-- * 'Id.Id': see "Id#name_types"+--+-- * 'Var.Var': see "Var#name_types"++module GHC.Types.Name.Reader (+        -- * The main type+        RdrName(..),    -- Constructors exported only to GHC.Iface.Binary++        -- ** Construction+        mkRdrUnqual, mkRdrQual,+        mkUnqual, mkVarUnqual, mkQual, mkOrig,+        nameRdrName, getRdrName,++        -- ** Destruction+        rdrNameOcc, rdrNameSpace, demoteRdrName,+        isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual,+        isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,++        -- * Local mapping of 'RdrName' to 'Name.Name'+        LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,+        lookupLocalRdrEnv, lookupLocalRdrOcc,+        elemLocalRdrEnv, inLocalRdrEnvScope,+        localRdrEnvElts, delLocalRdrEnvList,++        -- * Global mapping of 'RdrName' to 'GlobalRdrElt's+        GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,+        lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,+        pprGlobalRdrEnv, globalRdrEnvElts,+        lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel,+        lookupGRE_Name_OccName,+        getGRE_NameQualifier_maybes,+        transformGREs, pickGREs, pickGREsModExp,++        -- * GlobalRdrElts+        gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE,+        greRdrNames, greSrcSpan, greQualModName,+        gresToAvailInfo,++        -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'+        GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel,+        unQualOK, qualSpecOK, unQualSpecOK,+        pprNameProvenance,+        Parent(..), greParent_maybe,+        ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),+        importSpecLoc, importSpecModule, isExplicitItem, bestImport,++        -- * Utils for StarIsType+        starInfo+  ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Types.Module+import GHC.Types.Name+import GHC.Types.Avail+import GHC.Types.Name.Set+import Maybes+import GHC.Types.SrcLoc as SrcLoc+import FastString+import GHC.Types.FieldLabel+import Outputable+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import Util+import GHC.Types.Name.Env++import Data.Data+import Data.List( sortBy )++{-+************************************************************************+*                                                                      *+\subsection{The main data type}+*                                                                      *+************************************************************************+-}++-- | Reader Name+--+-- Do not use the data constructors of RdrName directly: prefer the family+-- of functions that creates them, such as 'mkRdrUnqual'+--+-- - Note: A Located RdrName will only have API Annotations if it is a+--         compound one,+--   e.g.+--+-- > `bar`+-- > ( ~ )+--+-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',+--           'ApiAnnotation.AnnOpen'  @'('@ or @'['@ or @'[:'@,+--           'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,,+--           'ApiAnnotation.AnnBackquote' @'`'@,+--           'ApiAnnotation.AnnVal'+--           'ApiAnnotation.AnnTilde',++-- For details on above see note [Api annotations] in ApiAnnotation+data RdrName+  = Unqual OccName+        -- ^ Unqualified  name+        --+        -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.+        -- Create such a 'RdrName' with 'mkRdrUnqual'++  | Qual ModuleName OccName+        -- ^ Qualified name+        --+        -- A qualified name written by the user in+        -- /source/ code.  The module isn't necessarily+        -- the module where the thing is defined;+        -- just the one from which it is imported.+        -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@.+        -- Create such a 'RdrName' with 'mkRdrQual'++  | Orig Module OccName+        -- ^ Original name+        --+        -- An original name; the module is the /defining/ module.+        -- This is used when GHC generates code that will be fed+        -- into the renamer (e.g. from deriving clauses), but where+        -- we want to say \"Use Prelude.map dammit\". One of these+        -- can be created with 'mkOrig'++  | Exact Name+        -- ^ Exact name+        --+        -- We know exactly the 'Name'. This is used:+        --+        --  (1) When the parser parses built-in syntax like @[]@+        --      and @(,)@, but wants a 'RdrName' from it+        --+        --  (2) By Template Haskell, when TH has generated a unique name+        --+        -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name'+  deriving Data++{-+************************************************************************+*                                                                      *+\subsection{Simple functions}+*                                                                      *+************************************************************************+-}++instance HasOccName RdrName where+  occName = rdrNameOcc++rdrNameOcc :: RdrName -> OccName+rdrNameOcc (Qual _ occ) = occ+rdrNameOcc (Unqual occ) = occ+rdrNameOcc (Orig _ occ) = occ+rdrNameOcc (Exact name) = nameOccName name++rdrNameSpace :: RdrName -> NameSpace+rdrNameSpace = occNameSpace . rdrNameOcc++-- demoteRdrName lowers the NameSpace of RdrName.+-- see Note [Demotion] in GHC.Types.Name.Occurrence+demoteRdrName :: RdrName -> Maybe RdrName+demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ)+demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ)+demoteRdrName (Orig _ _) = panic "demoteRdrName"+demoteRdrName (Exact _) = panic "demoteRdrName"++        -- These two are the basic constructors+mkRdrUnqual :: OccName -> RdrName+mkRdrUnqual occ = Unqual occ++mkRdrQual :: ModuleName -> OccName -> RdrName+mkRdrQual mod occ = Qual mod occ++mkOrig :: Module -> OccName -> RdrName+mkOrig mod occ = Orig mod occ++---------------+        -- These two are used when parsing source files+        -- They do encode the module and occurrence names+mkUnqual :: NameSpace -> FastString -> RdrName+mkUnqual sp n = Unqual (mkOccNameFS sp n)++mkVarUnqual :: FastString -> RdrName+mkVarUnqual n = Unqual (mkVarOccFS n)++-- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and+-- the 'OccName' are taken from the first and second elements of the tuple respectively+mkQual :: NameSpace -> (FastString, FastString) -> RdrName+mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n)++getRdrName :: NamedThing thing => thing -> RdrName+getRdrName name = nameRdrName (getName name)++nameRdrName :: Name -> RdrName+nameRdrName name = Exact name+-- Keep the Name even for Internal names, so that the+-- unique is still there for debug printing, particularly+-- of Types (which are converted to IfaceTypes before printing)++nukeExact :: Name -> RdrName+nukeExact n+  | isExternalName n = Orig (nameModule n) (nameOccName n)+  | otherwise        = Unqual (nameOccName n)++isRdrDataCon :: RdrName -> Bool+isRdrTyVar   :: RdrName -> Bool+isRdrTc      :: RdrName -> Bool++isRdrDataCon rn = isDataOcc (rdrNameOcc rn)+isRdrTyVar   rn = isTvOcc   (rdrNameOcc rn)+isRdrTc      rn = isTcOcc   (rdrNameOcc rn)++isSrcRdrName :: RdrName -> Bool+isSrcRdrName (Unqual _) = True+isSrcRdrName (Qual _ _) = True+isSrcRdrName _          = False++isUnqual :: RdrName -> Bool+isUnqual (Unqual _) = True+isUnqual _          = False++isQual :: RdrName -> Bool+isQual (Qual _ _) = True+isQual _          = False++isQual_maybe :: RdrName -> Maybe (ModuleName, OccName)+isQual_maybe (Qual m n) = Just (m,n)+isQual_maybe _          = Nothing++isOrig :: RdrName -> Bool+isOrig (Orig _ _) = True+isOrig _          = False++isOrig_maybe :: RdrName -> Maybe (Module, OccName)+isOrig_maybe (Orig m n) = Just (m,n)+isOrig_maybe _          = Nothing++isExact :: RdrName -> Bool+isExact (Exact _) = True+isExact _         = False++isExact_maybe :: RdrName -> Maybe Name+isExact_maybe (Exact n) = Just n+isExact_maybe _         = Nothing++{-+************************************************************************+*                                                                      *+\subsection{Instances}+*                                                                      *+************************************************************************+-}++instance Outputable RdrName where+    ppr (Exact name)   = ppr name+    ppr (Unqual occ)   = ppr occ+    ppr (Qual mod occ) = ppr mod <> dot <> ppr occ+    ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ)++instance OutputableBndr RdrName where+    pprBndr _ n+        | isTvOcc (rdrNameOcc n) = char '@' <> ppr n+        | otherwise              = ppr n++    pprInfixOcc  rdr = pprInfixVar  (isSymOcc (rdrNameOcc rdr)) (ppr rdr)+    pprPrefixOcc rdr+      | Just name <- isExact_maybe rdr = pprPrefixName name+             -- pprPrefixName has some special cases, so+             -- we delegate to them rather than reproduce them+      | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)++instance Eq RdrName where+    (Exact n1)    == (Exact n2)    = n1==n2+        -- Convert exact to orig+    (Exact n1)    == r2@(Orig _ _) = nukeExact n1 == r2+    r1@(Orig _ _) == (Exact n2)    = r1 == nukeExact n2++    (Orig m1 o1)  == (Orig m2 o2)  = m1==m2 && o1==o2+    (Qual m1 o1)  == (Qual m2 o2)  = m1==m2 && o1==o2+    (Unqual o1)   == (Unqual o2)   = o1==o2+    _             == _             = False++instance Ord RdrName where+    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }+    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }+    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }+    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }++        -- Exact < Unqual < Qual < Orig+        -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig+        --      before comparing so that Prelude.map == the exact Prelude.map, but+        --      that meant that we reported duplicates when renaming bindings+        --      generated by Template Haskell; e.g+        --      do { n1 <- newName "foo"; n2 <- newName "foo";+        --           <decl involving n1,n2> }+        --      I think we can do without this conversion+    compare (Exact n1) (Exact n2) = n1 `compare` n2+    compare (Exact _)  _          = LT++    compare (Unqual _)   (Exact _)    = GT+    compare (Unqual o1)  (Unqual  o2) = o1 `compare` o2+    compare (Unqual _)   _            = LT++    compare (Qual _ _)   (Exact _)    = GT+    compare (Qual _ _)   (Unqual _)   = GT+    compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2)+    compare (Qual _ _)   (Orig _ _)   = LT++    compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2)+    compare (Orig _ _)   _            = GT++{-+************************************************************************+*                                                                      *+                        LocalRdrEnv+*                                                                      *+************************************************************************+-}++-- | Local Reader Environment+--+-- This environment is used to store local bindings+-- (@let@, @where@, lambda, @case@).+-- It is keyed by OccName, because we never use it for qualified names+-- We keep the current mapping, *and* the set of all Names in scope+-- Reason: see Note [Splicing Exact names] in GHC.Rename.Env+data LocalRdrEnv = LRE { lre_env      :: OccEnv Name+                       , lre_in_scope :: NameSet }++instance Outputable LocalRdrEnv where+  ppr (LRE {lre_env = env, lre_in_scope = ns})+    = hang (text "LocalRdrEnv {")+         2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env+                 , text "in_scope ="+                    <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr)+                 ] <+> char '}')+    where+      ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name+                     -- So we can see if the keys line up correctly++emptyLocalRdrEnv :: LocalRdrEnv+emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv+                       , lre_in_scope = emptyNameSet }++extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv+-- The Name should be a non-top-level thing+extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name+  = WARN( isExternalName name, ppr name )+    lre { lre_env      = extendOccEnv env (nameOccName name) name+        , lre_in_scope = extendNameSet ns name }++extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv+extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names+  = WARN( any isExternalName names, ppr names )+    lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]+        , lre_in_scope = extendNameSetList ns names }++lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name+lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr+  | Unqual occ <- rdr+  = lookupOccEnv env occ++  -- See Note [Local bindings with Exact Names]+  | Exact name <- rdr+  , name `elemNameSet` ns+  = Just name++  | otherwise+  = Nothing++lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name+lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ++elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool+elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns })+  = case rdr_name of+      Unqual occ -> occ  `elemOccEnv` env+      Exact name -> name `elemNameSet` ns  -- See Note [Local bindings with Exact Names]+      Qual {} -> False+      Orig {} -> False++localRdrEnvElts :: LocalRdrEnv -> [Name]+localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env++inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool+-- This is the point of the NameSet+inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns++delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv+delLocalRdrEnvList lre@(LRE { lre_env = env }) occs+  = lre { lre_env = delListFromOccEnv env occs }++{-+Note [Local bindings with Exact Names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With Template Haskell we can make local bindings that have Exact Names.+Computing shadowing etc may use elemLocalRdrEnv (at least it certainly+does so in GHC.Rename.Types.bindHsQTyVars), so for an Exact Name we must consult+the in-scope-name-set.+++************************************************************************+*                                                                      *+                        GlobalRdrEnv+*                                                                      *+************************************************************************+-}++-- | Global Reader Environment+type GlobalRdrEnv = OccEnv [GlobalRdrElt]+-- ^ Keyed by 'OccName'; when looking up a qualified name+-- we look up the 'OccName' part, and then check the 'Provenance'+-- to see if the appropriate qualification is valid.  This+-- saves routinely doubling the size of the env by adding both+-- qualified and unqualified names to the domain.+--+-- The list in the codomain is required because there may be name clashes+-- These only get reported on lookup, not on construction+--+-- INVARIANT 1: All the members of the list have distinct+--              'gre_name' fields; that is, no duplicate Names+--+-- INVARIANT 2: Imported provenance => Name is an ExternalName+--              However LocalDefs can have an InternalName.  This+--              happens only when type-checking a [d| ... |] Template+--              Haskell quotation; see this note in GHC.Rename.Names+--              Note [Top-level Names in Template Haskell decl quotes]+--+-- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then+--                 greOccName gre = occ+--+--              NB: greOccName gre is usually the same as+--                  nameOccName (gre_name gre), but not always in the+--                  case of record selectors; see greOccName++-- | Global Reader Element+--+-- An element of the 'GlobalRdrEnv'+data GlobalRdrElt+  = GRE { gre_name :: Name+        , gre_par  :: Parent+        , gre_lcl :: Bool          -- ^ True <=> the thing was defined locally+        , gre_imp :: [ImportSpec]  -- ^ In scope through these imports+    } deriving (Data, Eq)+         -- INVARIANT: either gre_lcl = True or gre_imp is non-empty+         -- See Note [GlobalRdrElt provenance]++-- | The children of a Name are the things that are abbreviated by the ".."+--   notation in export lists.  See Note [Parents]+data Parent = NoParent+            | ParentIs  { par_is :: Name }+            | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }+              -- ^ See Note [Parents for record fields]+            deriving (Eq, Data)++instance Outputable Parent where+   ppr NoParent        = empty+   ppr (ParentIs n)    = text "parent:" <> ppr n+   ppr (FldParent n f) = text "fldparent:"+                             <> ppr n <> colon <> ppr f++plusParent :: Parent -> Parent -> Parent+-- See Note [Combining parents]+plusParent p1@(ParentIs _)    p2 = hasParent p1 p2+plusParent p1@(FldParent _ _) p2 = hasParent p1 p2+plusParent p1 p2@(ParentIs _)    = hasParent p2 p1+plusParent p1 p2@(FldParent _ _) = hasParent p2 p1+plusParent _ _                   = NoParent++hasParent :: Parent -> Parent -> Parent+#if defined(DEBUG)+hasParent p NoParent = p+hasParent p p'+  | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p')  -- Parents should agree+#endif+hasParent p _  = p+++{- Note [GlobalRdrElt provenance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance",+i.e. how the Name came to be in scope.  It can be in scope two ways:+  - gre_lcl = True: it is bound in this module+  - gre_imp: a list of all the imports that brought it into scope++It's an INVARIANT that you have one or the other; that is, either+gre_lcl is True, or gre_imp is non-empty.++It is just possible to have *both* if there is a module loop: a Name+is defined locally in A, and also brought into scope by importing a+module that SOURCE-imported A.  Example (#7672):++ A.hs-boot   module A where+               data T++ B.hs        module B(Decl.T) where+               import {-# SOURCE #-} qualified A as Decl++ A.hs        module A where+               import qualified B+               data T = Z | S B.T++In A.hs, 'T' is locally bound, *and* imported as B.T.++Note [Parents]+~~~~~~~~~~~~~~~~~+  Parent           Children+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  data T           Data constructors+                   Record-field ids++  data family T    Data constructors and record-field ids+                   of all visible data instances of T++  class C          Class operations+                   Associated type constructors++~~~~~~~~~~~~~~~~~~~~~~~~~+ Constructor      Meaning+ ~~~~~~~~~~~~~~~~~~~~~~~~+  NoParent        Can not be bundled with a type constructor.+  ParentIs n      Can be bundled with the type constructor corresponding to+                  n.+  FldParent       See Note [Parents for record fields]+++++Note [Parents for record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For record fields, in addition to the Name of the type constructor+(stored in par_is), we use FldParent to store the field label.  This+extra information is used for identifying overloaded record fields+during renaming.++In a definition arising from a normal module (without+-XDuplicateRecordFields), par_lbl will be Nothing, meaning that the+field's label is the same as the OccName of the selector's Name.  The+GlobalRdrEnv will contain an entry like this:++    "x" |->  GRE x (FldParent T Nothing) LocalDef++When -XDuplicateRecordFields is enabled for the module that contains+T, the selector's Name will be mangled (see comments in GHC.Types.FieldLabel).+Thus we store the actual field label in par_lbl, and the GlobalRdrEnv+entry looks like this:++    "x" |->  GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef++Note that the OccName used when adding a GRE to the environment+(greOccName) now depends on the parent field: for FldParent it is the+field label, if present, rather than the selector name.++~~++Record pattern synonym selectors are treated differently. Their parent+information is `NoParent` in the module in which they are defined. This is because+a pattern synonym `P` has no parent constructor either.++However, if `f` is bundled with a type constructor `T` then whenever `f` is+imported the parent will use the `Parent` constructor so the parent of `f` is+now `T`.+++Note [Combining parents]+~~~~~~~~~~~~~~~~~~~~~~~~+With an associated type we might have+   module M where+     class C a where+       data T a+       op :: T a -> a+     instance C Int where+       data T Int = TInt+     instance C Bool where+       data T Bool = TBool++Then:   C is the parent of T+        T is the parent of TInt and TBool+So: in an export list+    C(..) is short for C( op, T )+    T(..) is short for T( TInt, TBool )++Module M exports everything, so its exports will be+   AvailTC C [C,T,op]+   AvailTC T [T,TInt,TBool]+On import we convert to GlobalRdrElt and then combine+those.  For T that will mean we have+  one GRE with Parent C+  one GRE with NoParent+That's why plusParent picks the "best" case.+-}++-- | make a 'GlobalRdrEnv' where all the elements point to the same+-- Provenance (useful for "hiding" imports, or imports with no details).+gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]+-- prov = Nothing   => locally bound+--        Just spec => imported as described by spec+gresFromAvails prov avails+  = concatMap (gresFromAvail (const prov)) avails++localGREsFromAvail :: AvailInfo -> [GlobalRdrElt]+-- Turn an Avail into a list of LocalDef GlobalRdrElts+localGREsFromAvail = gresFromAvail (const Nothing)++gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt]+gresFromAvail prov_fn avail+  = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail)+  where+    mk_gre n+      = case prov_fn n of  -- Nothing => bound locally+                           -- Just is => imported from 'is'+          Nothing -> GRE { gre_name = n, gre_par = mkParent n avail+                         , gre_lcl = True, gre_imp = [] }+          Just is -> GRE { gre_name = n, gre_par = mkParent n avail+                         , gre_lcl = False, gre_imp = [is] }++    mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded+                           , flSelector = n })+      = case prov_fn n of  -- Nothing => bound locally+                           -- Just is => imported from 'is'+          Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl+                         , gre_lcl = True, gre_imp = [] }+          Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl+                         , gre_lcl = False, gre_imp = [is] }+      where+        mb_lbl | is_overloaded = Just lbl+               | otherwise     = Nothing+++greQualModName :: GlobalRdrElt -> ModuleName+-- Get a suitable module qualifier for the GRE+-- (used in mkPrintUnqualified)+-- Prerecondition: the gre_name is always External+greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })+ | lcl, Just mod <- nameModule_maybe name = moduleName mod+ | (is:_) <- iss                          = is_as (is_decl is)+ | otherwise                              = pprPanic "greQualModName" (ppr gre)++greRdrNames :: GlobalRdrElt -> [RdrName]+greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss }+  = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss)+  where+    occ    = greOccName gre+    unqual = Unqual occ+    do_spec decl_spec+        | is_qual decl_spec = [qual]+        | otherwise         = [unqual,qual]+        where qual = Qual (is_as decl_spec) occ++-- the SrcSpan that pprNameProvenance prints out depends on whether+-- the Name is defined locally or not: for a local definition the+-- definition site is used, otherwise the location of the import+-- declaration.  We want to sort the export locations in+-- exportClashErr by this SrcSpan, we need to extract it:+greSrcSpan :: GlobalRdrElt -> SrcSpan+greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )+  | lcl           = nameSrcSpan name+  | (is:_) <- iss = is_dloc (is_decl is)+  | otherwise     = pprPanic "greSrcSpan" (ppr gre)++mkParent :: Name -> AvailInfo -> Parent+mkParent _ (Avail _)           = NoParent+mkParent n (AvailTC m _ _) | n == m    = NoParent+                         | otherwise = ParentIs m++greParent_maybe :: GlobalRdrElt -> Maybe Name+greParent_maybe gre = case gre_par gre of+                        NoParent      -> Nothing+                        ParentIs n    -> Just n+                        FldParent n _ -> Just n++-- | Takes a list of distinct GREs and folds them+-- into AvailInfos. This is more efficient than mapping each individual+-- GRE to an AvailInfo and the folding using `plusAvail` but needs the+-- uniqueness assumption.+gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo]+gresToAvailInfo gres+  = nameEnvElts avail_env+  where+    avail_env :: NameEnv AvailInfo -- Keyed by the parent+    (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres++    add :: (NameEnv AvailInfo, NameSet)+        -> GlobalRdrElt+        -> (NameEnv AvailInfo, NameSet)+    add (env, done) gre+      | name `elemNameSet` done+      = (env, done)  -- Don't insert twice into the AvailInfo+      | otherwise+      = ( extendNameEnv_Acc comb availFromGRE env key gre+        , done `extendNameSet` name )+      where+        name = gre_name gre+        key = case greParent_maybe gre of+                 Just parent -> parent+                 Nothing     -> gre_name gre++        -- We want to insert the child `k` into a list of children but+        -- need to maintain the invariant that the parent is first.+        --+        -- We also use the invariant that `k` is not already in `ns`.+        insertChildIntoChildren :: Name -> [Name] -> Name -> [Name]+        insertChildIntoChildren _ [] k = [k]+        insertChildIntoChildren p (n:ns) k+          | p == k = k:n:ns+          | otherwise = n:k:ns++        comb :: GlobalRdrElt -> AvailInfo -> AvailInfo+        comb _ (Avail n) = Avail n -- Duplicated name, should not happen+        comb gre (AvailTC m ns fls)+          = case gre_par gre of+              NoParent    -> AvailTC m (name:ns) fls -- Not sure this ever happens+              ParentIs {} -> AvailTC m (insertChildIntoChildren m ns name) fls+              FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel name mb_lbl : fls)++availFromGRE :: GlobalRdrElt -> AvailInfo+availFromGRE (GRE { gre_name = me, gre_par = parent })+  = case parent of+      ParentIs p                  -> AvailTC p [me] []+      NoParent   | isTyConName me -> AvailTC me [me] []+                 | otherwise      -> avail   me+      FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl]++mkFieldLabel :: Name -> Maybe FastString -> FieldLabel+mkFieldLabel me mb_lbl =+          case mb_lbl of+                 Nothing  -> FieldLabel { flLabel = occNameFS (nameOccName me)+                                        , flIsOverloaded = False+                                        , flSelector = me }+                 Just lbl -> FieldLabel { flLabel = lbl+                                        , flIsOverloaded = True+                                        , flSelector = me }++emptyGlobalRdrEnv :: GlobalRdrEnv+emptyGlobalRdrEnv = emptyOccEnv++globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt]+globalRdrEnvElts env = foldOccEnv (++) [] env++instance Outputable GlobalRdrElt where+  ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre))+               2 (pprNameProvenance gre)++pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc+pprGlobalRdrEnv locals_only env+  = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)"))+             <+> lbrace+         , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ]+             <+> rbrace) ]+  where+    remove_locals gres | locals_only = filter isLocalGRE gres+                       | otherwise   = gres+    pp []   = empty+    pp gres = hang (ppr occ+                     <+> parens (text "unique" <+> ppr (getUnique occ))+                     <> colon)+                 2 (vcat (map ppr gres))+      where+        occ = nameOccName (gre_name (head gres))++lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt]+lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of+                                  Nothing   -> []+                                  Just gres -> gres++greOccName :: GlobalRdrElt -> OccName+greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl+greOccName gre                                            = nameOccName (gre_name gre)++lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]+lookupGRE_RdrName rdr_name env+  = case lookupOccEnv env (rdrNameOcc rdr_name) of+    Nothing   -> []+    Just gres -> pickGREs rdr_name gres++lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt+-- ^ Look for precisely this 'Name' in the environment.  This tests+-- whether it is in scope, ignoring anything else that might be in+-- scope with the same 'OccName'.+lookupGRE_Name env name+  = lookupGRE_Name_OccName env name (nameOccName name)++lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt+-- ^ Look for a particular record field selector in the environment, where the+-- selector name and field label may be different: the GlobalRdrEnv is keyed on+-- the label.  See Note [Parents for record fields] for why this happens.+lookupGRE_FieldLabel env fl+  = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl))++lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt+-- ^ Look for precisely this 'Name' in the environment, but with an 'OccName'+-- that might differ from that of the 'Name'.  See 'lookupGRE_FieldLabel' and+-- Note [Parents for record fields].+lookupGRE_Name_OccName env name occ+  = case [ gre | gre <- lookupGlobalRdrEnv env occ+               , gre_name gre == name ] of+      []    -> Nothing+      [gre] -> Just gre+      gres  -> pprPanic "lookupGRE_Name_OccName"+                        (ppr name $$ ppr occ $$ ppr gres)+               -- See INVARIANT 1 on GlobalRdrEnv+++getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]]+-- Returns all the qualifiers by which 'x' is in scope+-- Nothing means "the unqualified version is in scope"+-- [] means the thing is not in scope at all+getGRE_NameQualifier_maybes env name+  = case lookupGRE_Name env name of+      Just gre -> [qualifier_maybe gre]+      Nothing  -> []+  where+    qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss })+      | lcl       = Nothing+      | otherwise = Just $ map (is_as . is_decl) iss++isLocalGRE :: GlobalRdrElt -> Bool+isLocalGRE (GRE {gre_lcl = lcl }) = lcl++isRecFldGRE :: GlobalRdrElt -> Bool+isRecFldGRE (GRE {gre_par = FldParent{}}) = True+isRecFldGRE _                             = False++-- Returns the field label of this GRE, if it has one+greLabel :: GlobalRdrElt -> Maybe FieldLabelString+greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl+greLabel (GRE{gre_name = n, gre_par = FldParent{}})     = Just (occNameFS (nameOccName n))+greLabel _                                              = Nothing++unQualOK :: GlobalRdrElt -> Bool+-- ^ Test if an unqualified version of this thing would be in scope+unQualOK (GRE {gre_lcl = lcl, gre_imp = iss })+  | lcl = True+  | otherwise = any unQualSpecOK iss++{- Note [GRE filtering]+~~~~~~~~~~~~~~~~~~~~~~~+(pickGREs rdr gres) takes a list of GREs which have the same OccName+as 'rdr', say "x".  It does two things:++(a) filters the GREs to a subset that are in scope+    * Qualified,   as 'M.x'  if want_qual    is Qual M _+    * Unqualified, as 'x'    if want_unqual  is Unqual _++(b) for that subset, filter the provenance field (gre_lcl and gre_imp)+    to ones that brought it into scope qualified or unqualified resp.++Example:+      module A ( f ) where+      import qualified Foo( f )+      import Baz( f )+      f = undefined++Let's suppose that Foo.f and Baz.f are the same entity really, but the local+'f' is different, so there will be two GREs matching "f":+   gre1:  gre_lcl = True,  gre_imp = []+   gre2:  gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ]++The use of "f" in the export list is ambiguous because it's in scope+from the local def and the import Baz(f); but *not* the import qualified Foo.+pickGREs returns two GRE+   gre1:   gre_lcl = True,  gre_imp = []+   gre2:   gre_lcl = False, gre_imp = [ imported from Bar ]++Now the "ambiguous occurrence" message can correctly report how the+ambiguity arises.+-}++pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt]+-- ^ Takes a list of GREs which have the right OccName 'x'+-- Pick those GREs that are in scope+--    * Qualified,   as 'M.x'  if want_qual    is Qual M _+--    * Unqualified, as 'x'    if want_unqual  is Unqual _+--+-- Return each such GRE, with its ImportSpecs filtered, to reflect+-- how it is in scope qualified or unqualified respectively.+-- See Note [GRE filtering]+pickGREs (Unqual {})  gres = mapMaybe pickUnqualGRE     gres+pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres+pickGREs _            _    = []  -- I don't think this actually happens++pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt+pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss })+  | not lcl, null iss' = Nothing+  | otherwise          = Just (gre { gre_imp = iss' })+  where+    iss' = filter unQualSpecOK iss++pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt+pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss })+  | not lcl', null iss' = Nothing+  | otherwise           = Just (gre { gre_lcl = lcl', gre_imp = iss' })+  where+    iss' = filter (qualSpecOK mod) iss+    lcl' = lcl && name_is_from mod n++    name_is_from :: ModuleName -> Name -> Bool+    name_is_from mod name = case nameModule_maybe name of+                              Just n_mod -> moduleName n_mod == mod+                              Nothing    -> False++pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)]+-- ^ Pick GREs that are in scope *both* qualified *and* unqualified+-- Return each GRE that is, as a pair+--    (qual_gre, unqual_gre)+-- These two GREs are the original GRE with imports filtered to express how+-- it is in scope qualified an unqualified respectively+--+-- Used only for the 'module M' item in export list;+--   see GHC.Rename.Names.exports_from_avail+pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres++pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt)+pickBothGRE mod gre@(GRE { gre_name = n })+  | isBuiltInSyntax n                = Nothing+  | Just gre1 <- pickQualGRE mod gre+  , Just gre2 <- pickUnqualGRE   gre = Just (gre1, gre2)+  | otherwise                        = Nothing+  where+        -- isBuiltInSyntax filter out names for built-in syntax They+        -- just clutter up the environment (esp tuples), and the+        -- parser will generate Exact RdrNames for them, so the+        -- cluttered envt is no use.  Really, it's only useful for+        -- GHC.Base and GHC.Tuple.++-- Building GlobalRdrEnvs++plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv+plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2++mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv+mkGlobalRdrEnv gres+  = foldr add emptyGlobalRdrEnv gres+  where+    add gre env = extendOccEnv_Acc insertGRE singleton env+                                   (greOccName gre)+                                   gre++insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt]+insertGRE new_g [] = [new_g]+insertGRE new_g (old_g : old_gs)+        | gre_name new_g == gre_name old_g+        = new_g `plusGRE` old_g : old_gs+        | otherwise+        = old_g : insertGRE new_g old_gs++plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt+-- Used when the gre_name fields match+plusGRE g1 g2+  = GRE { gre_name = gre_name g1+        , gre_lcl  = gre_lcl g1 || gre_lcl g2+        , gre_imp  = gre_imp g1 ++ gre_imp g2+        , gre_par  = gre_par  g1 `plusParent` gre_par  g2 }++transformGREs :: (GlobalRdrElt -> GlobalRdrElt)+              -> [OccName]+              -> GlobalRdrEnv -> GlobalRdrEnv+-- ^ Apply a transformation function to the GREs for these OccNames+transformGREs trans_gre occs rdr_env+  = foldr trans rdr_env occs+  where+    trans occ env+      = case lookupOccEnv env occ of+           Just gres -> extendOccEnv env occ (map trans_gre gres)+           Nothing   -> env++extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv+extendGlobalRdrEnv env gre+  = extendOccEnv_Acc insertGRE singleton env+                     (greOccName gre) gre++shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv+shadowNames = foldl' shadowName++{- Note [GlobalRdrEnv shadowing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before adding new names to the GlobalRdrEnv we nuke some existing entries;+this is "shadowing".  The actual work is done by RdrEnv.shadowName.+Suppose+   env' = shadowName env M.f++Then:+   * Looking up (Unqual f) in env' should succeed, returning M.f,+     even if env contains existing unqualified bindings for f.+     They are shadowed++   * Looking up (Qual M.f) in env' should succeed, returning M.f++   * Looking up (Qual X.f) in env', where X /= M, should be the same as+     looking up (Qual X.f) in env.+     That is, shadowName does /not/ delete earlier qualified bindings++There are two reasons for shadowing:++* The GHCi REPL++  - Ids bought into scope on the command line (eg let x = True) have+    External Names, like Ghci4.x.  We want a new binding for 'x' (say)+    to override the existing binding for 'x'.  Example:++           ghci> :load M    -- Brings `x` and `M.x` into scope+           ghci> x+           ghci> "Hello"+           ghci> M.x+           ghci> "hello"+           ghci> let x = True  -- Shadows `x`+           ghci> x             -- The locally bound `x`+                               -- NOT an ambiguous reference+           ghci> True+           ghci> M.x           -- M.x is still in scope!+           ghci> "Hello"+    So when we add `x = True` we must not delete the `M.x` from the+    `GlobalRdrEnv`; rather we just want to make it "qualified only";+    hence the `mk_fake-imp_spec` in `shadowName`.  See also Note+    [Interactively-bound Ids in GHCi] in GHC.Driver.Types++  - Data types also have External Names, like Ghci4.T; but we still want+    'T' to mean the newly-declared 'T', not an old one.++* Nested Template Haskell declaration brackets+  See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names++  Consider a TH decl quote:+      module M where+        f x = h [d| f = ...f...M.f... |]+  We must shadow the outer unqualified binding of 'f', else we'll get+  a complaint when extending the GlobalRdrEnv, saying that there are+  two bindings for 'f'.  There are several tricky points:++    - This shadowing applies even if the binding for 'f' is in a+      where-clause, and hence is in the *local* RdrEnv not the *global*+      RdrEnv.  This is done in lcl_env_TH in extendGlobalRdrEnvRn.++    - The External Name M.f from the enclosing module must certainly+      still be available.  So we don't nuke it entirely; we just make+      it seem like qualified import.++    - We only shadow *External* names (which come from the main module),+      or from earlier GHCi commands. Do not shadow *Internal* names+      because in the bracket+          [d| class C a where f :: a+              f = 4 |]+      rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the+      class decl, and *separately* extend the envt with the value binding.+      At that stage, the class op 'f' will have an Internal name.+-}++shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv+-- Remove certain old GREs that share the same OccName as this new Name.+-- See Note [GlobalRdrEnv shadowing] for details+shadowName env name+  = alterOccEnv (fmap alter_fn) env (nameOccName name)+  where+    alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt]+    alter_fn gres = mapMaybe (shadow_with name) gres++    shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt+    shadow_with new_name+       old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss })+       = case nameModule_maybe old_name of+           Nothing -> Just old_gre   -- Old name is Internal; do not shadow+           Just old_mod+              | Just new_mod <- nameModule_maybe new_name+              , new_mod == old_mod   -- Old name same as new name; shadow completely+              -> Nothing++              | null iss'            -- Nothing remains+              -> Nothing++              | otherwise+              -> Just (old_gre { gre_lcl = False, gre_imp = iss' })++              where+                iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss+                lcl_imp | lcl       = [mk_fake_imp_spec old_name old_mod]+                        | otherwise = []++    mk_fake_imp_spec old_name old_mod    -- Urgh!+      = ImpSpec id_spec ImpAll+      where+        old_mod_name = moduleName old_mod+        id_spec      = ImpDeclSpec { is_mod = old_mod_name+                                   , is_as = old_mod_name+                                   , is_qual = True+                                   , is_dloc = nameSrcSpan old_name }++    shadow_is :: Name -> ImportSpec -> Maybe ImportSpec+    shadow_is new_name is@(ImpSpec { is_decl = id_spec })+       | Just new_mod <- nameModule_maybe new_name+       , is_as id_spec == moduleName new_mod+       = Nothing   -- Shadow both qualified and unqualified+       | otherwise -- Shadow unqualified only+       = Just (is { is_decl = id_spec { is_qual = True } })+++{-+************************************************************************+*                                                                      *+                        ImportSpec+*                                                                      *+************************************************************************+-}++-- | Import Specification+--+-- The 'ImportSpec' of something says how it came to be imported+-- It's quite elaborate so that we can give accurate unused-name warnings.+data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec,+                            is_item :: ImpItemSpec }+                deriving( Eq, Data )++-- | Import Declaration Specification+--+-- Describes a particular import declaration and is+-- shared among all the 'Provenance's for that decl+data ImpDeclSpec+  = ImpDeclSpec {+        is_mod      :: ModuleName, -- ^ Module imported, e.g. @import Muggle@+                                   -- Note the @Muggle@ may well not be+                                   -- the defining module for this thing!++                                   -- TODO: either should be Module, or there+                                   -- should be a Maybe UnitId here too.+        is_as       :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause)+        is_qual     :: Bool,       -- ^ Was this import qualified?+        is_dloc     :: SrcSpan     -- ^ The location of the entire import declaration+    } deriving (Eq, Data)++-- | Import Item Specification+--+-- Describes import info a particular Name+data ImpItemSpec+  = ImpAll              -- ^ The import had no import list,+                        -- or had a hiding list++  | ImpSome {+        is_explicit :: Bool,+        is_iloc     :: SrcSpan  -- Location of the import item+    }   -- ^ The import had an import list.+        -- The 'is_explicit' field is @True@ iff the thing was named+        -- /explicitly/ in the import specs rather+        -- than being imported as part of a "..." group. Consider:+        --+        -- > import C( T(..) )+        --+        -- Here the constructors of @T@ are not named explicitly;+        -- only @T@ is named explicitly.+  deriving (Eq, Data)++bestImport :: [ImportSpec] -> ImportSpec+-- See Note [Choosing the best import declaration]+bestImport iss+  = case sortBy best iss of+      (is:_) -> is+      []     -> pprPanic "bestImport" (ppr iss)+  where+    best :: ImportSpec -> ImportSpec -> Ordering+    -- Less means better+    -- Unqualified always wins over qualified; then+    -- import-all wins over import-some; then+    -- earlier declaration wins over later+    best (ImpSpec { is_item = item1, is_decl = d1 })+         (ImpSpec { is_item = item2, is_decl = d2 })+      = (is_qual d1 `compare` is_qual d2) `thenCmp`+        (best_item item1 item2)           `thenCmp`+        SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2)++    best_item :: ImpItemSpec -> ImpItemSpec -> Ordering+    best_item ImpAll ImpAll = EQ+    best_item ImpAll (ImpSome {}) = LT+    best_item (ImpSome {}) ImpAll = GT+    best_item (ImpSome { is_explicit = e1 })+              (ImpSome { is_explicit = e2 }) = e1 `compare` e2+     -- False < True, so if e1 is explicit and e2 is not, we get GT++{- Note [Choosing the best import declaration]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When reporting unused import declarations we use the following rules.+   (see [wiki:commentary/compiler/unused-imports])++Say that an import-item is either+  * an entire import-all decl (eg import Foo), or+  * a particular item in an import list (eg import Foo( ..., x, ...)).+The general idea is that for each /occurrence/ of an imported name, we will+attribute that use to one import-item. Once we have processed all the+occurrences, any import items with no uses attributed to them are unused,+and are warned about. More precisely:++1. For every RdrName in the program text, find its GlobalRdrElt.++2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one+   the "chosen import-item", and mark it "used". This is done+   by 'bestImport'++3. After processing all the RdrNames, bleat about any+   import-items that are unused.+   This is done in GHC.Rename.Names.warnUnusedImportDecls.++The function 'bestImport' returns the dominant import among the+ImportSpecs it is given, implementing Step 2.  We say import-item A+dominates import-item B if we choose A over B. In general, we try to+choose the import that is most likely to render other imports+unnecessary.  Here is the dominance relationship we choose:++    a) import Foo dominates import qualified Foo.++    b) import Foo dominates import Foo(x).++    c) Otherwise choose the textually first one.++Rationale for (a).  Consider+   import qualified M  -- Import #1+   import M( x )       -- Import #2+   foo = M.x + x++The unqualified 'x' can only come from import #2.  The qualified 'M.x'+could come from either, but bestImport picks import #2, because it is+more likely to be useful in other imports, as indeed it is in this+case (see #5211 for a concrete example).++But the rules are not perfect; consider+   import qualified M  -- Import #1+   import M( x )       -- Import #2+   foo = M.x + M.y++The M.x will use import #2, but M.y can only use import #1.+-}+++unQualSpecOK :: ImportSpec -> Bool+-- ^ Is in scope unqualified?+unQualSpecOK is = not (is_qual (is_decl is))++qualSpecOK :: ModuleName -> ImportSpec -> Bool+-- ^ Is in scope qualified with the given module?+qualSpecOK mod is = mod == is_as (is_decl is)++importSpecLoc :: ImportSpec -> SrcSpan+importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl+importSpecLoc (ImpSpec _    item)   = is_iloc item++importSpecModule :: ImportSpec -> ModuleName+importSpecModule is = is_mod (is_decl is)++isExplicitItem :: ImpItemSpec -> Bool+isExplicitItem ImpAll                        = False+isExplicitItem (ImpSome {is_explicit = exp}) = exp++pprNameProvenance :: GlobalRdrElt -> SDoc+-- ^ Print out one place where the name was define/imported+-- (With -dppr-debug, print them all)+pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })+  = ifPprDebug (vcat pp_provs)+               (head pp_provs)+  where+    pp_provs = pp_lcl ++ map pp_is iss+    pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)]+                    else []+    pp_is is = sep [ppr is, ppr_defn_site is name]++-- If we know the exact definition point (which we may do with GHCi)+-- then show that too.  But not if it's just "imported from X".+ppr_defn_site :: ImportSpec -> Name -> SDoc+ppr_defn_site imp_spec name+  | same_module && not (isGoodSrcSpan loc)+  = empty              -- Nothing interesting to say+  | otherwise+  = parens $ hang (text "and originally defined" <+> pp_mod)+                2 (pprLoc loc)+  where+    loc = nameSrcSpan name+    defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name+    same_module = importSpecModule imp_spec == moduleName defining_mod+    pp_mod | same_module = empty+           | otherwise   = text "in" <+> quotes (ppr defining_mod)+++instance Outputable ImportSpec where+   ppr imp_spec+     = text "imported" <+> qual+        <+> text "from" <+> quotes (ppr (importSpecModule imp_spec))+        <+> pprLoc (importSpecLoc imp_spec)+     where+       qual | is_qual (is_decl imp_spec) = text "qualified"+            | otherwise                  = empty++pprLoc :: SrcSpan -> SDoc+pprLoc (RealSrcSpan s _)  = text "at" <+> ppr s+pprLoc (UnhelpfulSpan {}) = empty++-- | Display info about the treatment of '*' under NoStarIsType.+--+-- With StarIsType, three properties of '*' hold:+--+--   (a) it is not an infix operator+--   (b) it is always in scope+--   (c) it is a synonym for Data.Kind.Type+--+-- However, the user might not know that he's working on a module with+-- NoStarIsType and write code that still assumes (a), (b), and (c), which+-- actually do not hold in that module.+--+-- Violation of (a) shows up in the parser. For instance, in the following+-- examples, we have '*' not applied to enough arguments:+--+--   data A :: *+--   data F :: * -> *+--+-- Violation of (b) or (c) show up in the renamer and the typechecker+-- respectively. For instance:+--+--   type K = Either * Bool+--+-- This will parse differently depending on whether StarIsType is enabled,+-- but it will parse nonetheless. With NoStarIsType it is parsed as a type+-- operator, thus we have ((*) Either Bool). Now there are two cases to+-- consider:+--+--   1. There is no definition of (*) in scope. In this case the renamer will+--      fail to look it up. This is a violation of assumption (b).+--+--   2. There is a definition of the (*) type operator in scope (for example+--      coming from GHC.TypeNats). In this case the user will get a kind+--      mismatch error. This is a violation of assumption (c).+--+-- The user might unknowingly be working on a module with NoStarIsType+-- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a+-- hint whenever an assumption about '*' is violated. Unfortunately, it is+-- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b).+--+-- 'starInfo' generates an appropriate hint to the user depending on the+-- extensions enabled in the module and the name that triggered the error.+-- That is, if we have NoStarIsType and the error is related to '*' or its+-- Unicode variant, the resulting SDoc will contain a helpful suggestion.+-- Otherwise it is empty.+--+starInfo :: Bool -> RdrName -> SDoc+starInfo star_is_type rdr_name =+  -- One might ask: if can use `sdocOption sdocStarIsType` here, why bother to+  -- take star_is_type as input? Why not refactor?+  --+  -- The reason is that `sdocOption sdocStarIsType` would indicate that+  -- StarIsType is enabled in the module that tries to load the problematic+  -- definition, not in the module that is being loaded.+  --+  -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint+  -- must be displayed even if we load this definition from a module (or GHCi)+  -- with StarIsType enabled!+  --+  if isUnqualStar && not star_is_type+     then text "With NoStarIsType, " <>+          quotes (ppr rdr_name) <>+          text " is treated as a regular type operator. "+        $$+          text "Did you mean to use " <> quotes (text "Type") <>+          text " from Data.Kind instead?"+      else empty+  where+    -- Does rdr_name look like the user might have meant the '*' kind by it?+    -- We focus on unqualified stars specifically, because qualified stars are+    -- treated as type operators even under StarIsType.+    isUnqualStar+      | Unqual occName <- rdr_name+      = let fs = occNameFS occName+        in fs == fsLit "*" || fs == fsLit "★"+      | otherwise = False
+ compiler/GHC/Types/Name/Set.hs view
@@ -0,0 +1,215 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998+-}++{-# LANGUAGE CPP #-}+module GHC.Types.Name.Set (+        -- * Names set type+        NameSet,++        -- ** Manipulating these sets+        emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets,+        minusNameSet, elemNameSet, extendNameSet, extendNameSetList,+        delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet,+        intersectsNameSet, intersectNameSet,+        nameSetAny, nameSetAll, nameSetElemsStable,++        -- * Free variables+        FreeVars,++        -- ** Manipulating sets of free variables+        isEmptyFVs, emptyFVs, plusFVs, plusFV,+        mkFVs, addOneFV, unitFV, delFV, delFVs,+        intersectFVs,++        -- * Defs and uses+        Defs, Uses, DefUse, DefUses,++        -- ** Manipulating defs and uses+        emptyDUs, usesOnly, mkDUs, plusDU,+        findUses, duDefs, duUses, allUses+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Types.Name+import OrdList+import GHC.Types.Unique.Set+import Data.List (sortBy)++{-+************************************************************************+*                                                                      *+\subsection[Sets of names}+*                                                                      *+************************************************************************+-}++type NameSet = UniqSet Name++emptyNameSet       :: NameSet+unitNameSet        :: Name -> NameSet+extendNameSetList   :: NameSet -> [Name] -> NameSet+extendNameSet    :: NameSet -> Name -> NameSet+mkNameSet          :: [Name] -> NameSet+unionNameSet      :: NameSet -> NameSet -> NameSet+unionNameSets  :: [NameSet] -> NameSet+minusNameSet       :: NameSet -> NameSet -> NameSet+elemNameSet        :: Name -> NameSet -> Bool+isEmptyNameSet     :: NameSet -> Bool+delFromNameSet     :: NameSet -> Name -> NameSet+delListFromNameSet :: NameSet -> [Name] -> NameSet+filterNameSet      :: (Name -> Bool) -> NameSet -> NameSet+intersectNameSet   :: NameSet -> NameSet -> NameSet+intersectsNameSet  :: NameSet -> NameSet -> Bool+-- ^ True if there is a non-empty intersection.+-- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty++isEmptyNameSet    = isEmptyUniqSet+emptyNameSet      = emptyUniqSet+unitNameSet       = unitUniqSet+mkNameSet         = mkUniqSet+extendNameSetList  = addListToUniqSet+extendNameSet   = addOneToUniqSet+unionNameSet     = unionUniqSets+unionNameSets = unionManyUniqSets+minusNameSet      = minusUniqSet+elemNameSet       = elementOfUniqSet+delFromNameSet    = delOneFromUniqSet+filterNameSet     = filterUniqSet+intersectNameSet  = intersectUniqSets++delListFromNameSet set ns = foldl' delFromNameSet set ns++intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2))++nameSetAny :: (Name -> Bool) -> NameSet -> Bool+nameSetAny = uniqSetAny++nameSetAll :: (Name -> Bool) -> NameSet -> Bool+nameSetAll = uniqSetAll++-- | Get the elements of a NameSet with some stable ordering.+-- This only works for Names that originate in the source code or have been+-- tidied.+-- See Note [Deterministic UniqFM] to learn about nondeterminism+nameSetElemsStable :: NameSet -> [Name]+nameSetElemsStable ns =+  sortBy stableNameCmp $ nonDetEltsUniqSet ns+  -- It's OK to use nonDetEltsUniqSet here because we immediately sort+  -- with stableNameCmp++{-+************************************************************************+*                                                                      *+\subsection{Free variables}+*                                                                      *+************************************************************************++These synonyms are useful when we are thinking of free variables+-}++type FreeVars   = NameSet++plusFV   :: FreeVars -> FreeVars -> FreeVars+addOneFV :: FreeVars -> Name -> FreeVars+unitFV   :: Name -> FreeVars+emptyFVs :: FreeVars+plusFVs  :: [FreeVars] -> FreeVars+mkFVs    :: [Name] -> FreeVars+delFV    :: Name -> FreeVars -> FreeVars+delFVs   :: [Name] -> FreeVars -> FreeVars+intersectFVs :: FreeVars -> FreeVars -> FreeVars++isEmptyFVs :: NameSet -> Bool+isEmptyFVs  = isEmptyNameSet+emptyFVs    = emptyNameSet+plusFVs     = unionNameSets+plusFV      = unionNameSet+mkFVs       = mkNameSet+addOneFV    = extendNameSet+unitFV      = unitNameSet+delFV n s   = delFromNameSet s n+delFVs ns s = delListFromNameSet s ns+intersectFVs = intersectNameSet++{-+************************************************************************+*                                                                      *+                Defs and uses+*                                                                      *+************************************************************************+-}++-- | A set of names that are defined somewhere+type Defs = NameSet++-- | A set of names that are used somewhere+type Uses = NameSet++-- | @(Just ds, us) =>@ The use of any member of the @ds@+--                      implies that all the @us@ are used too.+--                      Also, @us@ may mention @ds@.+--+-- @Nothing =>@ Nothing is defined in this group, but+--              nevertheless all the uses are essential.+--              Used for instance declarations, for example+type DefUse  = (Maybe Defs, Uses)++-- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses'+--   In a single (def, use) pair, the defs also scope over the uses+type DefUses = OrdList DefUse++emptyDUs :: DefUses+emptyDUs = nilOL++usesOnly :: Uses -> DefUses+usesOnly uses = unitOL (Nothing, uses)++mkDUs :: [(Defs,Uses)] -> DefUses+mkDUs pairs = toOL [(Just defs, uses) | (defs,uses) <- pairs]++plusDU :: DefUses -> DefUses -> DefUses+plusDU = appOL++duDefs :: DefUses -> Defs+duDefs dus = foldr get emptyNameSet dus+  where+    get (Nothing, _u1) d2 = d2+    get (Just d1, _u1) d2 = d1 `unionNameSet` d2++allUses :: DefUses -> Uses+-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned+allUses dus = foldr get emptyNameSet dus+  where+    get (_d1, u1) u2 = u1 `unionNameSet` u2++duUses :: DefUses -> Uses+-- ^ Collect all 'Uses', regardless of whether the group is itself used,+-- but remove 'Defs' on the way+duUses dus = foldr get emptyNameSet dus+  where+    get (Nothing,   rhs_uses) uses = rhs_uses `unionNameSet` uses+    get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSet` uses)+                                     `minusNameSet` defs++findUses :: DefUses -> Uses -> Uses+-- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively.+-- The result is a superset of the input 'Uses'; and includes things defined+-- in the input 'DefUses' (but only if they are used)+findUses dus uses+  = foldr get uses dus+  where+    get (Nothing, rhs_uses) uses+        = rhs_uses `unionNameSet` uses+    get (Just defs, rhs_uses) uses+        | defs `intersectsNameSet` uses         -- Used+        || nameSetAny (startsWithUnderscore . nameOccName) defs+                -- At least one starts with an "_",+                -- so treat the group as used+        = rhs_uses `unionNameSet` uses+        | otherwise     -- No def is used+        = uses
compiler/GHC/Types/RepType.hs view
@@ -25,14 +25,14 @@  import GhcPrelude -import BasicTypes (Arity, RepArity)-import DataCon+import GHC.Types.Basic (Arity, RepArity)+import GHC.Core.DataCon import Outputable import PrelNames-import Coercion-import TyCon-import TyCoRep-import Type+import GHC.Core.Coercion+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep+import GHC.Core.Type import Util import TysPrim import {-# SOURCE #-} TysWiredIn ( anyTypeOfKind )
+ compiler/GHC/Types/SrcLoc.hs view
@@ -0,0 +1,741 @@+-- (c) The University of Glasgow, 1992-2006++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveFunctor      #-}+{-# LANGUAGE DeriveFoldable     #-}+{-# LANGUAGE DeriveTraversable  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE RecordWildCards    #-}+{-# LANGUAGE TypeFamilies       #-}+{-# LANGUAGE ViewPatterns       #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE PatternSynonyms    #-}+++-- | This module contains types that relate to the positions of things+-- in source files, and allow tagging of those things with locations+module GHC.Types.SrcLoc (+        -- * SrcLoc+        RealSrcLoc,             -- Abstract+        SrcLoc(..),++        -- ** Constructing SrcLoc+        mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,++        noSrcLoc,               -- "I'm sorry, I haven't a clue"+        generatedSrcLoc,        -- Code generated within the compiler+        interactiveSrcLoc,      -- Code from an interactive session++        advanceSrcLoc,+        advanceBufPos,++        -- ** Unsafely deconstructing SrcLoc+        -- These are dubious exports, because they crash on some inputs+        srcLocFile,             -- return the file name part+        srcLocLine,             -- return the line part+        srcLocCol,              -- return the column part++        -- * SrcSpan+        RealSrcSpan,            -- Abstract+        SrcSpan(..),++        -- ** Constructing SrcSpan+        mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,+        noSrcSpan,+        wiredInSrcSpan,         -- Something wired into the compiler+        interactiveSrcSpan,+        srcLocSpan, realSrcLocSpan,+        combineSrcSpans,+        srcSpanFirstCharacter,++        -- ** Deconstructing SrcSpan+        srcSpanStart, srcSpanEnd,+        realSrcSpanStart, realSrcSpanEnd,+        srcSpanFileName_maybe,+        pprUserRealSpan,++        -- ** Unsafely deconstructing SrcSpan+        -- These are dubious exports, because they crash on some inputs+        srcSpanFile,+        srcSpanStartLine, srcSpanEndLine,+        srcSpanStartCol, srcSpanEndCol,++        -- ** Predicates on SrcSpan+        isGoodSrcSpan, isOneLineSpan,+        containsSpan,++        -- * StringBuffer locations+        BufPos(..),+        BufSpan(..),++        -- * Located+        Located,+        RealLocated,+        GenLocated(..),++        -- ** Constructing Located+        noLoc,+        mkGeneralLocated,++        -- ** Deconstructing Located+        getLoc, unLoc,+        unRealSrcSpan, getRealSrcSpan,++        -- ** Modifying Located+        mapLoc,++        -- ** Combining and comparing Located values+        eqLocated, cmpLocated, combineLocs, addCLoc,+        leftmost_smallest, leftmost_largest, rightmost_smallest,+        spans, isSubspanOf, isRealSubspanOf, sortLocated,+        sortRealLocated,+        lookupSrcLoc, lookupSrcSpan,++        liftL,++        -- * Parser locations+        PsLoc(..),+        PsSpan(..),+        PsLocated,+        advancePsLoc,+        mkPsSpan,+        psSpanStart,+        psSpanEnd,+        mkSrcSpanPs,++    ) where++import GhcPrelude++import Util+import Json+import Outputable+import FastString++import Control.DeepSeq+import Control.Applicative (liftA2)+import Data.Bits+import Data.Data+import Data.List (sortBy, intercalate)+import Data.Function (on)+import qualified Data.Map as Map++{-+************************************************************************+*                                                                      *+\subsection[SrcLoc-SrcLocations]{Source-location information}+*                                                                      *+************************************************************************++We keep information about the {\em definition} point for each entity;+this is the obvious stuff:+-}++-- | Real Source Location+--+-- Represents a single point within a file+data RealSrcLoc+  = SrcLoc      FastString              -- A precise location (file name)+                {-# UNPACK #-} !Int     -- line number, begins at 1+                {-# UNPACK #-} !Int     -- column number, begins at 1+  deriving (Eq, Ord)++-- | 0-based index identifying the raw location in the StringBuffer.+--+-- Unlike 'RealSrcLoc', it is not affected by #line and {-# LINE ... #-}+-- pragmas. In particular, notice how 'setSrcLoc' and 'resetAlrLastLoc' in+-- Lexer.x update 'PsLoc' preserving 'BufPos'.+--+-- The parser guarantees that 'BufPos' are monotonic. See #17632.+newtype BufPos = BufPos { bufPos :: Int }+  deriving (Eq, Ord, Show)++-- | Source Location+data SrcLoc+  = RealSrcLoc !RealSrcLoc !(Maybe BufPos)  -- See Note [Why Maybe BufPos]+  | UnhelpfulLoc FastString     -- Just a general indication+  deriving (Eq, Show)++{-+************************************************************************+*                                                                      *+\subsection[SrcLoc-access-fns]{Access functions}+*                                                                      *+************************************************************************+-}++mkSrcLoc :: FastString -> Int -> Int -> SrcLoc+mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing++mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc+mkRealSrcLoc x line col = SrcLoc x line col++-- | Built-in "bad" 'SrcLoc' values for particular locations+noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc+noSrcLoc          = UnhelpfulLoc (fsLit "<no location info>")+generatedSrcLoc   = UnhelpfulLoc (fsLit "<compiler-generated code>")+interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive>")++-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location+mkGeneralSrcLoc :: FastString -> SrcLoc+mkGeneralSrcLoc = UnhelpfulLoc++-- | Gives the filename of the 'RealSrcLoc'+srcLocFile :: RealSrcLoc -> FastString+srcLocFile (SrcLoc fname _ _) = fname++-- | Raises an error when used on a "bad" 'SrcLoc'+srcLocLine :: RealSrcLoc -> Int+srcLocLine (SrcLoc _ l _) = l++-- | Raises an error when used on a "bad" 'SrcLoc'+srcLocCol :: RealSrcLoc -> Int+srcLocCol (SrcLoc _ _ c) = c++-- | Move the 'SrcLoc' down by one line if the character is a newline,+-- to the next 8-char tabstop if it is a tab, and across by one+-- character in any other case+advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc+advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f  (l + 1) 1+advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f  l (advance_tabstop c)+advanceSrcLoc (SrcLoc f l c) _    = SrcLoc f  l (c + 1)++advance_tabstop :: Int -> Int+advance_tabstop c = ((((c - 1) `shiftR` 3) + 1) `shiftL` 3) + 1++advanceBufPos :: BufPos -> BufPos+advanceBufPos (BufPos i) = BufPos (i+1)++{-+************************************************************************+*                                                                      *+\subsection[SrcLoc-instances]{Instance declarations for various names}+*                                                                      *+************************************************************************+-}++sortLocated :: [Located a] -> [Located a]+sortLocated = sortBy (leftmost_smallest `on` getLoc)++sortRealLocated :: [RealLocated a] -> [RealLocated a]+sortRealLocated = sortBy (compare `on` getLoc)++lookupSrcLoc :: SrcLoc -> Map.Map RealSrcLoc a -> Maybe a+lookupSrcLoc (RealSrcLoc l _) = Map.lookup l+lookupSrcLoc (UnhelpfulLoc _) = const Nothing++lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a+lookupSrcSpan (RealSrcSpan l _) = Map.lookup l+lookupSrcSpan (UnhelpfulSpan _) = const Nothing++instance Outputable RealSrcLoc where+    ppr (SrcLoc src_path src_line src_col)+      = hcat [ pprFastFilePath src_path <> colon+             , int src_line <> colon+             , int src_col ]++-- I don't know why there is this style-based difference+--        if userStyle sty || debugStyle sty then+--            hcat [ pprFastFilePath src_path, char ':',+--                   int src_line,+--                   char ':', int src_col+--                 ]+--        else+--            hcat [text "{-# LINE ", int src_line, space,+--                  char '\"', pprFastFilePath src_path, text " #-}"]++instance Outputable SrcLoc where+    ppr (RealSrcLoc l _) = ppr l+    ppr (UnhelpfulLoc s)  = ftext s++instance Data RealSrcSpan where+  -- don't traverse?+  toConstr _   = abstractConstr "RealSrcSpan"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "RealSrcSpan"++instance Data SrcSpan where+  -- don't traverse?+  toConstr _   = abstractConstr "SrcSpan"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "SrcSpan"++{-+************************************************************************+*                                                                      *+\subsection[SrcSpan]{Source Spans}+*                                                                      *+************************************************************************+-}++{- |+A 'RealSrcSpan' delimits a portion of a text file.  It could be represented+by a pair of (line,column) coordinates, but in fact we optimise+slightly by using more compact representations for single-line and+zero-length spans, both of which are quite common.++The end position is defined to be the column /after/ the end of the+span.  That is, a span of (1,1)-(1,2) is one character long, and a+span of (1,1)-(1,1) is zero characters long.+-}++-- | Real Source Span+data RealSrcSpan+  = RealSrcSpan'+        { srcSpanFile     :: !FastString,+          srcSpanSLine    :: {-# UNPACK #-} !Int,+          srcSpanSCol     :: {-# UNPACK #-} !Int,+          srcSpanELine    :: {-# UNPACK #-} !Int,+          srcSpanECol     :: {-# UNPACK #-} !Int+        }+  deriving Eq++-- | StringBuffer Source Span+data BufSpan =+  BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos }+  deriving (Eq, Ord, Show)++-- | Source Span+--+-- A 'SrcSpan' identifies either a specific portion of a text file+-- or a human-readable description of a location.+data SrcSpan =+    RealSrcSpan !RealSrcSpan !(Maybe BufSpan)  -- See Note [Why Maybe BufPos]+  | UnhelpfulSpan !FastString   -- Just a general indication+                                -- also used to indicate an empty span++  deriving (Eq, Show) -- Show is used by Lexer.x, because we+                      -- derive Show for Token++{- Note [Why Maybe BufPos]+~~~~~~~~~~~~~~~~~~~~~~~~~~+In SrcLoc we store (Maybe BufPos); in SrcSpan we store (Maybe BufSpan).+Why the Maybe?++Surely, the lexer can always fill in the buffer position, and it guarantees to do so.+However, sometimes the SrcLoc/SrcSpan is constructed in a different context+where the buffer location is not available, and then we use Nothing instead of+a fake value like BufPos (-1).++Perhaps the compiler could be re-engineered to pass around BufPos more+carefully and never discard it, and this 'Maybe' could be removed. If you're+interested in doing so, you may find this ripgrep query useful:++  rg "RealSrc(Loc|Span).*?Nothing"++For example, it is not uncommon to whip up source locations for e.g. error+messages, constructing a SrcSpan without a BufSpan.+-}++instance ToJson SrcSpan where+  json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")]+  json (RealSrcSpan rss _) = json rss++instance ToJson RealSrcSpan where+  json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile))+                                     , ("startLine", JSInt srcSpanSLine)+                                     , ("startCol", JSInt srcSpanSCol)+                                     , ("endLine", JSInt srcSpanELine)+                                     , ("endCol", JSInt srcSpanECol)+                                     ]++instance NFData SrcSpan where+  rnf x = x `seq` ()++-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty+noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan+noSrcSpan          = UnhelpfulSpan (fsLit "<no location info>")+wiredInSrcSpan     = UnhelpfulSpan (fsLit "<wired into compiler>")+interactiveSrcSpan = UnhelpfulSpan (fsLit "<interactive>")++-- | Create a "bad" 'SrcSpan' that has not location information+mkGeneralSrcSpan :: FastString -> SrcSpan+mkGeneralSrcSpan = UnhelpfulSpan++-- | Create a 'SrcSpan' corresponding to a single point+srcLocSpan :: SrcLoc -> SrcSpan+srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str+srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb)++realSrcLocSpan :: RealSrcLoc -> RealSrcSpan+realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col++-- | Create a 'SrcSpan' between two points in a file+mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan+mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2+  where+        line1 = srcLocLine loc1+        line2 = srcLocLine loc2+        col1 = srcLocCol loc1+        col2 = srcLocCol loc2+        file = srcLocFile loc1++-- | 'True' if the span is known to straddle only one line.+isOneLineRealSpan :: RealSrcSpan -> Bool+isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _)+  = line1 == line2++-- | 'True' if the span is a single point+isPointRealSpan :: RealSrcSpan -> Bool+isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2)+  = line1 == line2 && col1 == col2++-- | Create a 'SrcSpan' between two points in a file+mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan+mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str+mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str+mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2)+    = RealSrcSpan (mkRealSrcSpan loc1 loc2) (liftA2 BufSpan mbpos1 mbpos2)++-- | Combines two 'SrcSpan' into one that spans at least all the characters+-- within both spans. Returns UnhelpfulSpan if the files differ.+combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan+combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful+combineSrcSpans l (UnhelpfulSpan _) = l+combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2)+  | srcSpanFile span1 == srcSpanFile span2+      = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2)+  | otherwise = UnhelpfulSpan (fsLit "<combineSrcSpans: files differ>")++-- | Combines two 'SrcSpan' into one that spans at least all the characters+-- within both spans. Assumes the "file" part is the same in both inputs+combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan+combineRealSrcSpans span1 span2+  = RealSrcSpan' file line_start col_start line_end col_end+  where+    (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1)+                                  (srcSpanStartLine span2, srcSpanStartCol span2)+    (line_end, col_end)     = max (srcSpanEndLine span1, srcSpanEndCol span1)+                                  (srcSpanEndLine span2, srcSpanEndCol span2)+    file = srcSpanFile span1++combineBufSpans :: BufSpan -> BufSpan -> BufSpan+combineBufSpans span1 span2 = BufSpan start end+  where+    start = min (bufSpanStart span1) (bufSpanStart span2)+    end   = max (bufSpanEnd   span1) (bufSpanEnd   span2)+++-- | Convert a SrcSpan into one that represents only its first character+srcSpanFirstCharacter :: SrcSpan -> SrcSpan+srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l+srcSpanFirstCharacter (RealSrcSpan span mbspan) =+    RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan)+  where+    loc1@(SrcLoc f l c) = realSrcSpanStart span+    loc2 = SrcLoc f l (c+1)+    mkBufSpan bspan =+      let bpos1@(BufPos i) = bufSpanStart bspan+          bpos2 = BufPos (i+1)+      in BufSpan bpos1 bpos2++{-+************************************************************************+*                                                                      *+\subsection[SrcSpan-predicates]{Predicates}+*                                                                      *+************************************************************************+-}++-- | Test if a 'SrcSpan' is "good", i.e. has precise location information+isGoodSrcSpan :: SrcSpan -> Bool+isGoodSrcSpan (RealSrcSpan _ _) = True+isGoodSrcSpan (UnhelpfulSpan _) = False++isOneLineSpan :: SrcSpan -> Bool+-- ^ True if the span is known to straddle only one line.+-- For "bad" 'SrcSpan', it returns False+isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s+isOneLineSpan (UnhelpfulSpan _) = False++-- | Tests whether the first span "contains" the other span, meaning+-- that it covers at least as much source code. True where spans are equal.+containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool+containsSpan s1 s2+  = (srcSpanStartLine s1, srcSpanStartCol s1)+       <= (srcSpanStartLine s2, srcSpanStartCol s2)+    && (srcSpanEndLine s1, srcSpanEndCol s1)+       >= (srcSpanEndLine s2, srcSpanEndCol s2)+    && (srcSpanFile s1 == srcSpanFile s2)+    -- We check file equality last because it is (presumably?) least+    -- likely to fail.+{-+%************************************************************************+%*                                                                      *+\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions}+*                                                                      *+************************************************************************+-}++srcSpanStartLine :: RealSrcSpan -> Int+srcSpanEndLine :: RealSrcSpan -> Int+srcSpanStartCol :: RealSrcSpan -> Int+srcSpanEndCol :: RealSrcSpan -> Int++srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l+srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l+srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l+srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c++{-+************************************************************************+*                                                                      *+\subsection[SrcSpan-access-fns]{Access functions}+*                                                                      *+************************************************************************+-}++-- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable+srcSpanStart :: SrcSpan -> SrcLoc+srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str+srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b)++-- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable+srcSpanEnd :: SrcSpan -> SrcLoc+srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str+srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b)++realSrcSpanStart :: RealSrcSpan -> RealSrcLoc+realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s)+                                  (srcSpanStartLine s)+                                  (srcSpanStartCol s)++realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc+realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s)+                                (srcSpanEndLine s)+                                (srcSpanEndCol s)++-- | Obtains the filename for a 'SrcSpan' if it is "good"+srcSpanFileName_maybe :: SrcSpan -> Maybe FastString+srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s)+srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing++{-+************************************************************************+*                                                                      *+\subsection[SrcSpan-instances]{Instances}+*                                                                      *+************************************************************************+-}++-- We want to order RealSrcSpans first by the start point, then by the+-- end point.+instance Ord RealSrcSpan where+  a `compare` b =+     (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp`+     (realSrcSpanEnd   a `compare` realSrcSpanEnd   b)++instance Show RealSrcLoc where+  show (SrcLoc filename row col)+      = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col++-- Show is used by Lexer.x, because we derive Show for Token+instance Show RealSrcSpan where+  show span@(RealSrcSpan' file sl sc el ec)+    | isPointRealSpan span+    = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc])++    | isOneLineRealSpan span+    = "SrcSpanOneLine " ++ show file ++ " "+                        ++ intercalate " " (map show [sl,sc,ec])++    | otherwise+    = "SrcSpanMultiLine " ++ show file ++ " "+                          ++ intercalate " " (map show [sl,sc,el,ec])+++instance Outputable RealSrcSpan where+    ppr span = pprUserRealSpan True span++-- I don't know why there is this style-based difference+--      = getPprStyle $ \ sty ->+--        if userStyle sty || debugStyle sty then+--           text (showUserRealSpan True span)+--        else+--           hcat [text "{-# LINE ", int (srcSpanStartLine span), space,+--                 char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]++instance Outputable SrcSpan where+    ppr span = pprUserSpan True span++-- I don't know why there is this style-based difference+--      = getPprStyle $ \ sty ->+--        if userStyle sty || debugStyle sty then+--           pprUserSpan True span+--        else+--           case span of+--           UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"+--           RealSrcSpan s -> ppr s++pprUserSpan :: Bool -> SrcSpan -> SDoc+pprUserSpan _         (UnhelpfulSpan s) = ftext s+pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s++pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc+pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _)+  | isPointRealSpan span+  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)+         , int line <> colon+         , int col ]++pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol)+  | isOneLineRealSpan span+  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)+         , int line <> colon+         , int scol+         , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ]+            -- For single-character or point spans, we just+            -- output the starting column number++pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol)+  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)+         , parens (int sline <> comma <> int scol)+         , char '-'+         , parens (int eline <> comma <> int ecol') ]+ where+   ecol' = if ecol == 0 then ecol else ecol - 1++{-+************************************************************************+*                                                                      *+\subsection[Located]{Attaching SrcSpans to things}+*                                                                      *+************************************************************************+-}++-- | We attach SrcSpans to lots of things, so let's have a datatype for it.+data GenLocated l e = L l e+  deriving (Eq, Ord, Data, Functor, Foldable, Traversable)++type Located = GenLocated SrcSpan+type RealLocated = GenLocated RealSrcSpan++mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b+mapLoc = fmap++unLoc :: GenLocated l e -> e+unLoc (L _ e) = e++getLoc :: GenLocated l e -> l+getLoc (L l _) = l++noLoc :: e -> Located e+noLoc e = L noSrcSpan e++mkGeneralLocated :: String -> e -> Located e+mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e++combineLocs :: Located a -> Located b -> SrcSpan+combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)++-- | Combine locations from two 'Located' things and add them to a third thing+addCLoc :: Located a -> Located b -> c -> Located c+addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c++-- not clear whether to add a general Eq instance, but this is useful sometimes:++-- | Tests whether the two located things are equal+eqLocated :: Eq a => GenLocated l a -> GenLocated l a -> Bool+eqLocated a b = unLoc a == unLoc b++-- not clear whether to add a general Ord instance, but this is useful sometimes:++-- | Tests the ordering of the two located things+cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering+cmpLocated a b = unLoc a `compare` unLoc b++instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where+  ppr (L l e) = -- TODO: We can't do this since Located was refactored into+                -- GenLocated:+                -- Print spans without the file name etc+                -- ifPprDebug (braces (pprUserSpan False l))+                whenPprDebug (braces (ppr l))+             $$ ppr e++{-+************************************************************************+*                                                                      *+\subsection{Ordering SrcSpans for InteractiveUI}+*                                                                      *+************************************************************************+-}++-- | Strategies for ordering 'SrcSpan's+leftmost_smallest, leftmost_largest, rightmost_smallest :: SrcSpan -> SrcSpan -> Ordering+rightmost_smallest = compareSrcSpanBy (flip compare)+leftmost_smallest = compareSrcSpanBy compare+leftmost_largest = compareSrcSpanBy $ \a b ->+  (realSrcSpanStart a `compare` realSrcSpanStart b)+    `thenCmp`+  (realSrcSpanEnd b `compare` realSrcSpanEnd a)++compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering+compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b+compareSrcSpanBy _   (RealSrcSpan _ _) (UnhelpfulSpan _) = LT+compareSrcSpanBy _   (UnhelpfulSpan _) (RealSrcSpan _ _) = GT+compareSrcSpanBy _   (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ++-- | Determines whether a span encloses a given line and column index+spans :: SrcSpan -> (Int, Int) -> Bool+spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan"+spans (RealSrcSpan span _) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span+   where loc = mkRealSrcLoc (srcSpanFile span) l c++-- | Determines whether a span is enclosed by another one+isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other+            -> SrcSpan -- ^ The span it may be enclosed by+            -> Bool+isSubspanOf (RealSrcSpan src _) (RealSrcSpan parent _) = isRealSubspanOf src parent+isSubspanOf _ _ = False++-- | Determines whether a span is enclosed by another one+isRealSubspanOf :: RealSrcSpan -- ^ The span that may be enclosed by the other+                -> RealSrcSpan -- ^ The span it may be enclosed by+                -> Bool+isRealSubspanOf src parent+    | srcSpanFile parent /= srcSpanFile src = False+    | otherwise = realSrcSpanStart parent <= realSrcSpanStart src &&+                  realSrcSpanEnd parent   >= realSrcSpanEnd src++liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b)+liftL f (L loc a) = do+  a' <- f a+  return $ L loc a'++getRealSrcSpan :: RealLocated a -> RealSrcSpan+getRealSrcSpan (L l _) = l++unRealSrcSpan :: RealLocated a -> a+unRealSrcSpan  (L _ e) = e+++-- | A location as produced by the parser. Consists of two components:+--+-- * The location in the file, adjusted for #line and {-# LINE ... #-} pragmas (RealSrcLoc)+-- * The location in the string buffer (BufPos) with monotonicity guarantees (see #17632)+data PsLoc+  = PsLoc { psRealLoc :: !RealSrcLoc, psBufPos :: !BufPos }+  deriving (Eq, Ord, Show)++data PsSpan+  = PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan }+  deriving (Eq, Ord, Show)++type PsLocated = GenLocated PsSpan++advancePsLoc :: PsLoc -> Char -> PsLoc+advancePsLoc (PsLoc real_loc buf_loc) c =+  PsLoc (advanceSrcLoc real_loc c) (advanceBufPos buf_loc)++mkPsSpan :: PsLoc -> PsLoc -> PsSpan+mkPsSpan (PsLoc r1 b1) (PsLoc r2 b2) = PsSpan (mkRealSrcSpan r1 r2) (BufSpan b1 b2)++psSpanStart :: PsSpan -> PsLoc+psSpanStart (PsSpan r b) = PsLoc (realSrcSpanStart r) (bufSpanStart b)++psSpanEnd :: PsSpan -> PsLoc+psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b)++mkSrcSpanPs :: PsSpan -> SrcSpan+mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Just b)
+ compiler/GHC/Types/Unique.hs view
@@ -0,0 +1,448 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++@Uniques@ are used to distinguish entities in the compiler (@Ids@,+@Classes@, etc.) from each other.  Thus, @Uniques@ are the basic+comparison key in the compiler.++If there is any single operation that needs to be fast, it is @Unique@++comparison.  Unsurprisingly, there is quite a bit of huff-and-puff+directed to that end.++Some of the other hair in this code is to be able to use a+``splittable @UniqueSupply@'' if requested/possible (not standard+Haskell).+-}++{-# LANGUAGE CPP, BangPatterns, MagicHash #-}++module GHC.Types.Unique (+        -- * Main data types+        Unique, Uniquable(..),+        uNIQUE_BITS,++        -- ** Constructors, destructors and operations on 'Unique's+        hasKey,++        pprUniqueAlways,++        mkUniqueGrimily,+        getKey,+        mkUnique, unpkUnique,+        eqUnique, ltUnique,+        incrUnique,++        newTagUnique,+        initTyVarUnique,+        initExitJoinUnique,+        nonDetCmpUnique,+        isValidKnownKeyUnique,++        -- ** Making built-in uniques++        -- now all the built-in GHC.Types.Uniques (and functions to make them)+        -- [the Oh-So-Wonderful Haskell module system wins again...]+        mkAlphaTyVarUnique,+        mkPrimOpIdUnique, mkPrimOpWrapperUnique,+        mkPreludeMiscIdUnique, mkPreludeDataConUnique,+        mkPreludeTyConUnique, mkPreludeClassUnique,+        mkCoVarUnique,++        mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,+        mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,+        mkCostCentreUnique,++        mkBuiltinUnique,+        mkPseudoUniqueD,+        mkPseudoUniqueE,+        mkPseudoUniqueH,++        -- ** Deriving uniques+        -- *** From TyCon name uniques+        tyConRepNameUnique,+        -- *** From DataCon name uniques+        dataConWorkerUnique, dataConTyRepNameUnique,++        -- ** Local uniques+        -- | These are exposed exclusively for use by 'VarEnv.uniqAway', which+        -- has rather peculiar needs. See Note [Local uniques].+        mkLocalUnique, minLocalUnique, maxLocalUnique+    ) where++#include "HsVersions.h"+#include "Unique.h"++import GhcPrelude++import GHC.Types.Basic+import FastString+import Outputable+import Util++-- just for implementing a fast [0,61) -> Char function+import GHC.Exts (indexCharOffAddr#, Char(..), Int(..))++import Data.Char        ( chr, ord )+import Data.Bits++{-+************************************************************************+*                                                                      *+\subsection[Unique-type]{@Unique@ type and operations}+*                                                                      *+************************************************************************++The @Chars@ are ``tag letters'' that identify the @UniqueSupply@.+Fast comparison is everything on @Uniques@:+-}++-- | Unique identifier.+--+-- The type of unique identifiers that are used in many places in GHC+-- for fast ordering and equality tests. You should generate these with+-- the functions from the 'UniqSupply' module+--+-- These are sometimes also referred to as \"keys\" in comments in GHC.+newtype Unique = MkUnique Int++{-# INLINE uNIQUE_BITS #-}+uNIQUE_BITS :: Int+uNIQUE_BITS = finiteBitSize (0 :: Int) - UNIQUE_TAG_BITS++{-+Now come the functions which construct uniques from their pieces, and vice versa.+The stuff about unique *supplies* is handled further down this module.+-}++unpkUnique      :: Unique -> (Char, Int)        -- The reverse++mkUniqueGrimily :: Int -> Unique                -- A trap-door for UniqSupply+getKey          :: Unique -> Int                -- for Var++incrUnique   :: Unique -> Unique+stepUnique   :: Unique -> Int -> Unique+newTagUnique :: Unique -> Char -> Unique++mkUniqueGrimily = MkUnique++{-# INLINE getKey #-}+getKey (MkUnique x) = x++incrUnique (MkUnique i) = MkUnique (i + 1)+stepUnique (MkUnique i) n = MkUnique (i + n)++mkLocalUnique :: Int -> Unique+mkLocalUnique i = mkUnique 'X' i++minLocalUnique :: Unique+minLocalUnique = mkLocalUnique 0++maxLocalUnique :: Unique+maxLocalUnique = mkLocalUnique uniqueMask++-- newTagUnique changes the "domain" of a unique to a different char+newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u++-- | How many bits are devoted to the unique index (as opposed to the class+-- character).+uniqueMask :: Int+uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1++-- pop the Char in the top 8 bits of the Unique(Supply)++-- No 64-bit bugs here, as long as we have at least 32 bits. --JSM++-- and as long as the Char fits in 8 bits, which we assume anyway!++mkUnique :: Char -> Int -> Unique       -- Builds a unique from pieces+-- NOT EXPORTED, so that we can see all the Chars that+--               are used in this one module+mkUnique c i+  = MkUnique (tag .|. bits)+  where+    tag  = ord c `shiftL` uNIQUE_BITS+    bits = i .&. uniqueMask++unpkUnique (MkUnique u)+  = let+        -- as long as the Char may have its eighth bit set, we+        -- really do need the logical right-shift here!+        tag = chr (u `shiftR` uNIQUE_BITS)+        i   = u .&. uniqueMask+    in+    (tag, i)++-- | The interface file symbol-table encoding assumes that known-key uniques fit+-- in 30-bits; verify this.+--+-- See Note [Symbol table representation of names] in GHC.Iface.Binary for details.+isValidKnownKeyUnique :: Unique -> Bool+isValidKnownKeyUnique u =+    case unpkUnique u of+      (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22)++{-+************************************************************************+*                                                                      *+\subsection[Uniquable-class]{The @Uniquable@ class}+*                                                                      *+************************************************************************+-}++-- | Class of things that we can obtain a 'Unique' from+class Uniquable a where+    getUnique :: a -> Unique++hasKey          :: Uniquable a => a -> Unique -> Bool+x `hasKey` k    = getUnique x == k++instance Uniquable FastString where+ getUnique fs = mkUniqueGrimily (uniqueOfFS fs)++instance Uniquable Int where+ getUnique i = mkUniqueGrimily i++{-+************************************************************************+*                                                                      *+\subsection[Unique-instances]{Instance declarations for @Unique@}+*                                                                      *+************************************************************************++And the whole point (besides uniqueness) is fast equality.  We don't+use `deriving' because we want {\em precise} control of ordering+(equality on @Uniques@ is v common).+-}++-- Note [Unique Determinism]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of allocated @Uniques@ is not stable across rebuilds.+-- The main reason for that is that typechecking interface files pulls+-- @Uniques@ from @UniqSupply@ and the interface file for the module being+-- currently compiled can, but doesn't have to exist.+--+-- It gets more complicated if you take into account that the interface+-- files are loaded lazily and that building multiple files at once has to+-- work for any subset of interface files present. When you add parallelism+-- this makes @Uniques@ hopelessly random.+--+-- As such, to get deterministic builds, the order of the allocated+-- @Uniques@ should not affect the final result.+-- see also wiki/deterministic-builds+--+-- Note [Unique Determinism and code generation]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The goal of the deterministic builds (wiki/deterministic-builds, #4012)+-- is to get ABI compatible binaries given the same inputs and environment.+-- The motivation behind that is that if the ABI doesn't change the+-- binaries can be safely reused.+-- Note that this is weaker than bit-for-bit identical binaries and getting+-- bit-for-bit identical binaries is not a goal for now.+-- This means that we don't care about nondeterminism that happens after+-- the interface files are created, in particular we don't care about+-- register allocation and code generation.+-- To track progress on bit-for-bit determinism see #12262.++eqUnique :: Unique -> Unique -> Bool+eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2++ltUnique :: Unique -> Unique -> Bool+ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2++-- Provided here to make it explicit at the call-site that it can+-- introduce non-determinism.+-- See Note [Unique Determinism]+-- See Note [No Ord for Unique]+nonDetCmpUnique :: Unique -> Unique -> Ordering+nonDetCmpUnique (MkUnique u1) (MkUnique u2)+  = if u1 == u2 then EQ else if u1 < u2 then LT else GT++{-+Note [No Ord for Unique]+~~~~~~~~~~~~~~~~~~~~~~~~~~+As explained in Note [Unique Determinism] the relative order of Uniques+is nondeterministic. To prevent from accidental use the Ord Unique+instance has been removed.+This makes it easier to maintain deterministic builds, but comes with some+drawbacks.+The biggest drawback is that Maps keyed by Uniques can't directly be used.+The alternatives are:++  1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which+  2) Create a newtype wrapper based on Unique ordering where nondeterminism+     is controlled. See Module.ModuleEnv+  3) Change the algorithm to use nonDetCmpUnique and document why it's still+     deterministic+  4) Use TrieMap as done in GHC.Cmm.CommonBlockElim.groupByLabel+-}++instance Eq Unique where+    a == b = eqUnique a b+    a /= b = not (eqUnique a b)++instance Uniquable Unique where+    getUnique u = u++-- We do sometimes make strings with @Uniques@ in them:++showUnique :: Unique -> String+showUnique uniq+  = case unpkUnique uniq of+      (tag, u) -> finish_show tag u (iToBase62 u)++finish_show :: Char -> Int -> String -> String+finish_show 't' u _pp_u | u < 26+  = -- Special case to make v common tyvars, t1, t2, ...+    -- come out as a, b, ... (shorter, easier to read)+    [chr (ord 'a' + u)]+finish_show tag _ pp_u = tag : pp_u++pprUniqueAlways :: Unique -> SDoc+-- The "always" means regardless of -dsuppress-uniques+-- It replaces the old pprUnique to remind callers that+-- they should consider whether they want to consult+-- Opt_SuppressUniques+pprUniqueAlways u+  = text (showUnique u)++instance Outputable Unique where+    ppr = pprUniqueAlways++instance Show Unique where+    show uniq = showUnique uniq++{-+************************************************************************+*                                                                      *+\subsection[Utils-base62]{Base-62 numbers}+*                                                                      *+************************************************************************++A character-stingy way to read/write numbers (notably Uniques).+The ``62-its'' are \tr{[0-9a-zA-Z]}.  We don't handle negative Ints.+Code stolen from Lennart.+-}++iToBase62 :: Int -> String+iToBase62 n_+  = ASSERT(n_ >= 0) go n_ ""+  where+    go n cs | n < 62+            = let !c = chooseChar62 n in c : cs+            | otherwise+            = go q (c : cs) where (!q, r) = quotRem n 62+                                  !c = chooseChar62 r++    chooseChar62 :: Int -> Char+    {-# INLINE chooseChar62 #-}+    chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n)+    chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#++{-+************************************************************************+*                                                                      *+\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things}+*                                                                      *+************************************************************************++Allocation of unique supply characters:+        v,t,u : for renumbering value-, type- and usage- vars.+        B:   builtin+        C-E: pseudo uniques     (used in native-code generator)+        X:   uniques from mkLocalUnique+        _:   unifiable tyvars   (above)+        0-9: prelude things below+             (no numbers left any more..)+        ::   (prelude) parallel array data constructors++        other a-z: lower case chars for unique supplies.  Used so far:++        d       desugarer+        f       AbsC flattener+        g       SimplStg+        k       constraint tuple tycons+        m       constraint tuple datacons+        n       Native codegen+        r       Hsc name cache+        s       simplifier+        z       anonymous sums+-}++mkAlphaTyVarUnique     :: Int -> Unique+mkPreludeClassUnique   :: Int -> Unique+mkPreludeTyConUnique   :: Int -> Unique+mkPreludeDataConUnique :: Arity -> Unique+mkPrimOpIdUnique       :: Int -> Unique+-- See Note [Primop wrappers] in PrimOp.hs.+mkPrimOpWrapperUnique  :: Int -> Unique+mkPreludeMiscIdUnique  :: Int -> Unique+mkCoVarUnique          :: Int -> Unique++mkAlphaTyVarUnique   i = mkUnique '1' i+mkCoVarUnique        i = mkUnique 'g' i+mkPreludeClassUnique i = mkUnique '2' i++--------------------------------------------------+-- Wired-in type constructor keys occupy *two* slots:+--    * u: the TyCon itself+--    * u+1: the TyConRepName of the TyCon+mkPreludeTyConUnique i                = mkUnique '3' (2*i)++tyConRepNameUnique :: Unique -> Unique+tyConRepNameUnique  u = incrUnique u++--------------------------------------------------+-- Wired-in data constructor keys occupy *three* slots:+--    * u: the DataCon itself+--    * u+1: its worker Id+--    * u+2: the TyConRepName of the promoted TyCon+-- Prelude data constructors are too simple to need wrappers.++mkPreludeDataConUnique i              = mkUnique '6' (3*i)    -- Must be alphabetic++--------------------------------------------------+dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique+dataConWorkerUnique  u = incrUnique u+dataConTyRepNameUnique u = stepUnique u 2++--------------------------------------------------+mkPrimOpIdUnique op         = mkUnique '9' (2*op)+mkPrimOpWrapperUnique op    = mkUnique '9' (2*op+1)+mkPreludeMiscIdUnique  i    = mkUnique '0' i++-- The "tyvar uniques" print specially nicely: a, b, c, etc.+-- See pprUnique for details++initTyVarUnique :: Unique+initTyVarUnique = mkUnique 't' 0++mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH,+   mkBuiltinUnique :: Int -> Unique++mkBuiltinUnique i = mkUnique 'B' i+mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs+mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs+mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs++mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique+mkRegSingleUnique = mkUnique 'R'+mkRegSubUnique    = mkUnique 'S'+mkRegPairUnique   = mkUnique 'P'+mkRegClassUnique  = mkUnique 'L'++mkCostCentreUnique :: Int -> Unique+mkCostCentreUnique = mkUnique 'C'++mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique+-- See Note [The Unique of an OccName] in GHC.Types.Name.Occurrence+mkVarOccUnique  fs = mkUnique 'i' (uniqueOfFS fs)+mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs)+mkTvOccUnique   fs = mkUnique 'v' (uniqueOfFS fs)+mkTcOccUnique   fs = mkUnique 'c' (uniqueOfFS fs)++initExitJoinUnique :: Unique+initExitJoinUnique = mkUnique 's' 0+
+ compiler/GHC/Types/Unique/DFM.hs view
@@ -0,0 +1,420 @@+{-+(c) Bartosz Nitka, Facebook, 2015++UniqDFM: Specialised deterministic finite maps, for things with @Uniques@.++Basically, the things need to be in class @Uniquable@, and we use the+@getUnique@ method to grab their @Uniques@.++This is very similar to @UniqFM@, the major difference being that the order of+folding is not dependent on @Unique@ ordering, giving determinism.+Currently the ordering is determined by insertion order.++See Note [Unique Determinism] in GHC.Types.Unique for explanation why @Unique@ ordering+is not deterministic.+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wall #-}++module GHC.Types.Unique.DFM (+        -- * Unique-keyed deterministic mappings+        UniqDFM,       -- abstract type++        -- ** Manipulating those mappings+        emptyUDFM,+        unitUDFM,+        addToUDFM,+        addToUDFM_C,+        addListToUDFM,+        delFromUDFM,+        delListFromUDFM,+        adjustUDFM,+        alterUDFM,+        mapUDFM,+        plusUDFM,+        plusUDFM_C,+        lookupUDFM, lookupUDFM_Directly,+        elemUDFM,+        foldUDFM,+        eltsUDFM,+        filterUDFM, filterUDFM_Directly,+        isNullUDFM,+        sizeUDFM,+        intersectUDFM, udfmIntersectUFM,+        intersectsUDFM,+        disjointUDFM, disjointUdfmUfm,+        equalKeysUDFM,+        minusUDFM,+        listToUDFM,+        udfmMinusUFM,+        partitionUDFM,+        anyUDFM, allUDFM,+        pprUniqDFM, pprUDFM,++        udfmToList,+        udfmToUfm,+        nonDetFoldUDFM,+        alwaysUnsafeUfmToUdfm,+    ) where++import GhcPrelude++import GHC.Types.Unique ( Uniquable(..), Unique, getKey )+import Outputable++import qualified Data.IntMap as M+import Data.Data+import Data.Functor.Classes (Eq1 (..))+import Data.List (sortBy)+import Data.Function (on)+import qualified Data.Semigroup as Semi+import GHC.Types.Unique.FM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap)++-- Note [Deterministic UniqFM]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- A @UniqDFM@ is just like @UniqFM@ with the following additional+-- property: the function `udfmToList` returns the elements in some+-- deterministic order not depending on the Unique key for those elements.+--+-- If the client of the map performs operations on the map in deterministic+-- order then `udfmToList` returns them in deterministic order.+--+-- There is an implementation cost: each element is given a serial number+-- as it is added, and `udfmToList` sorts it's result by this serial+-- number. So you should only use `UniqDFM` if you need the deterministic+-- property.+--+-- `foldUDFM` also preserves determinism.+--+-- Normal @UniqFM@ when you turn it into a list will use+-- Data.IntMap.toList function that returns the elements in the order of+-- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with+-- with a list ordered by @Uniques@.+-- The order of @Uniques@ is known to be not stable across rebuilds.+-- See Note [Unique Determinism] in GHC.Types.Unique.+--+--+-- There's more than one way to implement this. The implementation here tags+-- every value with the insertion time that can later be used to sort the+-- values when asked to convert to a list.+--+-- An alternative would be to have+--+--   data UniqDFM ele = UDFM (M.IntMap ele) [ele]+--+-- where the list determines the order. This makes deletion tricky as we'd+-- only accumulate elements in that list, but makes merging easier as you+-- can just merge both structures independently.+-- Deletion can probably be done in amortized fashion when the size of the+-- list is twice the size of the set.++-- | A type of values tagged with insertion time+data TaggedVal val =+  TaggedVal+    val+    {-# UNPACK #-} !Int -- ^ insertion time+  deriving (Data, Functor)++taggedFst :: TaggedVal val -> val+taggedFst (TaggedVal v _) = v++taggedSnd :: TaggedVal val -> Int+taggedSnd (TaggedVal _ i) = i++instance Eq val => Eq (TaggedVal val) where+  (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2++-- | Type of unique deterministic finite maps+data UniqDFM ele =+  UDFM+    !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and+                                -- values are tagged with insertion time.+                                -- The invariant is that all the tags will+                                -- be distinct within a single map+    {-# UNPACK #-} !Int         -- Upper bound on the values' insertion+                                -- time. See Note [Overflow on plusUDFM]+  deriving (Data, Functor)++-- | Deterministic, in O(n log n).+instance Foldable UniqDFM where+  foldr = foldUDFM++-- | Deterministic, in O(n log n).+instance Traversable UniqDFM where+  traverse f = fmap listToUDFM_Directly+             . traverse (\(u,a) -> (u,) <$> f a)+             . udfmToList++emptyUDFM :: UniqDFM elt+emptyUDFM = UDFM M.empty 0++unitUDFM :: Uniquable key => key -> elt -> UniqDFM elt+unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1++-- The new binding always goes to the right of existing ones+addToUDFM :: Uniquable key => UniqDFM elt -> key -> elt  -> UniqDFM elt+addToUDFM m k v = addToUDFM_Directly m (getUnique k) v++-- The new binding always goes to the right of existing ones+addToUDFM_Directly :: UniqDFM elt -> Unique -> elt -> UniqDFM elt+addToUDFM_Directly (UDFM m i) u v+  = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)+  where+    tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i+      -- Keep the old tag, but insert the new value+      -- This means that udfmToList typically returns elements+      -- in the order of insertion, rather than the reverse++addToUDFM_Directly_C+  :: (elt -> elt -> elt)   -- old -> new -> result+  -> UniqDFM elt+  -> Unique -> elt+  -> UniqDFM elt+addToUDFM_Directly_C f (UDFM m i) u v+  = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)+    where+      tf (TaggedVal new_v _) (TaggedVal old_v old_i)+         = TaggedVal (f old_v new_v) old_i+          -- Flip the arguments, because M.insertWith uses  (new->old->result)+          --                         but f            needs (old->new->result)+          -- Like addToUDFM_Directly, keep the old tag++addToUDFM_C+  :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result+  -> UniqDFM elt -- old+  -> key -> elt -- new+  -> UniqDFM elt -- result+addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v++addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt+addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v)++addListToUDFM_Directly :: UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt+addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v)++addListToUDFM_Directly_C+  :: (elt -> elt -> elt) -> UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt+addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_Directly_C f m k v)++delFromUDFM :: Uniquable key => UniqDFM elt -> key -> UniqDFM elt+delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i++plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt+plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j)+  -- we will use the upper bound on the tag as a proxy for the set size,+  -- to insert the smaller one into the bigger one+  | i > j = insertUDFMIntoLeft_C f udfml udfmr+  | otherwise = insertUDFMIntoLeft_C f udfmr udfml++-- Note [Overflow on plusUDFM]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- There are multiple ways of implementing plusUDFM.+-- The main problem that needs to be solved is overlap on times of+-- insertion between different keys in two maps.+-- Consider:+--+-- A = fromList [(a, (x, 1))]+-- B = fromList [(b, (y, 1))]+--+-- If you merge them naively you end up with:+--+-- C = fromList [(a, (x, 1)), (b, (y, 1))]+--+-- Which loses information about ordering and brings us back into+-- non-deterministic world.+--+-- The solution I considered before would increment the tags on one of the+-- sets by the upper bound of the other set. The problem with this approach+-- is that you'll run out of tags for some merge patterns.+-- Say you start with A with upper bound 1, you merge A with A to get A' and+-- the upper bound becomes 2. You merge A' with A' and the upper bound+-- doubles again. After 64 merges you overflow.+-- This solution would have the same time complexity as plusUFM, namely O(n+m).+--+-- The solution I ended up with has time complexity of+-- O(m log m + m * min (n+m, W)) where m is the smaller set.+-- It simply inserts the elements of the smaller set into the larger+-- set in the order that they were inserted into the smaller set. That's+-- O(m log m) for extracting the elements from the smaller set in the+-- insertion order and O(m * min(n+m, W)) to insert them into the bigger+-- set.++plusUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt+plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j)+  -- we will use the upper bound on the tag as a proxy for the set size,+  -- to insert the smaller one into the bigger one+  | i > j = insertUDFMIntoLeft udfml udfmr+  | otherwise = insertUDFMIntoLeft udfmr udfml++insertUDFMIntoLeft :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt+insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr++insertUDFMIntoLeft_C+  :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt+insertUDFMIntoLeft_C f udfml udfmr =+  addListToUDFM_Directly_C f udfml $ udfmToList udfmr++lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt+lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m++lookupUDFM_Directly :: UniqDFM elt -> Unique -> Maybe elt+lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m++elemUDFM :: Uniquable key => key -> UniqDFM elt -> Bool+elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m++-- | Performs a deterministic fold over the UniqDFM.+-- It's O(n log n) while the corresponding function on `UniqFM` is O(n).+foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a+foldUDFM k z m = foldr k z (eltsUDFM m)++-- | Performs a nondeterministic fold over the UniqDFM.+-- It's O(n), same as the corresponding function on `UniqFM`.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a+nonDetFoldUDFM k z (UDFM m _i) = foldr k z $ map taggedFst $ M.elems m++eltsUDFM :: UniqDFM elt -> [elt]+eltsUDFM (UDFM m _i) =+  map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m++filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt+filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i++filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM elt -> UniqDFM elt+filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i+  where+  p' k (TaggedVal v _) = p (getUnique k) v++-- | Converts `UniqDFM` to a list, with elements in deterministic order.+-- It's O(n log n) while the corresponding function on `UniqFM` is O(n).+udfmToList :: UniqDFM elt -> [(Unique, elt)]+udfmToList (UDFM m _i) =+  [ (getUnique k, taggedFst v)+  | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]++-- Determines whether two 'UniqDFM's contain the same keys.+equalKeysUDFM :: UniqDFM a -> UniqDFM b -> Bool+equalKeysUDFM (UDFM m1 _) (UDFM m2 _) = liftEq (\_ _ -> True) m1 m2++isNullUDFM :: UniqDFM elt -> Bool+isNullUDFM (UDFM m _) = M.null m++sizeUDFM :: UniqDFM elt -> Int+sizeUDFM (UDFM m _i) = M.size m++intersectUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt+intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i+  -- M.intersection is left biased, that means the result will only have+  -- a subset of elements from the left set, so `i` is a good upper bound.++udfmIntersectUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1+udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i+  -- M.intersection is left biased, that means the result will only have+  -- a subset of elements from the left set, so `i` is a good upper bound.++intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool+intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y)++disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool+disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y)++disjointUdfmUfm :: UniqDFM elt -> UniqFM elt2 -> Bool+disjointUdfmUfm (UDFM x _i) y = M.null (M.intersection x (ufmToIntMap y))++minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1+minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i+  -- M.difference returns a subset of a left set, so `i` is a good upper+  -- bound.++udfmMinusUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1+udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i+  -- M.difference returns a subset of a left set, so `i` is a good upper+  -- bound.++-- | Partition UniqDFM into two UniqDFMs according to the predicate+partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt)+partitionUDFM p (UDFM m i) =+  case M.partition (p . taggedFst) m of+    (left, right) -> (UDFM left i, UDFM right i)++-- | Delete a list of elements from a UniqDFM+delListFromUDFM  :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt+delListFromUDFM = foldl' delFromUDFM++-- | This allows for lossy conversion from UniqDFM to UniqFM+udfmToUfm :: UniqDFM elt -> UniqFM elt+udfmToUfm (UDFM m _i) =+  listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m]++listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt+listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM++listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt+listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM++-- | Apply a function to a particular element+adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt+adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i++-- | The expression (alterUDFM f k map) alters value x at k, or absence+-- thereof. alterUDFM can be used to insert, delete, or update a value in+-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are+-- more efficient.+alterUDFM+  :: Uniquable key+  => (Maybe elt -> Maybe elt)  -- How to adjust+  -> UniqDFM elt               -- old+  -> key                       -- new+  -> UniqDFM elt               -- result+alterUDFM f (UDFM m i) k =+  UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1)+  where+  alterf Nothing = inject $ f Nothing+  alterf (Just (TaggedVal v _)) = inject $ f (Just v)+  inject Nothing = Nothing+  inject (Just v) = Just $ TaggedVal v i++-- | Map a function over every value in a UniqDFM+mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2+mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i++anyUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool+anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m++allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool+allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m++instance Semi.Semigroup (UniqDFM a) where+  (<>) = plusUDFM++instance Monoid (UniqDFM a) where+  mempty = emptyUDFM+  mappend = (Semi.<>)++-- This should not be used in committed code, provided for convenience to+-- make ad-hoc conversions when developing+alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt+alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList++-- Output-ery++instance Outputable a => Outputable (UniqDFM a) where+    ppr ufm = pprUniqDFM ppr ufm++pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc+pprUniqDFM ppr_elt ufm+  = brackets $ fsep $ punctuate comma $+    [ ppr uq <+> text ":->" <+> ppr_elt elt+    | (uq, elt) <- udfmToList ufm ]++pprUDFM :: UniqDFM a    -- ^ The things to be pretty printed+       -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements+       -> SDoc          -- ^ 'SDoc' where the things have been pretty+                        -- printed+pprUDFM ufm pp = pp (eltsUDFM ufm)
+ compiler/GHC/Types/Unique/DSet.hs view
@@ -0,0 +1,141 @@+-- (c) Bartosz Nitka, Facebook, 2015++-- |+-- Specialised deterministic sets, for things with @Uniques@+--+-- Based on 'UniqDFM's (as you would expect).+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need it.+--+-- Basically, the things need to be in class 'Uniquable'.++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}++module GHC.Types.Unique.DSet (+        -- * Unique set type+        UniqDSet,    -- type synonym for UniqFM a+        getUniqDSet,+        pprUniqDSet,++        -- ** Manipulating these sets+        delOneFromUniqDSet, delListFromUniqDSet,+        emptyUniqDSet,+        unitUniqDSet,+        mkUniqDSet,+        addOneToUniqDSet, addListToUniqDSet,+        unionUniqDSets, unionManyUniqDSets,+        minusUniqDSet, uniqDSetMinusUniqSet,+        intersectUniqDSets, uniqDSetIntersectUniqSet,+        foldUniqDSet,+        elementOfUniqDSet,+        filterUniqDSet,+        sizeUniqDSet,+        isEmptyUniqDSet,+        lookupUniqDSet,+        uniqDSetToList,+        partitionUniqDSet,+        mapUniqDSet+    ) where++import GhcPrelude++import Outputable+import GHC.Types.Unique.DFM+import GHC.Types.Unique.Set+import GHC.Types.Unique++import Data.Coerce+import Data.Data+import qualified Data.Semigroup as Semi++-- See Note [UniqSet invariant] in GHC.Types.Unique.Set for why we want a newtype here.+-- Beyond preserving invariants, we may also want to 'override' typeclass+-- instances.++newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a}+                   deriving (Data, Semi.Semigroup, Monoid)++emptyUniqDSet :: UniqDSet a+emptyUniqDSet = UniqDSet emptyUDFM++unitUniqDSet :: Uniquable a => a -> UniqDSet a+unitUniqDSet x = UniqDSet (unitUDFM x x)++mkUniqDSet :: Uniquable a => [a] -> UniqDSet a+mkUniqDSet = foldl' addOneToUniqDSet emptyUniqDSet++-- The new element always goes to the right of existing ones.+addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a+addOneToUniqDSet (UniqDSet set) x = UniqDSet (addToUDFM set x x)++addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a+addListToUniqDSet = foldl' addOneToUniqDSet++delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a+delOneFromUniqDSet (UniqDSet s) = UniqDSet . delFromUDFM s++delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a+delListFromUniqDSet (UniqDSet s) = UniqDSet . delListFromUDFM s++unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a+unionUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (plusUDFM s t)++unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a+unionManyUniqDSets [] = emptyUniqDSet+unionManyUniqDSets sets = foldr1 unionUniqDSets sets++minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a+minusUniqDSet (UniqDSet s) (UniqDSet t) = UniqDSet (minusUDFM s t)++uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a+uniqDSetMinusUniqSet xs ys+  = UniqDSet (udfmMinusUFM (getUniqDSet xs) (getUniqSet ys))++intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a+intersectUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (intersectUDFM s t)++uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a+uniqDSetIntersectUniqSet xs ys+  = UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys))++foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b+foldUniqDSet c n (UniqDSet s) = foldUDFM c n s++elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool+elementOfUniqDSet k = elemUDFM k . getUniqDSet++filterUniqDSet :: (a -> Bool) -> UniqDSet a -> UniqDSet a+filterUniqDSet p (UniqDSet s) = UniqDSet (filterUDFM p s)++sizeUniqDSet :: UniqDSet a -> Int+sizeUniqDSet = sizeUDFM . getUniqDSet++isEmptyUniqDSet :: UniqDSet a -> Bool+isEmptyUniqDSet = isNullUDFM . getUniqDSet++lookupUniqDSet :: Uniquable a => UniqDSet a -> a -> Maybe a+lookupUniqDSet = lookupUDFM . getUniqDSet++uniqDSetToList :: UniqDSet a -> [a]+uniqDSetToList = eltsUDFM . getUniqDSet++partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a)+partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet++-- See Note [UniqSet invariant] in GHC.Types.Unique.Set+mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b+mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList++-- Two 'UniqDSet's are considered equal if they contain the same+-- uniques.+instance Eq (UniqDSet a) where+  UniqDSet a == UniqDSet b = equalKeysUDFM a b++getUniqDSet :: UniqDSet a -> UniqDFM a+getUniqDSet = getUniqDSet'++instance Outputable a => Outputable (UniqDSet a) where+  ppr = pprUniqDSet ppr++pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc+pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList
+ compiler/GHC/Types/Unique/FM.hs view
@@ -0,0 +1,416 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1994-1998+++UniqFM: Specialised finite maps, for things with @Uniques@.++Basically, the things need to be in class @Uniquable@, and we use the+@getUnique@ method to grab their @Uniques@.++(A similar thing to @UniqSet@, as opposed to @Set@.)++The interface is based on @FiniteMap@s, but the implementation uses+@Data.IntMap@, which is both maintained and faster than the past+implementation (see commit log).++The @UniqFM@ interface maps directly to Data.IntMap, only+``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased+and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order+of arguments of combining function.+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wall #-}++module GHC.Types.Unique.FM (+        -- * Unique-keyed mappings+        UniqFM,           -- abstract type+        NonDetUniqFM(..), -- wrapper for opting into nondeterminism++        -- ** Manipulating those mappings+        emptyUFM,+        unitUFM,+        unitDirectlyUFM,+        listToUFM,+        listToUFM_Directly,+        listToUFM_C,+        addToUFM,addToUFM_C,addToUFM_Acc,+        addListToUFM,addListToUFM_C,+        addToUFM_Directly,+        addListToUFM_Directly,+        adjustUFM, alterUFM,+        adjustUFM_Directly,+        delFromUFM,+        delFromUFM_Directly,+        delListFromUFM,+        delListFromUFM_Directly,+        plusUFM,+        plusUFM_C,+        plusUFM_CD,+        plusMaybeUFM_C,+        plusUFMList,+        minusUFM,+        intersectUFM,+        intersectUFM_C,+        disjointUFM,+        equalKeysUFM,+        nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly,+        anyUFM, allUFM, seqEltsUFM,+        mapUFM, mapUFM_Directly,+        elemUFM, elemUFM_Directly,+        filterUFM, filterUFM_Directly, partitionUFM,+        sizeUFM,+        isNullUFM,+        lookupUFM, lookupUFM_Directly,+        lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,+        nonDetEltsUFM, eltsUFM, nonDetKeysUFM,+        ufmToSet_Directly,+        nonDetUFMToList, ufmToIntMap,+        pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM+    ) where++import GhcPrelude++import GHC.Types.Unique ( Uniquable(..), Unique, getKey )+import Outputable++import qualified Data.IntMap as M+import qualified Data.IntSet as S+import Data.Data+import qualified Data.Semigroup as Semi+import Data.Functor.Classes (Eq1 (..))+++newtype UniqFM ele = UFM (M.IntMap ele)+  deriving (Data, Eq, Functor)+  -- Nondeterministic Foldable and Traversable instances are accessible through+  -- use of the 'NonDetUniqFM' wrapper.+  -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism.++emptyUFM :: UniqFM elt+emptyUFM = UFM M.empty++isNullUFM :: UniqFM elt -> Bool+isNullUFM (UFM m) = M.null m++unitUFM :: Uniquable key => key -> elt -> UniqFM elt+unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v)++-- when you've got the Unique already+unitDirectlyUFM :: Unique -> elt -> UniqFM elt+unitDirectlyUFM u v = UFM (M.singleton (getKey u) v)++listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt+listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM++listToUFM_Directly :: [(Unique, elt)] -> UniqFM elt+listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM++listToUFM_C+  :: Uniquable key+  => (elt -> elt -> elt)+  -> [(key, elt)]+  -> UniqFM elt+listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM++addToUFM :: Uniquable key => UniqFM elt -> key -> elt  -> UniqFM elt+addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m)++addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt+addListToUFM = foldl' (\m (k, v) -> addToUFM m k v)++addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt+addListToUFM_Directly = foldl' (\m (k, v) -> addToUFM_Directly m k v)++addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt+addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m)++addToUFM_C+  :: Uniquable key+  => (elt -> elt -> elt)  -- old -> new -> result+  -> UniqFM elt           -- old+  -> key -> elt           -- new+  -> UniqFM elt           -- result+-- Arguments of combining function of M.insertWith and addToUFM_C are flipped.+addToUFM_C f (UFM m) k v =+  UFM (M.insertWith (flip f) (getKey $ getUnique k) v m)++addToUFM_Acc+  :: Uniquable key+  => (elt -> elts -> elts)  -- Add to existing+  -> (elt -> elts)          -- New element+  -> UniqFM elts            -- old+  -> key -> elt             -- new+  -> UniqFM elts            -- result+addToUFM_Acc exi new (UFM m) k v =+  UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m)++alterUFM+  :: Uniquable key+  => (Maybe elt -> Maybe elt)  -- How to adjust+  -> UniqFM elt                -- old+  -> key                       -- new+  -> UniqFM elt                -- result+alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m)++addListToUFM_C+  :: Uniquable key+  => (elt -> elt -> elt)+  -> UniqFM elt -> [(key,elt)]+  -> UniqFM elt+addListToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v)++adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt+adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m)++adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt+adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m)++delFromUFM :: Uniquable key => UniqFM elt -> key    -> UniqFM elt+delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)++delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt+delListFromUFM = foldl' delFromUFM++delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt+delListFromUFM_Directly = foldl' delFromUFM_Directly++delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt+delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)++-- Bindings in right argument shadow those in the left+plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt+-- M.union is left-biased, plusUFM should be right-biased.+plusUFM (UFM x) (UFM y) = UFM (M.union y x)+     -- Note (M.union y x), with arguments flipped+     -- M.union is left-biased, plusUFM should be right-biased.++plusUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt+plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)++-- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the+-- combinding function and `d1` resp. `d2` as the default value if+-- there is no entry in `m1` reps. `m2`. The domain is the union of+-- the domains of `m1` and `m2`.+--+-- Representative example:+--+-- @+-- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42+--    == {A: f 1 42, B: f 2 3, C: f 23 4 }+-- @+plusUFM_CD+  :: (elt -> elt -> elt)+  -> UniqFM elt  -- map X+  -> elt         -- default for X+  -> UniqFM elt  -- map Y+  -> elt         -- default for Y+  -> UniqFM elt+plusUFM_CD f (UFM xm) dx (UFM ym) dy+  = UFM $ M.mergeWithKey+      (\_ x y -> Just (x `f` y))+      (M.map (\x -> x `f` dy))+      (M.map (\y -> dx `f` y))+      xm ym++plusMaybeUFM_C :: (elt -> elt -> Maybe elt)+               -> UniqFM elt -> UniqFM elt -> UniqFM elt+plusMaybeUFM_C f (UFM xm) (UFM ym)+    = UFM $ M.mergeWithKey+        (\_ x y -> x `f` y)+        id+        id+        xm ym++plusUFMList :: [UniqFM elt] -> UniqFM elt+plusUFMList = foldl' plusUFM emptyUFM++minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1+minusUFM (UFM x) (UFM y) = UFM (M.difference x y)++intersectUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1+intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y)++intersectUFM_C+  :: (elt1 -> elt2 -> elt3)+  -> UniqFM elt1+  -> UniqFM elt2+  -> UniqFM elt3+intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)++disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool+disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y)++foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a+foldUFM k z (UFM m) = M.foldr k z m++mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2+mapUFM f (UFM m) = UFM (M.map f m)++mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2+mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)++filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt+filterUFM p (UFM m) = UFM (M.filter p m)++filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt+filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m)++partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt)+partitionUFM p (UFM m) =+  case M.partition p m of+    (left, right) -> (UFM left, UFM right)++sizeUFM :: UniqFM elt -> Int+sizeUFM (UFM m) = M.size m++elemUFM :: Uniquable key => key -> UniqFM elt -> Bool+elemUFM k (UFM m) = M.member (getKey $ getUnique k) m++elemUFM_Directly :: Unique -> UniqFM elt -> Bool+elemUFM_Directly u (UFM m) = M.member (getKey u) m++lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt+lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m++-- when you've got the Unique already+lookupUFM_Directly :: UniqFM elt -> Unique -> Maybe elt+lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m++lookupWithDefaultUFM :: Uniquable key => UniqFM elt -> elt -> key -> elt+lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m++lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt+lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m++eltsUFM :: UniqFM elt -> [elt]+eltsUFM (UFM m) = M.elems m++ufmToSet_Directly :: UniqFM elt -> S.IntSet+ufmToSet_Directly (UFM m) = M.keysSet m++anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool+anyUFM p (UFM m) = M.foldr ((||) . p) False m++allUFM :: (elt -> Bool) -> UniqFM elt -> Bool+allUFM p (UFM m) = M.foldr ((&&) . p) True m++seqEltsUFM :: ([elt] -> ()) -> UniqFM elt -> ()+seqEltsUFM seqList = seqList . nonDetEltsUFM+  -- It's OK to use nonDetEltsUFM here because the type guarantees that+  -- the only interesting thing this function can do is to force the+  -- elements.++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetEltsUFM :: UniqFM elt -> [elt]+nonDetEltsUFM (UFM m) = M.elems m++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetKeysUFM :: UniqFM elt -> [Unique]+nonDetKeysUFM (UFM m) = map getUnique $ M.keys m++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a+nonDetFoldUFM k z (UFM m) = M.foldr k z m++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a+nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetUFMToList :: UniqFM elt -> [(Unique, elt)]+nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m++-- | A wrapper around 'UniqFM' with the sole purpose of informing call sites+-- that the provided 'Foldable' and 'Traversable' instances are+-- nondeterministic.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism.+newtype NonDetUniqFM ele = NonDetUniqFM { getNonDet :: UniqFM ele }+  deriving (Functor)++-- | Inherently nondeterministic.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism.+instance Foldable NonDetUniqFM where+  foldr f z (NonDetUniqFM (UFM m)) = foldr f z m++-- | Inherently nondeterministic.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism.+instance Traversable NonDetUniqFM where+  traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m++ufmToIntMap :: UniqFM elt -> M.IntMap elt+ufmToIntMap (UFM m) = m++-- Determines whether two 'UniqFM's contain the same keys.+equalKeysUFM :: UniqFM a -> UniqFM b -> Bool+equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2++-- Instances++instance Semi.Semigroup (UniqFM a) where+  (<>) = plusUFM++instance Monoid (UniqFM a) where+    mempty = emptyUFM+    mappend = (Semi.<>)++-- Output-ery++instance Outputable a => Outputable (UniqFM a) where+    ppr ufm = pprUniqFM ppr ufm++pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc+pprUniqFM ppr_elt ufm+  = brackets $ fsep $ punctuate comma $+    [ ppr uq <+> text ":->" <+> ppr_elt elt+    | (uq, elt) <- nonDetUFMToList ufm ]+  -- It's OK to use nonDetUFMToList here because we only use it for+  -- pretty-printing.++-- | Pretty-print a non-deterministic set.+-- The order of variables is non-deterministic and for pretty-printing that+-- shouldn't be a problem.+-- Having this function helps contain the non-determinism created with+-- nonDetEltsUFM.+pprUFM :: UniqFM a      -- ^ The things to be pretty printed+       -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements+       -> SDoc          -- ^ 'SDoc' where the things have been pretty+                        -- printed+pprUFM ufm pp = pp (nonDetEltsUFM ufm)++-- | Pretty-print a non-deterministic set.+-- The order of variables is non-deterministic and for pretty-printing that+-- shouldn't be a problem.+-- Having this function helps contain the non-determinism created with+-- nonDetUFMToList.+pprUFMWithKeys+       :: UniqFM a                -- ^ The things to be pretty printed+       -> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements+       -> SDoc                    -- ^ 'SDoc' where the things have been pretty+                                  -- printed+pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm)++-- | Determines the pluralisation suffix appropriate for the length of a set+-- in the same way that plural from Outputable does for lists.+pluralUFM :: UniqFM a -> SDoc+pluralUFM ufm+  | sizeUFM ufm == 1 = empty+  | otherwise = char 's'
+ compiler/GHC/Types/Unique/Set.hs view
@@ -0,0 +1,195 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1994-1998++\section[UniqSet]{Specialised sets, for things with @Uniques@}++Based on @UniqFMs@ (as you would expect).++Basically, the things need to be in class @Uniquable@.+-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}++module GHC.Types.Unique.Set (+        -- * Unique set type+        UniqSet,    -- type synonym for UniqFM a+        getUniqSet,+        pprUniqSet,++        -- ** Manipulating these sets+        emptyUniqSet,+        unitUniqSet,+        mkUniqSet,+        addOneToUniqSet, addListToUniqSet,+        delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet,+        delListFromUniqSet_Directly,+        unionUniqSets, unionManyUniqSets,+        minusUniqSet, uniqSetMinusUFM,+        intersectUniqSets,+        restrictUniqSetToUFM,+        uniqSetAny, uniqSetAll,+        elementOfUniqSet,+        elemUniqSet_Directly,+        filterUniqSet,+        filterUniqSet_Directly,+        sizeUniqSet,+        isEmptyUniqSet,+        lookupUniqSet,+        lookupUniqSet_Directly,+        partitionUniqSet,+        mapUniqSet,+        unsafeUFMToUniqSet,+        nonDetEltsUniqSet,+        nonDetKeysUniqSet,+        nonDetFoldUniqSet,+        nonDetFoldUniqSet_Directly+    ) where++import GhcPrelude++import GHC.Types.Unique.FM+import GHC.Types.Unique+import Data.Coerce+import Outputable+import Data.Data+import qualified Data.Semigroup as Semi++-- Note [UniqSet invariant]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- UniqSet has the following invariant:+--   The keys in the map are the uniques of the values+-- It means that to implement mapUniqSet you have to update+-- both the keys and the values.++newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a}+                  deriving (Data, Semi.Semigroup, Monoid)++emptyUniqSet :: UniqSet a+emptyUniqSet = UniqSet emptyUFM++unitUniqSet :: Uniquable a => a -> UniqSet a+unitUniqSet x = UniqSet $ unitUFM x x++mkUniqSet :: Uniquable a => [a]  -> UniqSet a+mkUniqSet = foldl' addOneToUniqSet emptyUniqSet++addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a+addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x)++addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a+addListToUniqSet = foldl' addOneToUniqSet++delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a+delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a)++delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a+delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u)++delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a+delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l)++delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a+delListFromUniqSet_Directly (UniqSet s) l =+    UniqSet (delListFromUFM_Directly s l)++unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a+unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t)++unionManyUniqSets :: [UniqSet a] -> UniqSet a+unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet++minusUniqSet  :: UniqSet a -> UniqSet a -> UniqSet a+minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t)++intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a+intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t)++restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a+restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m)++uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a+uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t)++elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool+elementOfUniqSet a (UniqSet s) = elemUFM a s++elemUniqSet_Directly :: Unique -> UniqSet a -> Bool+elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s++filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a+filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s)++filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt+filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s)++partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a)+partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s)++uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool+uniqSetAny p (UniqSet s) = anyUFM p s++uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool+uniqSetAll p (UniqSet s) = allUFM p s++sizeUniqSet :: UniqSet a -> Int+sizeUniqSet (UniqSet s) = sizeUFM s++isEmptyUniqSet :: UniqSet a -> Bool+isEmptyUniqSet (UniqSet s) = isNullUFM s++lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b+lookupUniqSet (UniqSet s) k = lookupUFM s k++lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a+lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetEltsUniqSet :: UniqSet elt -> [elt]+nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet'++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetKeysUniqSet :: UniqSet elt -> [Unique]+nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet'++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a+nonDetFoldUniqSet c n (UniqSet s) = nonDetFoldUFM c n s++-- See Note [Deterministic UniqFM] to learn about nondeterminism.+-- If you use this please provide a justification why it doesn't introduce+-- nondeterminism.+nonDetFoldUniqSet_Directly:: (Unique -> elt -> a -> a) -> a -> UniqSet elt -> a+nonDetFoldUniqSet_Directly f n (UniqSet s) = nonDetFoldUFM_Directly f n s++-- See Note [UniqSet invariant]+mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b+mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet++-- Two 'UniqSet's are considered equal if they contain the same+-- uniques.+instance Eq (UniqSet a) where+  UniqSet a == UniqSet b = equalKeysUFM a b++getUniqSet :: UniqSet a -> UniqFM a+getUniqSet = getUniqSet'++-- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@+-- assuming, without checking, that it maps each 'Unique' to a value+-- that has that 'Unique'. See Note [UniqSet invariant].+unsafeUFMToUniqSet :: UniqFM a -> UniqSet a+unsafeUFMToUniqSet = UniqSet++instance Outputable a => Outputable (UniqSet a) where+    ppr = pprUniqSet ppr++pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc+-- It's OK to use nonDetUFMToList here because we only use it for+-- pretty-printing.+pprUniqSet f = braces . pprWithCommas f . nonDetEltsUniqSet
+ compiler/GHC/Types/Unique/Supply.hs view
@@ -0,0 +1,223 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE BangPatterns #-}++#if !defined(GHC_LOADED_INTO_GHCI)+{-# LANGUAGE UnboxedTuples #-}+#endif++module GHC.Types.Unique.Supply (+        -- * Main data type+        UniqSupply, -- Abstractly++        -- ** Operations on supplies+        uniqFromSupply, uniqsFromSupply, -- basic ops+        takeUniqFromSupply, uniqFromMask,++        mkSplitUniqSupply,+        splitUniqSupply, listSplitUniqSupply,++        -- * Unique supply monad and its abstraction+        UniqSM, MonadUnique(..),++        -- ** Operations on the monad+        initUs, initUs_,++        -- * Set supply strategy+        initUniqSupply+  ) where++import GhcPrelude++import GHC.Types.Unique+import PlainPanic (panic)++import GHC.IO++import MonadUtils+import Control.Monad+import Data.Bits+import Data.Char++#include "Unique.h"++{-+************************************************************************+*                                                                      *+\subsection{Splittable Unique supply: @UniqSupply@}+*                                                                      *+************************************************************************+-}++-- | Unique Supply+--+-- A value of type 'UniqSupply' is unique, and it can+-- supply /one/ distinct 'Unique'.  Also, from the supply, one can+-- also manufacture an arbitrary number of further 'UniqueSupply' values,+-- which will be distinct from the first and from all others.+data UniqSupply+  = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this+                   UniqSupply UniqSupply+                                -- when split => these two supplies++mkSplitUniqSupply :: Char -> IO UniqSupply+-- ^ Create a unique supply out of thin air. The character given must+-- be distinct from those of all calls to this function in the compiler+-- for the values generated to be truly unique.++splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)+-- ^ Build two 'UniqSupply' from a single one, each of which+-- can supply its own 'Unique'.+listSplitUniqSupply :: UniqSupply -> [UniqSupply]+-- ^ Create an infinite list of 'UniqSupply' from a single one+uniqFromSupply  :: UniqSupply -> Unique+-- ^ Obtain the 'Unique' from this particular 'UniqSupply'+uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite+-- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply+takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)+-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply++uniqFromMask :: Char -> IO Unique+uniqFromMask mask+  = do { uqNum <- genSym+       ; return $! mkUnique mask uqNum }++mkSplitUniqSupply c+  = case ord c `shiftL` uNIQUE_BITS of+     !mask -> let+        -- here comes THE MAGIC:++        -- This is one of the most hammered bits in the whole compiler+        mk_supply+          -- NB: Use unsafeInterleaveIO for thread-safety.+          = unsafeInterleaveIO (+                genSym      >>= \ u ->+                mk_supply   >>= \ s1 ->+                mk_supply   >>= \ s2 ->+                return (MkSplitUniqSupply (mask .|. u) s1 s2)+            )+       in+       mk_supply++foreign import ccall unsafe "ghc_lib_parser_genSym" genSym :: IO Int+foreign import ccall unsafe "ghc_lib_parser_initGenSym" initUniqSupply :: Int -> Int -> IO ()++splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)+listSplitUniqSupply  (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2++uniqFromSupply  (MkSplitUniqSupply n _ _)  = mkUniqueGrimily n+uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2+takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1)++{-+************************************************************************+*                                                                      *+\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@}+*                                                                      *+************************************************************************+-}++-- Avoids using unboxed tuples when loading into GHCi+#if !defined(GHC_LOADED_INTO_GHCI)++type UniqResult result = (# result, UniqSupply #)++pattern UniqResult :: a -> b -> (# a, b #)+pattern UniqResult x y = (# x, y #)+{-# COMPLETE UniqResult #-}++#else++data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply+  deriving (Functor)++#endif++-- | A monad which just gives the ability to obtain 'Unique's+newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }+    deriving (Functor)++instance Monad UniqSM where+  (>>=) = thenUs+  (>>)  = (*>)++instance Applicative UniqSM where+    pure = returnUs+    (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of+                            UniqResult ff us1 -> case x us1 of+                              UniqResult xx us2 -> UniqResult (ff xx) us2+    (*>) = thenUs_++-- TODO: try to get rid of this instance+instance MonadFail UniqSM where+    fail = panic++-- | Run the 'UniqSM' action, returning the final 'UniqSupply'+initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)+initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) }++-- | Run the 'UniqSM' action, discarding the final 'UniqSupply'+initUs_ :: UniqSupply -> UniqSM a -> a+initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r }++{-# INLINE thenUs #-}+{-# INLINE returnUs #-}+{-# INLINE splitUniqSupply #-}++-- @thenUs@ is where we split the @UniqSupply@.++liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)+liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1)++instance MonadFix UniqSM where+    mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1)++thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b+thenUs (USM expr) cont+  = USM (\us0 -> case (expr us0) of+                   UniqResult result us1 -> unUSM (cont result) us1)++thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b+thenUs_ (USM expr) (USM cont)+  = USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 })++returnUs :: a -> UniqSM a+returnUs result = USM (\us -> UniqResult result us)++getUs :: UniqSM UniqSupply+getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2)++-- | A monad for generating unique identifiers+class Monad m => MonadUnique m where+    -- | Get a new UniqueSupply+    getUniqueSupplyM :: m UniqSupply+    -- | Get a new unique identifier+    getUniqueM  :: m Unique+    -- | Get an infinite list of new unique identifiers+    getUniquesM :: m [Unique]++    -- This default definition of getUniqueM, while correct, is not as+    -- efficient as it could be since it needlessly generates and throws away+    -- an extra Unique. For your instances consider providing an explicit+    -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly.+    getUniqueM  = liftM uniqFromSupply  getUniqueSupplyM+    getUniquesM = liftM uniqsFromSupply getUniqueSupplyM++instance MonadUnique UniqSM where+    getUniqueSupplyM = getUs+    getUniqueM  = getUniqueUs+    getUniquesM = getUniquesUs++getUniqueUs :: UniqSM Unique+getUniqueUs = USM (\us0 -> case takeUniqFromSupply us0 of+                           (u,us1) -> UniqResult u us1)++getUniquesUs :: UniqSM [Unique]+getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of+                            (us1,us2) -> UniqResult (uniqsFromSupply us1) us2)
+ compiler/GHC/Types/Var.hs view
@@ -0,0 +1,763 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section{@Vars@: Variables}+-}++{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++-- |+-- #name_types#+-- GHC uses several kinds of name internally:+--+-- * 'OccName.OccName': see "OccName#name_types"+--+-- * 'RdrName.RdrName': see "RdrName#name_types"+--+-- * 'Name.Name': see "Name#name_types"+--+-- * 'Id.Id': see "Id#name_types"+--+-- * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally+--   potentially contain type variables, which have a 'GHC.Core.TyCo.Rep.Kind'+--   rather than a 'GHC.Core.TyCo.Rep.Type' and only contain some extra+--   details during typechecking.+--+--   These 'Var.Var' names may either be global or local, see "Var#globalvslocal"+--+-- #globalvslocal#+-- Global 'Id's and 'Var's are those that are imported or correspond+--    to a data constructor, primitive operation, or record selectors.+-- Local 'Id's and 'Var's are those bound within an expression+--    (e.g. by a lambda) or at the top level of the module being compiled.++module GHC.Types.Var (+        -- * The main data type and synonyms+        Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId,+        TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar,++        -- * In and Out variants+        InVar,  InCoVar,  InId,  InTyVar,+        OutVar, OutCoVar, OutId, OutTyVar,++        -- ** Taking 'Var's apart+        varName, varUnique, varType,++        -- ** Modifying 'Var's+        setVarName, setVarUnique, setVarType, updateVarType,+        updateVarTypeM,++        -- ** Constructing, taking apart, modifying 'Id's+        mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar,+        idInfo, idDetails,+        lazySetIdInfo, setIdDetails, globaliseId,+        setIdExported, setIdNotExported,++        -- ** Predicates+        isId, isTyVar, isTcTyVar,+        isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar,+        isGlobalId, isExportedId,+        mustHaveLocalBinding,++        -- * ArgFlags+        ArgFlag(..), isVisibleArgFlag, isInvisibleArgFlag, sameVis,+        AnonArgFlag(..), ForallVisFlag(..), argToForallVisFlag,++        -- * TyVar's+        VarBndr(..), TyCoVarBinder, TyVarBinder,+        binderVar, binderVars, binderArgFlag, binderType,+        mkTyCoVarBinder, mkTyCoVarBinders,+        mkTyVarBinder, mkTyVarBinders,+        isTyVarBinder,++        -- ** Constructing TyVar's+        mkTyVar, mkTcTyVar,++        -- ** Taking 'TyVar's apart+        tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,++        -- ** Modifying 'TyVar's+        setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind,+        updateTyVarKindM,++        nonDetCmpVar++    ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-}   GHC.Core.TyCo.Rep( Type, Kind )+import {-# SOURCE #-}   GHC.Core.TyCo.Ppr( pprKind )+import {-# SOURCE #-}   TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv )+import {-# SOURCE #-}   GHC.Types.Id.Info( IdDetails, IdInfo, coVarDetails, isCoVarDetails,+                                           vanillaIdInfo, pprIdDetails )++import GHC.Types.Name hiding (varName)+import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique+                        , mkUniqueGrimily, nonDetCmpUnique )+import Util+import Binary+import Outputable++import Data.Data++{-+************************************************************************+*                                                                      *+                     Synonyms+*                                                                      *+************************************************************************+-- These synonyms are here and not in Id because otherwise we need a very+-- large number of SOURCE imports of Id.hs :-(+-}++-- | Identifier+type Id    = Var       -- A term-level identifier+                       --  predicate: isId++-- | Coercion Variable+type CoVar = Id        -- See Note [Evidence: EvIds and CoVars]+                       --   predicate: isCoVar++-- |+type NcId  = Id        -- A term-level (value) variable that is+                       -- /not/ an (unlifted) coercion+                       --    predicate: isNonCoVarId++-- | Type or kind Variable+type TyVar   = Var     -- Type *or* kind variable (historical)++-- | Type or Kind Variable+type TKVar   = Var     -- Type *or* kind variable (historical)++-- | Type variable that might be a metavariable+type TcTyVar = Var++-- | Type Variable+type TypeVar = Var     -- Definitely a type variable++-- | Kind Variable+type KindVar = Var     -- Definitely a kind variable+                       -- See Note [Kind and type variables]++-- See Note [Evidence: EvIds and CoVars]+-- | Evidence Identifier+type EvId   = Id        -- Term-level evidence: DictId, IpId, or EqVar++-- | Evidence Variable+type EvVar  = EvId      -- ...historical name for EvId++-- | Dictionary Function Identifier+type DFunId = Id        -- A dictionary function++-- | Dictionary Identifier+type DictId = EvId      -- A dictionary variable++-- | Implicit parameter Identifier+type IpId   = EvId      -- A term-level implicit parameter++-- | Equality Variable+type EqVar  = EvId      -- Boxed equality evidence+type JoinId = Id        -- A join variable++-- | Type or Coercion Variable+type TyCoVar = Id       -- Type, *or* coercion variable+                        --   predicate: isTyCoVar+++{- Many passes apply a substitution, and it's very handy to have type+   synonyms to remind us whether or not the substitution has been applied -}++type InVar      = Var+type InTyVar    = TyVar+type InCoVar    = CoVar+type InId       = Id+type OutVar     = Var+type OutTyVar   = TyVar+type OutCoVar   = CoVar+type OutId      = Id++++{- Note [Evidence: EvIds and CoVars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* An EvId (evidence Id) is a term-level evidence variable+  (dictionary, implicit parameter, or equality). Could be boxed or unboxed.++* DictId, IpId, and EqVar are synonyms when we know what kind of+  evidence we are talking about.  For example, an EqVar has type (t1 ~ t2).++* A CoVar is always an un-lifted coercion, of type (t1 ~# t2) or (t1 ~R# t2)++Note [Kind and type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before kind polymorphism, TyVar were used to mean type variables. Now+they are used to mean kind *or* type variables. KindVar is used when we+know for sure that it is a kind variable. In future, we might want to+go over the whole compiler code to use:+   - TKVar   to mean kind or type variables+   - TypeVar to mean         type variables only+   - KindVar to mean kind         variables+++************************************************************************+*                                                                      *+\subsection{The main data type declarations}+*                                                                      *+************************************************************************+++Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a+@Type@, and an @IdInfo@ (non-essential info about it, e.g.,+strictness).  The essential info about different kinds of @Vars@ is+in its @VarDetails@.+-}++-- | Variable+--+-- Essentially a typed 'Name', that may also contain some additional information+-- about the 'Var' and its use sites.+data Var+  = TyVar {  -- Type and kind variables+             -- see Note [Kind and type variables]+        varName    :: !Name,+        realUnique :: {-# UNPACK #-} !Int,+                                     -- ^ Key for fast comparison+                                     -- Identical to the Unique in the name,+                                     -- cached here for speed+        varType    :: Kind           -- ^ The type or kind of the 'Var' in question+ }++  | TcTyVar {                           -- Used only during type inference+                                        -- Used for kind variables during+                                        -- inference, as well+        varName        :: !Name,+        realUnique     :: {-# UNPACK #-} !Int,+        varType        :: Kind,+        tc_tv_details  :: TcTyVarDetails+  }++  | Id {+        varName    :: !Name,+        realUnique :: {-# UNPACK #-} !Int,+        varType    :: Type,+        idScope    :: IdScope,+        id_details :: IdDetails,        -- Stable, doesn't change+        id_info    :: IdInfo }          -- Unstable, updated by simplifier++-- | Identifier Scope+data IdScope    -- See Note [GlobalId/LocalId]+  = GlobalId+  | LocalId ExportFlag++data ExportFlag   -- See Note [ExportFlag on binders]+  = NotExported   -- ^ Not exported: may be discarded as dead code.+  | Exported      -- ^ Exported: kept alive++{- Note [ExportFlag on binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An ExportFlag of "Exported" on a top-level binder says "keep this+binding alive; do not drop it as dead code".  This transitively+keeps alive all the other top-level bindings that this binding refers+to.  This property is persisted all the way down the pipeline, so that+the binding will be compiled all the way to object code, and its+symbols will appear in the linker symbol table.++However, note that this use of "exported" is quite different to the+export list on a Haskell module.  Setting the ExportFlag on an Id does+/not/ mean that if you import the module (in Haskell source code) you+will see this Id.  Of course, things that appear in the export list+of the source Haskell module do indeed have their ExportFlag set.+But many other things, such as dictionary functions, are kept alive+by having their ExportFlag set, even though they are not exported+in the source-code sense.++We should probably use a different term for ExportFlag, like+KeepAlive.++Note [GlobalId/LocalId]+~~~~~~~~~~~~~~~~~~~~~~~+A GlobalId is+  * always a constant (top-level)+  * imported, or data constructor, or primop, or record selector+  * has a Unique that is globally unique across the whole+    GHC invocation (a single invocation may compile multiple modules)+  * never treated as a candidate by the free-variable finder;+        it's a constant!++A LocalId is+  * bound within an expression (lambda, case, local let(rec))+  * or defined at top level in the module being compiled+  * always treated as a candidate by the free-variable finder++After CoreTidy, top-level LocalIds are turned into GlobalIds+-}++instance Outputable Var where+  ppr var = sdocOption sdocSuppressVarKinds $ \supp_var_kinds ->+            getPprStyle $ \ppr_style ->+            if |  debugStyle ppr_style && (not supp_var_kinds)+                 -> parens (ppr (varName var) <+> ppr_debug var ppr_style <+>+                          dcolon <+> pprKind (tyVarKind var))+               |  otherwise+                 -> ppr (varName var) <> ppr_debug var ppr_style++ppr_debug :: Var -> PprStyle -> SDoc+ppr_debug (TyVar {}) sty+  | debugStyle sty = brackets (text "tv")+ppr_debug (TcTyVar {tc_tv_details = d}) sty+  | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d)+ppr_debug (Id { idScope = s, id_details = d }) sty+  | debugStyle sty = brackets (ppr_id_scope s <> pprIdDetails d)+ppr_debug _ _ = empty++ppr_id_scope :: IdScope -> SDoc+ppr_id_scope GlobalId              = text "gid"+ppr_id_scope (LocalId Exported)    = text "lidx"+ppr_id_scope (LocalId NotExported) = text "lid"++instance NamedThing Var where+  getName = varName++instance Uniquable Var where+  getUnique = varUnique++instance Eq Var where+    a == b = realUnique a == realUnique b++instance Ord Var where+    a <= b = realUnique a <= realUnique b+    a <  b = realUnique a <  realUnique b+    a >= b = realUnique a >= realUnique b+    a >  b = realUnique a >  realUnique b+    a `compare` b = a `nonDetCmpVar` b++-- | Compare Vars by their Uniques.+-- This is what Ord Var does, provided here to make it explicit at the+-- call-site that it can introduce non-determinism.+-- See Note [Unique Determinism]+nonDetCmpVar :: Var -> Var -> Ordering+nonDetCmpVar a b = varUnique a `nonDetCmpUnique` varUnique b++instance Data Var where+  -- don't traverse?+  toConstr _   = abstractConstr "Var"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "Var"++instance HasOccName Var where+  occName = nameOccName . varName++varUnique :: Var -> Unique+varUnique var = mkUniqueGrimily (realUnique var)++setVarUnique :: Var -> Unique -> Var+setVarUnique var uniq+  = var { realUnique = getKey uniq,+          varName = setNameUnique (varName var) uniq }++setVarName :: Var -> Name -> Var+setVarName var new_name+  = var { realUnique = getKey (getUnique new_name),+          varName = new_name }++setVarType :: Id -> Type -> Id+setVarType id ty = id { varType = ty }++updateVarType :: (Type -> Type) -> Id -> Id+updateVarType f id = id { varType = f (varType id) }++updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id+updateVarTypeM f id = do { ty' <- f (varType id)+                         ; return (id { varType = ty' }) }++{- *********************************************************************+*                                                                      *+*                   ArgFlag+*                                                                      *+********************************************************************* -}++-- | Argument Flag+--+-- Is something required to appear in source Haskell ('Required'),+-- permitted by request ('Specified') (visible type application), or+-- prohibited entirely from appearing in source Haskell ('Inferred')?+-- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep+data ArgFlag = Inferred | Specified | Required+  deriving (Eq, Ord, Data)+  -- (<) on ArgFlag means "is less visible than"++-- | Does this 'ArgFlag' classify an argument that is written in Haskell?+isVisibleArgFlag :: ArgFlag -> Bool+isVisibleArgFlag Required = True+isVisibleArgFlag _        = False++-- | Does this 'ArgFlag' classify an argument that is not written in Haskell?+isInvisibleArgFlag :: ArgFlag -> Bool+isInvisibleArgFlag = not . isVisibleArgFlag++-- | Do these denote the same level of visibility? 'Required'+-- arguments are visible, others are not. So this function+-- equates 'Specified' and 'Inferred'. Used for printing.+sameVis :: ArgFlag -> ArgFlag -> Bool+sameVis Required Required = True+sameVis Required _        = False+sameVis _        Required = False+sameVis _        _        = True++instance Outputable ArgFlag where+  ppr Required  = text "[req]"+  ppr Specified = text "[spec]"+  ppr Inferred  = text "[infrd]"++instance Binary ArgFlag where+  put_ bh Required  = putByte bh 0+  put_ bh Specified = putByte bh 1+  put_ bh Inferred  = putByte bh 2++  get bh = do+    h <- getByte bh+    case h of+      0 -> return Required+      1 -> return Specified+      _ -> return Inferred++-- | The non-dependent version of 'ArgFlag'.++-- Appears here partly so that it's together with its friend ArgFlag,+-- but also because it is used in IfaceType, rather early in the+-- compilation chain+-- See Note [AnonArgFlag vs. ForallVisFlag]+data AnonArgFlag+  = VisArg    -- ^ Used for @(->)@: an ordinary non-dependent arrow.+              --   The argument is visible in source code.+  | InvisArg  -- ^ Used for @(=>)@: a non-dependent predicate arrow.+              --   The argument is invisible in source code.+  deriving (Eq, Ord, Data)++instance Outputable AnonArgFlag where+  ppr VisArg   = text "[vis]"+  ppr InvisArg = text "[invis]"++instance Binary AnonArgFlag where+  put_ bh VisArg   = putByte bh 0+  put_ bh InvisArg = putByte bh 1++  get bh = do+    h <- getByte bh+    case h of+      0 -> return VisArg+      _ -> return InvisArg++-- | Is a @forall@ invisible (e.g., @forall a b. {...}@, with a dot) or visible+-- (e.g., @forall a b -> {...}@, with an arrow)?++-- See Note [AnonArgFlag vs. ForallVisFlag]+data ForallVisFlag+  = ForallVis   -- ^ A visible @forall@ (with an arrow)+  | ForallInvis -- ^ An invisible @forall@ (with a dot)+  deriving (Eq, Ord, Data)++instance Outputable ForallVisFlag where+  ppr f = text $ case f of+                   ForallVis   -> "ForallVis"+                   ForallInvis -> "ForallInvis"++-- | Convert an 'ArgFlag' to its corresponding 'ForallVisFlag'.+argToForallVisFlag :: ArgFlag -> ForallVisFlag+argToForallVisFlag Required  = ForallVis+argToForallVisFlag Specified = ForallInvis+argToForallVisFlag Inferred  = ForallInvis++{-+Note [AnonArgFlag vs. ForallVisFlag]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The AnonArgFlag and ForallVisFlag data types are quite similar at a first+glance:++  data AnonArgFlag   = VisArg    | InvisArg+  data ForallVisFlag = ForallVis | ForallInvis++Both data types keep track of visibility of some sort. AnonArgFlag tracks+whether a FunTy has a visible argument (->) or an invisible predicate argument+(=>). ForallVisFlag tracks whether a `forall` quantifier is visible+(forall a -> {...}) or invisible (forall a. {...}).++Given their similarities, it's tempting to want to combine these two data types+into one, but they actually represent distinct concepts. AnonArgFlag reflects a+property of *Core* types, whereas ForallVisFlag reflects a property of the GHC+AST. In other words, AnonArgFlag is all about internals, whereas ForallVisFlag+is all about surface syntax. Therefore, they are kept as separate data types.+-}++{- *********************************************************************+*                                                                      *+*                   VarBndr, TyCoVarBinder+*                                                                      *+********************************************************************* -}++-- Variable Binder+--+-- VarBndr is polymorphic in both var and visibility fields.+-- Currently there are six different uses of 'VarBndr':+--   * Var.TyVarBinder   = VarBndr TyVar ArgFlag+--   * Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag+--   * TyCon.TyConBinder     = VarBndr TyVar TyConBndrVis+--   * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis+--   * IfaceType.IfaceForAllBndr  = VarBndr IfaceBndr ArgFlag+--   * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis+data VarBndr var argf = Bndr var argf+  deriving( Data )++-- | Variable Binder+--+-- A 'TyCoVarBinder' is the binder of a ForAllTy+-- It's convenient to define this synonym here rather its natural+-- home in GHC.Core.TyCo.Rep, because it's used in GHC.Core.DataCon.hs-boot+--+-- A 'TyVarBinder' is a binder with only TyVar+type TyCoVarBinder = VarBndr TyCoVar ArgFlag+type TyVarBinder   = VarBndr TyVar ArgFlag++binderVar :: VarBndr tv argf -> tv+binderVar (Bndr v _) = v++binderVars :: [VarBndr tv argf] -> [tv]+binderVars tvbs = map binderVar tvbs++binderArgFlag :: VarBndr tv argf -> argf+binderArgFlag (Bndr _ argf) = argf++binderType :: VarBndr TyCoVar argf -> Type+binderType (Bndr tv _) = varType tv++-- | Make a named binder+mkTyCoVarBinder :: ArgFlag -> TyCoVar -> TyCoVarBinder+mkTyCoVarBinder vis var = Bndr var vis++-- | Make a named binder+-- 'var' should be a type variable+mkTyVarBinder :: ArgFlag -> TyVar -> TyVarBinder+mkTyVarBinder vis var+  = ASSERT( isTyVar var )+    Bndr var vis++-- | Make many named binders+mkTyCoVarBinders :: ArgFlag -> [TyCoVar] -> [TyCoVarBinder]+mkTyCoVarBinders vis = map (mkTyCoVarBinder vis)++-- | Make many named binders+-- Input vars should be type variables+mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder]+mkTyVarBinders vis = map (mkTyVarBinder vis)++isTyVarBinder :: TyCoVarBinder -> Bool+isTyVarBinder (Bndr v _) = isTyVar v++instance Outputable tv => Outputable (VarBndr tv ArgFlag) where+  ppr (Bndr v Required)  = ppr v+  ppr (Bndr v Specified) = char '@' <> ppr v+  ppr (Bndr v Inferred)  = braces (ppr v)++instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where+  put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis }++  get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) }++instance NamedThing tv => NamedThing (VarBndr tv flag) where+  getName (Bndr tv _) = getName tv++{-+************************************************************************+*                                                                      *+*                 Type and kind variables                              *+*                                                                      *+************************************************************************+-}++tyVarName :: TyVar -> Name+tyVarName = varName++tyVarKind :: TyVar -> Kind+tyVarKind = varType++setTyVarUnique :: TyVar -> Unique -> TyVar+setTyVarUnique = setVarUnique++setTyVarName :: TyVar -> Name -> TyVar+setTyVarName   = setVarName++setTyVarKind :: TyVar -> Kind -> TyVar+setTyVarKind tv k = tv {varType = k}++updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar+updateTyVarKind update tv = tv {varType = update (tyVarKind tv)}++updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar+updateTyVarKindM update tv+  = do { k' <- update (tyVarKind tv)+       ; return $ tv {varType = k'} }++mkTyVar :: Name -> Kind -> TyVar+mkTyVar name kind = TyVar { varName    = name+                          , realUnique = getKey (nameUnique name)+                          , varType  = kind+                          }++mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar+mkTcTyVar name kind details+  = -- NB: 'kind' may be a coercion kind; cf, 'TcMType.newMetaCoVar'+    TcTyVar {   varName    = name,+                realUnique = getKey (nameUnique name),+                varType  = kind,+                tc_tv_details = details+        }++tcTyVarDetails :: TyVar -> TcTyVarDetails+-- See Note [TcTyVars in the typechecker] in TcType+tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details+tcTyVarDetails (TyVar {})                            = vanillaSkolemTv+tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var))++setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar+setTcTyVarDetails tv details = tv { tc_tv_details = details }++{-+%************************************************************************+%*                                                                      *+\subsection{Ids}+*                                                                      *+************************************************************************+-}++idInfo :: HasDebugCallStack => Id -> IdInfo+idInfo (Id { id_info = info }) = info+idInfo other                   = pprPanic "idInfo" (ppr other)++idDetails :: Id -> IdDetails+idDetails (Id { id_details = details }) = details+idDetails other                         = pprPanic "idDetails" (ppr other)++-- The next three have a 'Var' suffix even though they always build+-- Ids, because Id.hs uses 'mkGlobalId' etc with different types+mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id+mkGlobalVar details name ty info+  = mk_id name ty GlobalId details info++mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id+mkLocalVar details name ty info+  = mk_id name ty (LocalId NotExported) details  info++mkCoVar :: Name -> Type -> CoVar+-- Coercion variables have no IdInfo+mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo++-- | Exported 'Var's will not be removed as dead code+mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id+mkExportedLocalVar details name ty info+  = mk_id name ty (LocalId Exported) details info++mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id+mk_id name ty scope details info+  = Id { varName    = name,+         realUnique = getKey (nameUnique name),+         varType    = ty,+         idScope    = scope,+         id_details = details,+         id_info    = info }++-------------------+lazySetIdInfo :: Id -> IdInfo -> Var+lazySetIdInfo id info = id { id_info = info }++setIdDetails :: Id -> IdDetails -> Id+setIdDetails id details = id { id_details = details }++globaliseId :: Id -> Id+-- ^ If it's a local, make it global+globaliseId id = id { idScope = GlobalId }++setIdExported :: Id -> Id+-- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors+-- and class operations, which are born as global 'Id's and automatically exported+setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported }+setIdExported id@(Id { idScope = GlobalId })   = id+setIdExported tv                               = pprPanic "setIdExported" (ppr tv)++setIdNotExported :: Id -> Id+-- ^ We can only do this to LocalIds+setIdNotExported id = ASSERT( isLocalId id )+                      id { idScope = LocalId NotExported }++{-+************************************************************************+*                                                                      *+\subsection{Predicates over variables}+*                                                                      *+************************************************************************+-}++-- | Is this a type-level (i.e., computationally irrelevant, thus erasable)+-- variable? Satisfies @isTyVar = not . isId@.+isTyVar :: Var -> Bool        -- True of both TyVar and TcTyVar+isTyVar (TyVar {})   = True+isTyVar (TcTyVar {}) = True+isTyVar _            = False++isTcTyVar :: Var -> Bool      -- True of TcTyVar only+isTcTyVar (TcTyVar {}) = True+isTcTyVar _            = False++isTyCoVar :: Var -> Bool+isTyCoVar v = isTyVar v || isCoVar v++-- | Is this a value-level (i.e., computationally relevant) 'Id'entifier?+-- Satisfies @isId = not . isTyVar@.+isId :: Var -> Bool+isId (Id {}) = True+isId _       = False++-- | Is this a coercion variable?+-- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@.+isCoVar :: Var -> Bool+isCoVar (Id { id_details = details }) = isCoVarDetails details+isCoVar _                             = False++-- | Is this a term variable ('Id') that is /not/ a coercion variable?+-- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@.+isNonCoVarId :: Var -> Bool+isNonCoVarId (Id { id_details = details }) = not (isCoVarDetails details)+isNonCoVarId _                             = False++isLocalId :: Var -> Bool+isLocalId (Id { idScope = LocalId _ }) = True+isLocalId _                            = False++-- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's+-- These are the variables that we need to pay attention to when finding free+-- variables, or doing dependency analysis.+isLocalVar :: Var -> Bool+isLocalVar v = not (isGlobalId v)++isGlobalId :: Var -> Bool+isGlobalId (Id { idScope = GlobalId }) = True+isGlobalId _                           = False++-- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's+-- that must have a binding in this module.  The converse+-- is not quite right: there are some global 'Id's that must have+-- bindings, such as record selectors.  But that doesn't matter,+-- because it's only used for assertions+mustHaveLocalBinding        :: Var -> Bool+mustHaveLocalBinding var = isLocalVar var++-- | 'isExportedIdVar' means \"don't throw this away\"+isExportedId :: Var -> Bool+isExportedId (Id { idScope = GlobalId })        = True+isExportedId (Id { idScope = LocalId Exported}) = True+isExportedId _ = False
+ compiler/GHC/Types/Var.hs-boot view
@@ -0,0 +1,14 @@+module GHC.Types.Var where++import GhcPrelude ()+  -- We compile this module with -XNoImplicitPrelude (for some+  -- reason), so if there are no imports it does not seem to+  -- depend on anything.  But it does! We must, for example,+  -- compile GHC.Types in the ghc-prim library first.+  -- So this otherwise-unnecessary import tells the build system+  -- that this module depends on GhcPrelude, which ensures+  -- that GHC.Type is built first.++data ArgFlag+data AnonArgFlag+data Var
+ compiler/GHC/Types/Var/Env.hs view
@@ -0,0 +1,632 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++module GHC.Types.Var.Env (+        -- * Var, Id and TyVar environments (maps)+        VarEnv, IdEnv, TyVarEnv, CoVarEnv, TyCoVarEnv,++        -- ** Manipulating these environments+        emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly,+        elemVarEnv, disjointVarEnv,+        extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly,+        extendVarEnvList,+        plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C,+        plusVarEnvList, alterVarEnv,+        delVarEnvList, delVarEnv, delVarEnv_Directly,+        minusVarEnv, intersectsVarEnv,+        lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,+        mapVarEnv, zipVarEnv,+        modifyVarEnv, modifyVarEnv_Directly,+        isEmptyVarEnv,+        elemVarEnvByKey, lookupVarEnv_Directly,+        filterVarEnv, filterVarEnv_Directly, restrictVarEnv,+        partitionVarEnv,++        -- * Deterministic Var environments (maps)+        DVarEnv, DIdEnv, DTyVarEnv,++        -- ** Manipulating these environments+        emptyDVarEnv, mkDVarEnv,+        dVarEnvElts,+        extendDVarEnv, extendDVarEnv_C,+        extendDVarEnvList,+        lookupDVarEnv, elemDVarEnv,+        isEmptyDVarEnv, foldDVarEnv,+        mapDVarEnv, filterDVarEnv,+        modifyDVarEnv,+        alterDVarEnv,+        plusDVarEnv, plusDVarEnv_C,+        unitDVarEnv,+        delDVarEnv,+        delDVarEnvList,+        minusDVarEnv,+        partitionDVarEnv,+        anyDVarEnv,++        -- * The InScopeSet type+        InScopeSet,++        -- ** Operations on InScopeSets+        emptyInScopeSet, mkInScopeSet, delInScopeSet,+        extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,+        getInScopeVars, lookupInScope, lookupInScope_Directly,+        unionInScope, elemInScopeSet, uniqAway,+        varSetInScope,+        unsafeGetFreshLocalUnique,++        -- * The RnEnv2 type+        RnEnv2,++        -- ** Operations on RnEnv2s+        mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var,+        rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe,+        rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap,+        delBndrL, delBndrR, delBndrsL, delBndrsR,+        addRnInScopeSet,+        rnEtaL, rnEtaR,+        rnInScope, rnInScopeSet, lookupRnInScope,+        rnEnvL, rnEnvR,++        -- * TidyEnv and its operation+        TidyEnv,+        emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList+    ) where++import GhcPrelude+import qualified Data.IntMap.Strict as IntMap -- TODO: Move this to UniqFM++import GHC.Types.Name.Occurrence+import GHC.Types.Name+import GHC.Types.Var as Var+import GHC.Types.Var.Set+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM+import GHC.Types.Unique+import Util+import Maybes+import Outputable++{-+************************************************************************+*                                                                      *+                In-scope sets+*                                                                      *+************************************************************************+-}++-- | A set of variables that are in scope at some point+-- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides+-- the motivation for this abstraction.+newtype InScopeSet = InScope VarSet+        -- Note [Lookups in in-scope set]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        -- We store a VarSet here, but we use this for lookups rather than just+        -- membership tests. Typically the InScopeSet contains the canonical+        -- version of the variable (e.g. with an informative unfolding), so this+        -- lookup is useful (see, for instance, Note [In-scope set as a+        -- substitution]).++instance Outputable InScopeSet where+  ppr (InScope s) =+    text "InScope" <+>+    braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s)))+                      -- It's OK to use nonDetEltsUniqSet here because it's+                      -- only for pretty printing+                      -- In-scope sets get big, and with -dppr-debug+                      -- the output is overwhelming++emptyInScopeSet :: InScopeSet+emptyInScopeSet = InScope emptyVarSet++getInScopeVars ::  InScopeSet -> VarSet+getInScopeVars (InScope vs) = vs++mkInScopeSet :: VarSet -> InScopeSet+mkInScopeSet in_scope = InScope in_scope++extendInScopeSet :: InScopeSet -> Var -> InScopeSet+extendInScopeSet (InScope in_scope) v+   = InScope (extendVarSet in_scope v)++extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet+extendInScopeSetList (InScope in_scope) vs+   = InScope $ foldl' extendVarSet in_scope vs++extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet+extendInScopeSetSet (InScope in_scope) vs+   = InScope (in_scope `unionVarSet` vs)++delInScopeSet :: InScopeSet -> Var -> InScopeSet+delInScopeSet (InScope in_scope) v = InScope (in_scope `delVarSet` v)++elemInScopeSet :: Var -> InScopeSet -> Bool+elemInScopeSet v (InScope in_scope) = v `elemVarSet` in_scope++-- | Look up a variable the 'InScopeSet'.  This lets you map from+-- the variable's identity (unique) to its full value.+lookupInScope :: InScopeSet -> Var -> Maybe Var+lookupInScope (InScope in_scope) v  = lookupVarSet in_scope v++lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var+lookupInScope_Directly (InScope in_scope) uniq+  = lookupVarSet_Directly in_scope uniq++unionInScope :: InScopeSet -> InScopeSet -> InScopeSet+unionInScope (InScope s1) (InScope s2)+  = InScope (s1 `unionVarSet` s2)++varSetInScope :: VarSet -> InScopeSet -> Bool+varSetInScope vars (InScope s1) = vars `subVarSet` s1++{-+Note [Local uniques]+~~~~~~~~~~~~~~~~~~~~+Sometimes one must create conjure up a unique which is unique in a particular+context (but not necessarily globally unique). For instance, one might need to+create a fresh local identifier which does not shadow any of the locally+in-scope variables.  For this we purpose we provide 'uniqAway'.++'uniqAway' is implemented in terms of the 'unsafeGetFreshLocalUnique'+operation, which generates an unclaimed 'Unique' from an 'InScopeSet'. To+ensure that we do not conflict with uniques allocated by future allocations+from 'UniqSupply's, Uniques generated by 'unsafeGetFreshLocalUnique' are+allocated into a dedicated region of the unique space (namely the X tag).++Note that one must be quite carefully when using uniques generated in this way+since they are only locally unique. In particular, two successive calls to+'uniqAway' on the same 'InScopeSet' will produce the same unique.+ -}++-- | @uniqAway in_scope v@ finds a unique that is not used in the+-- in-scope set, and gives that to v. See Note [Local uniques].+uniqAway :: InScopeSet -> Var -> Var+-- It starts with v's current unique, of course, in the hope that it won't+-- have to change, and thereafter uses the successor to the last derived unique+-- found in the in-scope set.+uniqAway in_scope var+  | var `elemInScopeSet` in_scope = uniqAway' in_scope var      -- Make a new one+  | otherwise                     = var                         -- Nothing to do++uniqAway' :: InScopeSet -> Var -> Var+-- This one *always* makes up a new variable+uniqAway' in_scope var+  = setVarUnique var (unsafeGetFreshLocalUnique in_scope)++-- | @unsafeGetFreshUnique in_scope@ finds a unique that is not in-scope in the+-- given 'InScopeSet'. This must be used very carefully since one can very easily+-- introduce non-unique 'Unique's this way. See Note [Local uniques].+unsafeGetFreshLocalUnique :: InScopeSet -> Unique+unsafeGetFreshLocalUnique (InScope set)+  | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set)+  , let uniq' = mkLocalUnique uniq+  , not $ uniq' `ltUnique` minLocalUnique+  = incrUnique uniq'++  | otherwise+  = minLocalUnique++{-+************************************************************************+*                                                                      *+                Dual renaming+*                                                                      *+************************************************************************+-}++-- | Rename Environment 2+--+-- When we are comparing (or matching) types or terms, we are faced with+-- \"going under\" corresponding binders.  E.g. when comparing:+--+-- > \x. e1     ~   \y. e2+--+-- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of+-- things we must be careful of.  In particular, @x@ might be free in @e2@, or+-- y in @e1@.  So the idea is that we come up with a fresh binder that is free+-- in neither, and rename @x@ and @y@ respectively.  That means we must maintain:+--+-- 1. A renaming for the left-hand expression+--+-- 2. A renaming for the right-hand expressions+--+-- 3. An in-scope set+--+-- Furthermore, when matching, we want to be able to have an 'occurs check',+-- to prevent:+--+-- > \x. f   ~   \y. y+--+-- matching with [@f@ -> @y@].  So for each expression we want to know that set of+-- locally-bound variables. That is precisely the domain of the mappings 1.+-- and 2., but we must ensure that we always extend the mappings as we go in.+--+-- All of this information is bundled up in the 'RnEnv2'+data RnEnv2+  = RV2 { envL     :: VarEnv Var        -- Renaming for Left term+        , envR     :: VarEnv Var        -- Renaming for Right term+        , in_scope :: InScopeSet }      -- In scope in left or right terms++-- The renamings envL and envR are *guaranteed* to contain a binding+-- for every variable bound as we go into the term, even if it is not+-- renamed.  That way we can ask what variables are locally bound+-- (inRnEnvL, inRnEnvR)++mkRnEnv2 :: InScopeSet -> RnEnv2+mkRnEnv2 vars = RV2     { envL     = emptyVarEnv+                        , envR     = emptyVarEnv+                        , in_scope = vars }++addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2+addRnInScopeSet env vs+  | isEmptyVarSet vs = env+  | otherwise        = env { in_scope = extendInScopeSetSet (in_scope env) vs }++rnInScope :: Var -> RnEnv2 -> Bool+rnInScope x env = x `elemInScopeSet` in_scope env++rnInScopeSet :: RnEnv2 -> InScopeSet+rnInScopeSet = in_scope++-- | Retrieve the left mapping+rnEnvL :: RnEnv2 -> VarEnv Var+rnEnvL = envL++-- | Retrieve the right mapping+rnEnvR :: RnEnv2 -> VarEnv Var+rnEnvR = envR++rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2+-- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length+rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR++rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2+-- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term,+--                       and binder @bR@ in the Right term.+-- It finds a new binder, @new_b@,+-- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@+rnBndr2 env bL bR = fst $ rnBndr2_var env bL bR++rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var)+-- ^ Similar to 'rnBndr2' but returns the new variable as well as the+-- new environment+rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR+  = (RV2 { envL            = extendVarEnv envL bL new_b   -- See Note+         , envR            = extendVarEnv envR bR new_b   -- [Rebinding]+         , in_scope = extendInScopeSet in_scope new_b }, new_b)+  where+        -- Find a new binder not in scope in either term+    new_b | not (bL `elemInScopeSet` in_scope) = bL+          | not (bR `elemInScopeSet` in_scope) = bR+          | otherwise                          = uniqAway' in_scope bL++        -- Note [Rebinding]+        -- If the new var is the same as the old one, note that+        -- the extendVarEnv *deletes* any current renaming+        -- E.g.   (\x. \x. ...)  ~  (\y. \z. ...)+        --+        --   Inside \x  \y      { [x->y], [y->y],       {y} }+        --       \x  \z         { [x->x], [y->y, z->x], {y,x} }++rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var)+-- ^ Similar to 'rnBndr2' but used when there's a binder on the left+-- side only.+rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL+  = (RV2 { envL     = extendVarEnv envL bL new_b+         , envR     = envR+         , in_scope = extendInScopeSet in_scope new_b }, new_b)+  where+    new_b = uniqAway in_scope bL++rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var)+-- ^ Similar to 'rnBndr2' but used when there's a binder on the right+-- side only.+rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR+  = (RV2 { envR     = extendVarEnv envR bR new_b+         , envL     = envL+         , in_scope = extendInScopeSet in_scope new_b }, new_b)+  where+    new_b = uniqAway in_scope bR++rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var)+-- ^ Similar to 'rnBndrL' but used for eta expansion+-- See Note [Eta expansion]+rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL+  = (RV2 { envL     = extendVarEnv envL bL new_b+         , envR     = extendVarEnv envR new_b new_b     -- Note [Eta expansion]+         , in_scope = extendInScopeSet in_scope new_b }, new_b)+  where+    new_b = uniqAway in_scope bL++rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var)+-- ^ Similar to 'rnBndr2' but used for eta expansion+-- See Note [Eta expansion]+rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR+  = (RV2 { envL     = extendVarEnv envL new_b new_b     -- Note [Eta expansion]+         , envR     = extendVarEnv envR bR new_b+         , in_scope = extendInScopeSet in_scope new_b }, new_b)+  where+    new_b = uniqAway in_scope bR++delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2+delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v+  = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v }+delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v+  = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v }++delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2+delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v+  = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v }+delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v+  = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v }++rnOccL, rnOccR :: RnEnv2 -> Var -> Var+-- ^ Look up the renaming of an occurrence in the left or right term+rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v+rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v++rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var+-- ^ Look up the renaming of an occurrence in the left or right term+rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v+rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v++inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool+-- ^ Tells whether a variable is locally bound+inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env+inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env++lookupRnInScope :: RnEnv2 -> Var -> Var+lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v++nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2+-- ^ Wipe the left or right side renaming+nukeRnEnvL env = env { envL = emptyVarEnv }+nukeRnEnvR env = env { envR = emptyVarEnv }++rnSwap :: RnEnv2 -> RnEnv2+-- ^ swap the meaning of left and right+rnSwap (RV2 { envL = envL, envR = envR, in_scope = in_scope })+  = RV2 { envL = envR, envR = envL, in_scope = in_scope }++{-+Note [Eta expansion]+~~~~~~~~~~~~~~~~~~~~+When matching+     (\x.M) ~ N+we rename x to x' with, where x' is not in scope in+either term.  Then we want to behave as if we'd seen+     (\x'.M) ~ (\x'.N x')+Since x' isn't in scope in N, the form (\x'. N x') doesn't+capture any variables in N.  But we must nevertheless extend+the envR with a binding [x' -> x'], to support the occurs check.+For example, if we don't do this, we can get silly matches like+        forall a.  (\y.a)  ~   v+succeeding with [a -> v y], which is bogus of course.+++************************************************************************+*                                                                      *+                Tidying+*                                                                      *+************************************************************************+-}++-- | Tidy Environment+--+-- When tidying up print names, we keep a mapping of in-scope occ-names+-- (the 'TidyOccEnv') and a Var-to-Var of the current renamings+type TidyEnv = (TidyOccEnv, VarEnv Var)++emptyTidyEnv :: TidyEnv+emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)++mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv+mkEmptyTidyEnv occ_env = (occ_env, emptyVarEnv)++delTidyEnvList :: TidyEnv -> [Var] -> TidyEnv+delTidyEnvList (occ_env, var_env) vs = (occ_env', var_env')+  where+    occ_env' = occ_env `delTidyOccEnvList` map (occNameFS . getOccName) vs+    var_env' = var_env `delVarEnvList` vs++{-+************************************************************************+*                                                                      *+\subsection{@VarEnv@s}+*                                                                      *+************************************************************************+-}++-- | Variable Environment+type VarEnv elt     = UniqFM elt++-- | Identifier Environment+type IdEnv elt      = VarEnv elt++-- | Type Variable Environment+type TyVarEnv elt   = VarEnv elt++-- | Type or Coercion Variable Environment+type TyCoVarEnv elt = VarEnv elt++-- | Coercion Variable Environment+type CoVarEnv elt   = VarEnv elt++emptyVarEnv       :: VarEnv a+mkVarEnv          :: [(Var, a)] -> VarEnv a+mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a+zipVarEnv         :: [Var] -> [a] -> VarEnv a+unitVarEnv        :: Var -> a -> VarEnv a+alterVarEnv       :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a+extendVarEnv      :: VarEnv a -> Var -> a -> VarEnv a+extendVarEnv_C    :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a+extendVarEnv_Acc  :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b+extendVarEnv_Directly :: VarEnv a -> Unique -> a -> VarEnv a+plusVarEnv        :: VarEnv a -> VarEnv a -> VarEnv a+plusVarEnvList    :: [VarEnv a] -> VarEnv a+extendVarEnvList  :: VarEnv a -> [(Var, a)] -> VarEnv a++lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a+filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a+delVarEnv_Directly    :: VarEnv a -> Unique -> VarEnv a+partitionVarEnv   :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a)+restrictVarEnv    :: VarEnv a -> VarSet -> VarEnv a+delVarEnvList     :: VarEnv a -> [Var] -> VarEnv a+delVarEnv         :: VarEnv a -> Var -> VarEnv a+minusVarEnv       :: VarEnv a -> VarEnv b -> VarEnv a+intersectsVarEnv  :: VarEnv a -> VarEnv a -> Bool+plusVarEnv_C      :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a+plusVarEnv_CD     :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a+plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a+mapVarEnv         :: (a -> b) -> VarEnv a -> VarEnv b+modifyVarEnv      :: (a -> a) -> VarEnv a -> Var -> VarEnv a++isEmptyVarEnv     :: VarEnv a -> Bool+lookupVarEnv      :: VarEnv a -> Var -> Maybe a+filterVarEnv      :: (a -> Bool) -> VarEnv a -> VarEnv a+lookupVarEnv_NF   :: VarEnv a -> Var -> a+lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a+elemVarEnv        :: Var -> VarEnv a -> Bool+elemVarEnvByKey   :: Unique -> VarEnv a -> Bool+disjointVarEnv    :: VarEnv a -> VarEnv a -> Bool++elemVarEnv       = elemUFM+elemVarEnvByKey  = elemUFM_Directly+disjointVarEnv   = disjointUFM+alterVarEnv      = alterUFM+extendVarEnv     = addToUFM+extendVarEnv_C   = addToUFM_C+extendVarEnv_Acc = addToUFM_Acc+extendVarEnv_Directly = addToUFM_Directly+extendVarEnvList = addListToUFM+plusVarEnv_C     = plusUFM_C+plusVarEnv_CD    = plusUFM_CD+plusMaybeVarEnv_C = plusMaybeUFM_C+delVarEnvList    = delListFromUFM+delVarEnv        = delFromUFM+minusVarEnv      = minusUFM+intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2))+plusVarEnv       = plusUFM+plusVarEnvList   = plusUFMList+lookupVarEnv     = lookupUFM+filterVarEnv     = filterUFM+lookupWithDefaultVarEnv = lookupWithDefaultUFM+mapVarEnv        = mapUFM+mkVarEnv         = listToUFM+mkVarEnv_Directly= listToUFM_Directly+emptyVarEnv      = emptyUFM+unitVarEnv       = unitUFM+isEmptyVarEnv    = isNullUFM+lookupVarEnv_Directly = lookupUFM_Directly+filterVarEnv_Directly = filterUFM_Directly+delVarEnv_Directly    = delFromUFM_Directly+partitionVarEnv       = partitionUFM++restrictVarEnv env vs = filterVarEnv_Directly keep env+  where+    keep u _ = u `elemVarSetByKey` vs++zipVarEnv tyvars tys   = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)+lookupVarEnv_NF env id = case lookupVarEnv env id of+                         Just xx -> xx+                         Nothing -> panic "lookupVarEnv_NF: Nothing"++{-+@modifyVarEnv@: Look up a thing in the VarEnv,+then mash it with the modify function, and put it back.+-}++modifyVarEnv mangle_fn env key+  = case (lookupVarEnv env key) of+      Nothing -> env+      Just xx -> extendVarEnv env key (mangle_fn xx)++modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a+modifyVarEnv_Directly mangle_fn env key+  = case (lookupUFM_Directly env key) of+      Nothing -> env+      Just xx -> addToUFM_Directly env key (mangle_fn xx)++-- Deterministic VarEnv+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need+-- DVarEnv.++-- | Deterministic Variable Environment+type DVarEnv elt = UniqDFM elt++-- | Deterministic Identifier Environment+type DIdEnv elt = DVarEnv elt++-- | Deterministic Type Variable Environment+type DTyVarEnv elt = DVarEnv elt++emptyDVarEnv :: DVarEnv a+emptyDVarEnv = emptyUDFM++dVarEnvElts :: DVarEnv a -> [a]+dVarEnvElts = eltsUDFM++mkDVarEnv :: [(Var, a)] -> DVarEnv a+mkDVarEnv = listToUDFM++extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a+extendDVarEnv = addToUDFM++minusDVarEnv :: DVarEnv a -> DVarEnv a' -> DVarEnv a+minusDVarEnv = minusUDFM++lookupDVarEnv :: DVarEnv a -> Var -> Maybe a+lookupDVarEnv = lookupUDFM++foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b+foldDVarEnv = foldUDFM++mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b+mapDVarEnv = mapUDFM++filterDVarEnv      :: (a -> Bool) -> DVarEnv a -> DVarEnv a+filterDVarEnv = filterUDFM++alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a+alterDVarEnv = alterUDFM++plusDVarEnv :: DVarEnv a -> DVarEnv a -> DVarEnv a+plusDVarEnv = plusUDFM++plusDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a+plusDVarEnv_C = plusUDFM_C++unitDVarEnv :: Var -> a -> DVarEnv a+unitDVarEnv = unitUDFM++delDVarEnv :: DVarEnv a -> Var -> DVarEnv a+delDVarEnv = delFromUDFM++delDVarEnvList :: DVarEnv a -> [Var] -> DVarEnv a+delDVarEnvList = delListFromUDFM++isEmptyDVarEnv :: DVarEnv a -> Bool+isEmptyDVarEnv = isNullUDFM++elemDVarEnv :: Var -> DVarEnv a -> Bool+elemDVarEnv = elemUDFM++extendDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> Var -> a -> DVarEnv a+extendDVarEnv_C = addToUDFM_C++modifyDVarEnv :: (a -> a) -> DVarEnv a -> Var -> DVarEnv a+modifyDVarEnv mangle_fn env key+  = case (lookupDVarEnv env key) of+      Nothing -> env+      Just xx -> extendDVarEnv env key (mangle_fn xx)++partitionDVarEnv :: (a -> Bool) -> DVarEnv a -> (DVarEnv a, DVarEnv a)+partitionDVarEnv = partitionUDFM++extendDVarEnvList :: DVarEnv a -> [(Var, a)] -> DVarEnv a+extendDVarEnvList = addListToUDFM++anyDVarEnv :: (a -> Bool) -> DVarEnv a -> Bool+anyDVarEnv = anyUDFM
+ compiler/GHC/Types/Var/Set.hs view
@@ -0,0 +1,354 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP #-}++module GHC.Types.Var.Set (+        -- * Var, Id and TyVar set types+        VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet,++        -- ** Manipulating these sets+        emptyVarSet, unitVarSet, mkVarSet,+        extendVarSet, extendVarSetList,+        elemVarSet, subVarSet,+        unionVarSet, unionVarSets, mapUnionVarSet,+        intersectVarSet, intersectsVarSet, disjointVarSet,+        isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,+        minusVarSet, filterVarSet, mapVarSet,+        anyVarSet, allVarSet,+        transCloVarSet, fixVarSet,+        lookupVarSet_Directly, lookupVarSet, lookupVarSetByName,+        sizeVarSet, seqVarSet,+        elemVarSetByKey, partitionVarSet,+        pluralVarSet, pprVarSet,+        nonDetFoldVarSet,++        -- * Deterministic Var set types+        DVarSet, DIdSet, DTyVarSet, DTyCoVarSet,++        -- ** Manipulating these sets+        emptyDVarSet, unitDVarSet, mkDVarSet,+        extendDVarSet, extendDVarSetList,+        elemDVarSet, dVarSetElems, subDVarSet,+        unionDVarSet, unionDVarSets, mapUnionDVarSet,+        intersectDVarSet, dVarSetIntersectVarSet,+        intersectsDVarSet, disjointDVarSet,+        isEmptyDVarSet, delDVarSet, delDVarSetList,+        minusDVarSet, foldDVarSet, filterDVarSet, mapDVarSet,+        dVarSetMinusVarSet, anyDVarSet, allDVarSet,+        transCloDVarSet,+        sizeDVarSet, seqDVarSet,+        partitionDVarSet,+        dVarSetToVarSet,+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Types.Var      ( Var, TyVar, CoVar, TyCoVar, Id )+import GHC.Types.Unique+import GHC.Types.Name     ( Name )+import GHC.Types.Unique.Set+import GHC.Types.Unique.DSet+import GHC.Types.Unique.FM( disjointUFM, pluralUFM, pprUFM )+import GHC.Types.Unique.DFM( disjointUDFM, udfmToUfm, anyUDFM, allUDFM )+import Outputable (SDoc)++-- | A non-deterministic Variable Set+--+-- A non-deterministic set of variables.+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why it's not+-- deterministic and why it matters. Use DVarSet if the set eventually+-- gets converted into a list or folded over in a way where the order+-- changes the generated code, for example when abstracting variables.+type VarSet       = UniqSet Var++-- | Identifier Set+type IdSet        = UniqSet Id++-- | Type Variable Set+type TyVarSet     = UniqSet TyVar++-- | Coercion Variable Set+type CoVarSet     = UniqSet CoVar++-- | Type or Coercion Variable Set+type TyCoVarSet   = UniqSet TyCoVar++emptyVarSet     :: VarSet+intersectVarSet :: VarSet -> VarSet -> VarSet+unionVarSet     :: VarSet -> VarSet -> VarSet+unionVarSets    :: [VarSet] -> VarSet++mapUnionVarSet  :: (a -> VarSet) -> [a] -> VarSet+-- ^ map the function over the list, and union the results++unitVarSet      :: Var -> VarSet+extendVarSet    :: VarSet -> Var -> VarSet+extendVarSetList:: VarSet -> [Var] -> VarSet+elemVarSet      :: Var -> VarSet -> Bool+delVarSet       :: VarSet -> Var -> VarSet+delVarSetList   :: VarSet -> [Var] -> VarSet+minusVarSet     :: VarSet -> VarSet -> VarSet+isEmptyVarSet   :: VarSet -> Bool+mkVarSet        :: [Var] -> VarSet+lookupVarSet_Directly :: VarSet -> Unique -> Maybe Var+lookupVarSet    :: VarSet -> Var -> Maybe Var+                        -- Returns the set element, which may be+                        -- (==) to the argument, but not the same as+lookupVarSetByName :: VarSet -> Name -> Maybe Var+sizeVarSet      :: VarSet -> Int+filterVarSet    :: (Var -> Bool) -> VarSet -> VarSet++delVarSetByKey  :: VarSet -> Unique -> VarSet+elemVarSetByKey :: Unique -> VarSet -> Bool+partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet)++emptyVarSet     = emptyUniqSet+unitVarSet      = unitUniqSet+extendVarSet    = addOneToUniqSet+extendVarSetList= addListToUniqSet+intersectVarSet = intersectUniqSets++intersectsVarSet:: VarSet -> VarSet -> Bool     -- True if non-empty intersection+disjointVarSet  :: VarSet -> VarSet -> Bool     -- True if empty intersection+subVarSet       :: VarSet -> VarSet -> Bool     -- True if first arg is subset of second+        -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty;+        -- ditto disjointVarSet, subVarSet++unionVarSet     = unionUniqSets+unionVarSets    = unionManyUniqSets+elemVarSet      = elementOfUniqSet+minusVarSet     = minusUniqSet+delVarSet       = delOneFromUniqSet+delVarSetList   = delListFromUniqSet+isEmptyVarSet   = isEmptyUniqSet+mkVarSet        = mkUniqSet+lookupVarSet_Directly = lookupUniqSet_Directly+lookupVarSet    = lookupUniqSet+lookupVarSetByName = lookupUniqSet+sizeVarSet      = sizeUniqSet+filterVarSet    = filterUniqSet+delVarSetByKey  = delOneFromUniqSet_Directly+elemVarSetByKey = elemUniqSet_Directly+partitionVarSet = partitionUniqSet++mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs++-- See comments with type signatures+intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2)+disjointVarSet   s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2)+subVarSet        s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2)++anyVarSet :: (Var -> Bool) -> VarSet -> Bool+anyVarSet = uniqSetAny++allVarSet :: (Var -> Bool) -> VarSet -> Bool+allVarSet = uniqSetAll++mapVarSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b+mapVarSet = mapUniqSet++nonDetFoldVarSet :: (Var -> a -> a) -> a -> VarSet -> a+nonDetFoldVarSet = nonDetFoldUniqSet++fixVarSet :: (VarSet -> VarSet)   -- Map the current set to a new set+          -> VarSet -> VarSet+-- (fixVarSet f s) repeatedly applies f to the set s,+-- until it reaches a fixed point.+fixVarSet fn vars+  | new_vars `subVarSet` vars = vars+  | otherwise                 = fixVarSet fn new_vars+  where+    new_vars = fn vars++transCloVarSet :: (VarSet -> VarSet)+                  -- Map some variables in the set to+                  -- extra variables that should be in it+               -> VarSet -> VarSet+-- (transCloVarSet f s) repeatedly applies f to new candidates, adding any+-- new variables to s that it finds thereby, until it reaches a fixed point.+--+-- The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet)+-- for efficiency, so that the test can be batched up.+-- It's essential that fn will work fine if given new candidates+-- one at a time; ie  fn {v1,v2} = fn v1 `union` fn v2+-- Use fixVarSet if the function needs to see the whole set all at once+transCloVarSet fn seeds+  = go seeds seeds+  where+    go :: VarSet  -- Accumulating result+       -> VarSet  -- Work-list; un-processed subset of accumulating result+       -> VarSet+    -- Specification: go acc vs = acc `union` transClo fn vs++    go acc candidates+       | isEmptyVarSet new_vs = acc+       | otherwise            = go (acc `unionVarSet` new_vs) new_vs+       where+         new_vs = fn candidates `minusVarSet` acc++seqVarSet :: VarSet -> ()+seqVarSet s = sizeVarSet s `seq` ()++-- | Determines the pluralisation suffix appropriate for the length of a set+-- in the same way that plural from Outputable does for lists.+pluralVarSet :: VarSet -> SDoc+pluralVarSet = pluralUFM . getUniqSet++-- | Pretty-print a non-deterministic set.+-- The order of variables is non-deterministic and for pretty-printing that+-- shouldn't be a problem.+-- Having this function helps contain the non-determinism created with+-- nonDetEltsUFM.+-- Passing a list to the pretty-printing function allows the caller+-- to decide on the order of Vars (eg. toposort them) without them having+-- to use nonDetEltsUFM at the call site. This prevents from let-binding+-- non-deterministically ordered lists and reusing them where determinism+-- matters.+pprVarSet :: VarSet          -- ^ The things to be pretty printed+          -> ([Var] -> SDoc) -- ^ The pretty printing function to use on the+                             -- elements+          -> SDoc            -- ^ 'SDoc' where the things have been pretty+                             -- printed+pprVarSet = pprUFM . getUniqSet++-- Deterministic VarSet+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need+-- DVarSet.++-- | Deterministic Variable Set+type DVarSet     = UniqDSet Var++-- | Deterministic Identifier Set+type DIdSet      = UniqDSet Id++-- | Deterministic Type Variable Set+type DTyVarSet   = UniqDSet TyVar++-- | Deterministic Type or Coercion Variable Set+type DTyCoVarSet = UniqDSet TyCoVar++emptyDVarSet :: DVarSet+emptyDVarSet = emptyUniqDSet++unitDVarSet :: Var -> DVarSet+unitDVarSet = unitUniqDSet++mkDVarSet :: [Var] -> DVarSet+mkDVarSet = mkUniqDSet++-- The new element always goes to the right of existing ones.+extendDVarSet :: DVarSet -> Var -> DVarSet+extendDVarSet = addOneToUniqDSet++elemDVarSet :: Var -> DVarSet -> Bool+elemDVarSet = elementOfUniqDSet++dVarSetElems :: DVarSet -> [Var]+dVarSetElems = uniqDSetToList++subDVarSet :: DVarSet -> DVarSet -> Bool+subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2)++unionDVarSet :: DVarSet -> DVarSet -> DVarSet+unionDVarSet = unionUniqDSets++unionDVarSets :: [DVarSet] -> DVarSet+unionDVarSets = unionManyUniqDSets++-- | Map the function over the list, and union the results+mapUnionDVarSet  :: (a -> DVarSet) -> [a] -> DVarSet+mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs++intersectDVarSet :: DVarSet -> DVarSet -> DVarSet+intersectDVarSet = intersectUniqDSets++dVarSetIntersectVarSet :: DVarSet -> VarSet -> DVarSet+dVarSetIntersectVarSet = uniqDSetIntersectUniqSet++-- | True if empty intersection+disjointDVarSet :: DVarSet -> DVarSet -> Bool+disjointDVarSet s1 s2 = disjointUDFM (getUniqDSet s1) (getUniqDSet s2)++-- | True if non-empty intersection+intersectsDVarSet :: DVarSet -> DVarSet -> Bool+intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2)++isEmptyDVarSet :: DVarSet -> Bool+isEmptyDVarSet = isEmptyUniqDSet++delDVarSet :: DVarSet -> Var -> DVarSet+delDVarSet = delOneFromUniqDSet++minusDVarSet :: DVarSet -> DVarSet -> DVarSet+minusDVarSet = minusUniqDSet++dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet+dVarSetMinusVarSet = uniqDSetMinusUniqSet++foldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a+foldDVarSet = foldUniqDSet++anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool+anyDVarSet p = anyUDFM p . getUniqDSet++allDVarSet :: (Var -> Bool) -> DVarSet -> Bool+allDVarSet p = allUDFM p . getUniqDSet++mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b+mapDVarSet = mapUniqDSet++filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet+filterDVarSet = filterUniqDSet++sizeDVarSet :: DVarSet -> Int+sizeDVarSet = sizeUniqDSet++-- | Partition DVarSet according to the predicate given+partitionDVarSet :: (Var -> Bool) -> DVarSet -> (DVarSet, DVarSet)+partitionDVarSet = partitionUniqDSet++-- | Delete a list of variables from DVarSet+delDVarSetList :: DVarSet -> [Var] -> DVarSet+delDVarSetList = delListFromUniqDSet++seqDVarSet :: DVarSet -> ()+seqDVarSet s = sizeDVarSet s `seq` ()++-- | Add a list of variables to DVarSet+extendDVarSetList :: DVarSet -> [Var] -> DVarSet+extendDVarSetList = addListToUniqDSet++-- | Convert a DVarSet to a VarSet by forgetting the order of insertion+dVarSetToVarSet :: DVarSet -> VarSet+dVarSetToVarSet = unsafeUFMToUniqSet . udfmToUfm . getUniqDSet++-- | transCloVarSet for DVarSet+transCloDVarSet :: (DVarSet -> DVarSet)+                  -- Map some variables in the set to+                  -- extra variables that should be in it+                -> DVarSet -> DVarSet+-- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any+-- new variables to s that it finds thereby, until it reaches a fixed point.+--+-- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet)+-- for efficiency, so that the test can be batched up.+-- It's essential that fn will work fine if given new candidates+-- one at a time; ie  fn {v1,v2} = fn v1 `union` fn v2+transCloDVarSet fn seeds+  = go seeds seeds+  where+    go :: DVarSet  -- Accumulating result+       -> DVarSet  -- Work-list; un-processed subset of accumulating result+       -> DVarSet+    -- Specification: go acc vs = acc `union` transClo fn vs++    go acc candidates+       | isEmptyDVarSet new_vs = acc+       | otherwise            = go (acc `unionDVarSet` new_vs) new_vs+       where+         new_vs = fn candidates `minusDVarSet` acc
+ compiler/GHC/Utils/Lexeme.hs view
@@ -0,0 +1,240 @@+-- (c) The GHC Team+--+-- Functions to evaluate whether or not a string is a valid identifier.+-- There is considerable overlap between the logic here and the logic+-- in Lexer.x, but sadly there seems to be no way to merge them.++module GHC.Utils.Lexeme (+          -- * Lexical characteristics of Haskell names++          -- | Use these functions to figure what kind of name a 'FastString'+          -- represents; these functions do /not/ check that the identifier+          -- is valid.++        isLexCon, isLexVar, isLexId, isLexSym,+        isLexConId, isLexConSym, isLexVarId, isLexVarSym,+        startsVarSym, startsVarId, startsConSym, startsConId,++          -- * Validating identifiers++          -- | These functions (working over plain old 'String's) check+          -- to make sure that the identifier is valid.+        okVarOcc, okConOcc, okTcOcc,+        okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc++        -- Some of the exports above are not used within GHC, but may+        -- be of value to GHC API users.++  ) where++import GhcPrelude++import FastString++import Data.Char+import qualified Data.Set as Set++import GHC.Lexeme++{-++************************************************************************+*                                                                      *+    Lexical categories+*                                                                      *+************************************************************************++These functions test strings to see if they fit the lexical categories+defined in the Haskell report.++Note [Classification of generated names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Some names generated for internal use can show up in debugging output,+e.g.  when using -ddump-simpl. These generated names start with a $+but should still be pretty-printed using prefix notation. We make sure+this is the case in isLexVarSym by only classifying a name as a symbol+if all its characters are symbols, not just its first one.+-}++isLexCon,   isLexVar,    isLexId,    isLexSym    :: FastString -> Bool+isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool++isLexCon cs = isLexConId  cs || isLexConSym cs+isLexVar cs = isLexVarId  cs || isLexVarSym cs++isLexId  cs = isLexConId  cs || isLexVarId  cs+isLexSym cs = isLexConSym cs || isLexVarSym cs++-------------+isLexConId cs                           -- Prefix type or data constructors+  | nullFS cs          = False          --      e.g. "Foo", "[]", "(,)"+  | cs == (fsLit "[]") = True+  | otherwise          = startsConId (headFS cs)++isLexVarId cs                           -- Ordinary prefix identifiers+  | nullFS cs         = False           --      e.g. "x", "_x"+  | otherwise         = startsVarId (headFS cs)++isLexConSym cs                          -- Infix type or data constructors+  | nullFS cs          = False          --      e.g. ":-:", ":", "->"+  | cs == (fsLit "->") = True+  | otherwise          = startsConSym (headFS cs)++isLexVarSym fs                          -- Infix identifiers e.g. "+"+  | fs == (fsLit "~R#") = True+  | otherwise+  = case (if nullFS fs then [] else unpackFS fs) of+      [] -> False+      (c:cs) -> startsVarSym c && all isVarSymChar cs+        -- See Note [Classification of generated names]++{-++************************************************************************+*                                                                      *+    Detecting valid names for Template Haskell+*                                                                      *+************************************************************************++-}++----------------------+-- External interface+----------------------++-- | Is this an acceptable variable name?+okVarOcc :: String -> Bool+okVarOcc str@(c:_)+  | startsVarId c+  = okVarIdOcc str+  | startsVarSym c+  = okVarSymOcc str+okVarOcc _ = False++-- | Is this an acceptable constructor name?+okConOcc :: String -> Bool+okConOcc str@(c:_)+  | startsConId c+  = okConIdOcc str+  | startsConSym c+  = okConSymOcc str+  | str == "[]"+  = True+okConOcc _ = False++-- | Is this an acceptable type name?+okTcOcc :: String -> Bool+okTcOcc "[]" = True+okTcOcc "->" = True+okTcOcc "~"  = True+okTcOcc str@(c:_)+  | startsConId c+  = okConIdOcc str+  | startsConSym c+  = okConSymOcc str+  | startsVarSym c+  = okVarSymOcc str+okTcOcc _ = False++-- | Is this an acceptable alphanumeric variable name, assuming it starts+-- with an acceptable letter?+okVarIdOcc :: String -> Bool+okVarIdOcc str = okIdOcc str &&+                 -- admit "_" as a valid identifier.  Required to support typed+                 -- holes in Template Haskell.  See #10267+                 (str == "_" || not (str `Set.member` reservedIds))++-- | Is this an acceptable symbolic variable name, assuming it starts+-- with an acceptable character?+okVarSymOcc :: String -> Bool+okVarSymOcc str = all okSymChar str &&+                  not (str `Set.member` reservedOps) &&+                  not (isDashes str)++-- | Is this an acceptable alphanumeric constructor name, assuming it+-- starts with an acceptable letter?+okConIdOcc :: String -> Bool+okConIdOcc str = okIdOcc str ||+                 is_tuple_name1 True  str ||+                   -- Is it a boxed tuple...+                 is_tuple_name1 False str ||+                   -- ...or an unboxed tuple (#12407)...+                 is_sum_name1 str+                   -- ...or an unboxed sum (#12514)?+  where+    -- check for tuple name, starting at the beginning+    is_tuple_name1 True  ('(' : rest)       = is_tuple_name2 True  rest+    is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest+    is_tuple_name1 _     _                  = False++    -- check for tuple tail+    is_tuple_name2 True  ")"          = True+    is_tuple_name2 False "#)"         = True+    is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest+    is_tuple_name2 boxed (ws  : rest)+      | isSpace ws                    = is_tuple_name2 boxed rest+    is_tuple_name2 _     _            = False++    -- check for sum name, starting at the beginning+    is_sum_name1 ('(' : '#' : rest) = is_sum_name2 False rest+    is_sum_name1 _                  = False++    -- check for sum tail, only allowing at most one underscore+    is_sum_name2 _          "#)"         = True+    is_sum_name2 underscore ('|' : rest) = is_sum_name2 underscore rest+    is_sum_name2 False      ('_' : rest) = is_sum_name2 True rest+    is_sum_name2 underscore (ws  : rest)+      | isSpace ws                       = is_sum_name2 underscore rest+    is_sum_name2 _          _            = False++-- | Is this an acceptable symbolic constructor name, assuming it+-- starts with an acceptable character?+okConSymOcc :: String -> Bool+okConSymOcc ":" = True+okConSymOcc str = all okSymChar str &&+                  not (str `Set.member` reservedOps)++----------------------+-- Internal functions+----------------------++-- | Is this string an acceptable id, possibly with a suffix of hashes,+-- but not worrying about case or clashing with reserved words?+okIdOcc :: String -> Bool+okIdOcc str+  = let hashes = dropWhile okIdChar str in+    all (== '#') hashes   -- -XMagicHash allows a suffix of hashes+                          -- of course, `all` says "True" to an empty list++-- | Is this character acceptable in an identifier (after the first letter)?+-- See alexGetByte in Lexer.x+okIdChar :: Char -> Bool+okIdChar c = case generalCategory c of+  UppercaseLetter -> True+  LowercaseLetter -> True+  TitlecaseLetter -> True+  ModifierLetter  -> True -- See #10196+  OtherLetter     -> True -- See #1103+  NonSpacingMark  -> True -- See #7650+  DecimalNumber   -> True+  OtherNumber     -> True -- See #4373+  _               -> c == '\'' || c == '_'++-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report.+reservedIds :: Set.Set String+reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving"+                           , "do", "else", "foreign", "if", "import", "in"+                           , "infix", "infixl", "infixr", "instance", "let"+                           , "module", "newtype", "of", "then", "type", "where"+                           , "_" ]++-- | All reserved operators. Taken from section 2.4 of the 2010 Report.+reservedOps :: Set.Set String+reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->"+                           , "@", "~", "=>" ]++-- | Does this string contain only dashes and has at least 2 of them?+isDashes :: String -> Bool+isDashes ('-' : '-' : rest) = all (== '-') rest+isDashes _                  = False
− compiler/basicTypes/Avail.hs 
@@ -1,286 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}------ (c) The University of Glasgow-----#include "HsVersions.h"--module Avail (-    Avails,-    AvailInfo(..),-    avail,-    availsToNameSet,-    availsToNameSetWithSelectors,-    availsToNameEnv,-    availName, availNames, availNonFldNames,-    availNamesWithSelectors,-    availFlds,-    availsNamesWithOccs,-    availNamesWithOccs,-    stableAvailCmp,-    plusAvail,-    trimAvail,-    filterAvail,-    filterAvails,-    nubAvails---  ) where--import GhcPrelude--import Name-import NameEnv-import NameSet--import FieldLabel-import Binary-import ListSetOps-import Outputable-import Util--import Data.Data ( Data )-import Data.List ( find )-import Data.Function---- -------------------------------------------------------------------------------- The AvailInfo type---- | Records what things are \"available\", i.e. in scope-data AvailInfo--  -- | An ordinary identifier in scope-  = Avail Name--  -- | A type or class in scope-  ---  -- The __AvailTC Invariant__: If the type or class is itself to be in scope,-  -- it must be /first/ in this list.  Thus, typically:-  ---  -- > AvailTC Eq [Eq, ==, \/=] []-  | AvailTC-       Name         -- ^ The name of the type or class-       [Name]       -- ^ The available pieces of type or class,-                    -- excluding field selectors.-       [FieldLabel] -- ^ The record fields of the type-                    -- (see Note [Representing fields in AvailInfo]).--   deriving ( Eq    -- ^ Used when deciding if the interface has changed-            , Data )---- | A collection of 'AvailInfo' - several things that are \"available\"-type Avails = [AvailInfo]--{--Note [Representing fields in AvailInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When -XDuplicateRecordFields is disabled (the normal case), a-datatype like--  data T = MkT { foo :: Int }--gives rise to the AvailInfo--  AvailTC T [T, MkT] [FieldLabel "foo" False foo]--whereas if -XDuplicateRecordFields is enabled it gives--  AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT]--since the label does not match the selector name.--The labels in a field list are not necessarily unique:-data families allow the same parent (the family tycon) to have-multiple distinct fields with the same label. For example,--  data family F a-  data instance F Int  = MkFInt { foo :: Int }-  data instance F Bool = MkFBool { foo :: Bool}--gives rise to--  AvailTC F [ F, MkFInt, MkFBool ]-            [ FieldLabel "foo" True $sel:foo:MkFInt-            , FieldLabel "foo" True $sel:foo:MkFBool ]--Moreover, note that the flIsOverloaded flag need not be the same for-all the elements of the list.  In the example above, this occurs if-the two data instances are defined in different modules, one with-`-XDuplicateRecordFields` enabled and one with it disabled.  Thus it-is possible to have--  AvailTC F [ F, MkFInt, MkFBool ]-            [ FieldLabel "foo" True $sel:foo:MkFInt-            , FieldLabel "foo" False foo ]--If the two data instances are defined in different modules, both-without `-XDuplicateRecordFields`, it will be impossible to export-them from the same module (even with `-XDuplicateRecordfields`-enabled), because they would be represented identically.  The-workaround here is to enable `-XDuplicateRecordFields` on the defining-modules.--}---- | Compare lexicographically-stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering-stableAvailCmp (Avail n1)       (Avail n2)   = n1 `stableNameCmp` n2-stableAvailCmp (Avail {})         (AvailTC {})   = LT-stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =-    (n `stableNameCmp` m) `thenCmp`-    (cmpList stableNameCmp ns ms) `thenCmp`-    (cmpList (stableNameCmp `on` flSelector) nfs mfs)-stableAvailCmp (AvailTC {})       (Avail {})     = GT--avail :: Name -> AvailInfo-avail n = Avail n---- -------------------------------------------------------------------------------- Operations on AvailInfo--availsToNameSet :: [AvailInfo] -> NameSet-availsToNameSet avails = foldr add emptyNameSet avails-      where add avail set = extendNameSetList set (availNames avail)--availsToNameSetWithSelectors :: [AvailInfo] -> NameSet-availsToNameSetWithSelectors avails = foldr add emptyNameSet avails-      where add avail set = extendNameSetList set (availNamesWithSelectors avail)--availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo-availsToNameEnv avails = foldr add emptyNameEnv avails-     where add avail env = extendNameEnvList env-                                (zip (availNames avail) (repeat avail))---- | Just the main name made available, i.e. not the available pieces--- of type or class brought into scope by the 'GenAvailInfo'-availName :: AvailInfo -> Name-availName (Avail n)     = n-availName (AvailTC n _ _) = n---- | All names made available by the availability information (excluding overloaded selectors)-availNames :: AvailInfo -> [Name]-availNames (Avail n)         = [n]-availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]---- | All names made available by the availability information (including overloaded selectors)-availNamesWithSelectors :: AvailInfo -> [Name]-availNamesWithSelectors (Avail n)         = [n]-availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs---- | Names for non-fields made available by the availability information-availNonFldNames :: AvailInfo -> [Name]-availNonFldNames (Avail n)        = [n]-availNonFldNames (AvailTC _ ns _) = ns---- | Fields made available by the availability information-availFlds :: AvailInfo -> [FieldLabel]-availFlds (AvailTC _ _ fs) = fs-availFlds _                = []--availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)]-availsNamesWithOccs = concatMap availNamesWithOccs---- | 'Name's made available by the availability information, paired with--- the 'OccName' used to refer to each one.------ When @DuplicateRecordFields@ is in use, the 'Name' may be the--- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the--- 'OccName' will be the label of the field (e.g. @foo@).------ See Note [Representing fields in AvailInfo].-availNamesWithOccs :: AvailInfo -> [(Name, OccName)]-availNamesWithOccs (Avail n) = [(n, nameOccName n)]-availNamesWithOccs (AvailTC _ ns fs)-  = [ (n, nameOccName n) | n <- ns ] ++-    [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ]---- -------------------------------------------------------------------------------- Utility--plusAvail :: AvailInfo -> AvailInfo -> AvailInfo-plusAvail a1 a2-  | debugIsOn && availName a1 /= availName a2-  = pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2])-plusAvail a1@(Avail {})         (Avail {})        = a1-plusAvail (AvailTC _ [] [])     a2@(AvailTC {})   = a2-plusAvail a1@(AvailTC {})       (AvailTC _ [] []) = a1-plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)-  = case (n1==s1, n2==s2) of  -- Maintain invariant the parent is first-       (True,True)   -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))-                                   (fs1 `unionLists` fs2)-       (True,False)  -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))-                                   (fs1 `unionLists` fs2)-       (False,True)  -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))-                                   (fs1 `unionLists` fs2)-       (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))-                                   (fs1 `unionLists` fs2)-plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)-  = AvailTC n1 ss1 (fs1 `unionLists` fs2)-plusAvail (AvailTC n1 [] fs1)  (AvailTC _ ss2 fs2)-  = AvailTC n1 ss2 (fs1 `unionLists` fs2)-plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2])---- | trims an 'AvailInfo' to keep only a single name-trimAvail :: AvailInfo -> Name -> AvailInfo-trimAvail (Avail n)         _ = Avail n-trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of-    Just x  -> AvailTC n [] [x]-    Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] []---- | filters 'AvailInfo's by the given predicate-filterAvails  :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]-filterAvails keep avails = foldr (filterAvail keep) [] avails---- | filters an 'AvailInfo' by the given predicate-filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]-filterAvail keep ie rest =-  case ie of-    Avail n | keep n    -> ie : rest-            | otherwise -> rest-    AvailTC tc ns fs ->-        let ns' = filter keep ns-            fs' = filter (keep . flSelector) fs in-        if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest----- | Combines 'AvailInfo's from the same family--- 'avails' may have several items with the same availName--- E.g  import Ix( Ix(..), index )--- will give Ix(Ix,index,range) and Ix(index)--- We want to combine these; addAvail does that-nubAvails :: [AvailInfo] -> [AvailInfo]-nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails)-  where-    add env avail = extendNameEnv_C plusAvail env (availName avail) avail---- -------------------------------------------------------------------------------- Printing--instance Outputable AvailInfo where-   ppr = pprAvail--pprAvail :: AvailInfo -> SDoc-pprAvail (Avail n)-  = ppr n-pprAvail (AvailTC n ns fs)-  = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi-                         , fsep (punctuate comma (map (ppr . flLabel) fs))])--instance Binary AvailInfo where-    put_ bh (Avail aa) = do-            putByte bh 0-            put_ bh aa-    put_ bh (AvailTC ab ac ad) = do-            putByte bh 1-            put_ bh ab-            put_ bh ac-            put_ bh ad-    get bh = do-            h <- getByte bh-            case h of-              0 -> do aa <- get bh-                      return (Avail aa)-              _ -> do ab <- get bh-                      ac <- get bh-                      ad <- get bh-                      return (AvailTC ab ac ad)
− compiler/basicTypes/BasicTypes.hs 
@@ -1,1736 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1997-1998--\section[BasicTypes]{Miscellaneous types}--This module defines a miscellaneously collection of very simple-types that--\begin{itemize}-\item have no other obvious home-\item don't depend on any other complicated types-\item are used in more than one "part" of the compiler-\end{itemize}--}--{-# LANGUAGE DeriveDataTypeable #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--module BasicTypes(-        Version, bumpVersion, initialVersion,--        LeftOrRight(..),-        pickLR,--        ConTag, ConTagZ, fIRST_TAG,--        Arity, RepArity, JoinArity,--        Alignment, mkAlignment, alignmentOf, alignmentBytes,--        PromotionFlag(..), isPromoted,-        FunctionOrData(..),--        WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..),--        Fixity(..), FixityDirection(..),-        defaultFixity, maxPrecedence, minPrecedence,-        negateFixity, funTyFixity,-        compareFixity,-        LexicalFixity(..),--        RecFlag(..), isRec, isNonRec, boolToRecFlag,-        Origin(..), isGenerated,--        RuleName, pprRuleName,--        TopLevelFlag(..), isTopLevel, isNotTopLevel,--        OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,-        hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,--        Boxity(..), isBoxed,--        PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec,-        maybeParen,--        TupleSort(..), tupleSortBoxity, boxityTupleSort,-        tupleParens,--        sumParens, pprAlternative,--        -- ** The OneShotInfo type-        OneShotInfo(..),-        noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,-        bestOneShot, worstOneShot,--        OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc,-        isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs,-        strongLoopBreaker, weakLoopBreaker,--        InsideLam(..),-        OneBranch(..),-        InterestingCxt(..),-        TailCallInfo(..), tailCallInfo, zapOccTailCallInfo,-        isAlwaysTailCalled,--        EP(..),--        DefMethSpec(..),-        SwapFlag(..), flipSwap, unSwap, isSwapped,--        CompilerPhase(..), PhaseNum,--        Activation(..), isActive, isActiveIn, competesWith,-        isNeverActive, isAlwaysActive, isEarlyActive,-        activeAfterInitial, activeDuringFinal,--        RuleMatchInfo(..), isConLike, isFunLike,-        InlineSpec(..), noUserInlineSpec,-        InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,-        neverInlinePragma, dfunInlinePragma,-        isDefaultInlinePragma,-        isInlinePragma, isInlinablePragma, isAnyInlinePragma,-        inlinePragmaSpec, inlinePragmaSat,-        inlinePragmaActivation, inlinePragmaRuleMatchInfo,-        setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,-        pprInline, pprInlineDebug,--        SuccessFlag(..), succeeded, failed, successIf,--        IntegralLit(..), FractionalLit(..),-        negateIntegralLit, negateFractionalLit,-        mkIntegralLit, mkFractionalLit,-        integralFractionalLit,--        SourceText(..), pprWithSourceText,--        IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,--        SpliceExplicitFlag(..),--        TypeOrKind(..), isTypeLevel, isKindLevel-   ) where--import GhcPrelude--import FastString-import Outputable-import SrcLoc ( Located,unLoc )-import Data.Data hiding (Fixity, Prefix, Infix)-import Data.Function (on)-import Data.Bits-import qualified Data.Semigroup as Semi--{--************************************************************************-*                                                                      *-          Binary choice-*                                                                      *-************************************************************************--}--data LeftOrRight = CLeft | CRight-                 deriving( Eq, Data )--pickLR :: LeftOrRight -> (a,a) -> a-pickLR CLeft  (l,_) = l-pickLR CRight (_,r) = r--instance Outputable LeftOrRight where-  ppr CLeft    = text "Left"-  ppr CRight   = text "Right"--{--************************************************************************-*                                                                      *-\subsection[Arity]{Arity}-*                                                                      *-************************************************************************--}---- | The number of value arguments that can be applied to a value before it does--- "real work". So:---  fib 100     has arity 0---  \x -> fib x has arity 1--- See also Note [Definition of arity] in GHC.Core.Arity-type Arity = Int---- | Representation Arity------ The number of represented arguments that can be applied to a value before it does--- "real work". So:---  fib 100                    has representation arity 0---  \x -> fib x                has representation arity 1---  \(# x, y #) -> fib (x + y) has representation arity 2-type RepArity = Int---- | The number of arguments that a join point takes. Unlike the arity of a--- function, this is a purely syntactic property and is fixed when the join--- point is created (or converted from a value). Both type and value arguments--- are counted.-type JoinArity = Int--{--************************************************************************-*                                                                      *-              Constructor tags-*                                                                      *-************************************************************************--}---- | Constructor Tag------ Type of the tags associated with each constructor possibility or superclass--- selector-type ConTag = Int---- | A *zero-indexed* constructor tag-type ConTagZ = Int--fIRST_TAG :: ConTag--- ^ Tags are allocated from here for real constructors---   or for superclass selectors-fIRST_TAG =  1--{--************************************************************************-*                                                                      *-\subsection[Alignment]{Alignment}-*                                                                      *-************************************************************************--}---- | A power-of-two alignment-newtype Alignment = Alignment { alignmentBytes :: Int } deriving (Eq, Ord)---- Builds an alignment, throws on non power of 2 input. This is not--- ideal, but convenient for internal use and better then silently--- passing incorrect data.-mkAlignment :: Int -> Alignment-mkAlignment n-  | n == 1 = Alignment 1-  | n == 2 = Alignment 2-  | n == 4 = Alignment 4-  | n == 8 = Alignment 8-  | n == 16 = Alignment 16-  | n == 32 = Alignment 32-  | n == 64 = Alignment 64-  | n == 128 = Alignment 128-  | n == 256 = Alignment 256-  | n == 512 = Alignment 512-  | otherwise = panic "mkAlignment: received either a non power of 2 argument or > 512"---- Calculates an alignment of a number. x is aligned at N bytes means--- the remainder from x / N is zero. Currently, interested in N <= 8,--- but can be expanded to N <= 16 or N <= 32 if used within SSE or AVX--- context.-alignmentOf :: Int -> Alignment-alignmentOf x = case x .&. 7 of-  0 -> Alignment 8-  4 -> Alignment 4-  2 -> Alignment 2-  _ -> Alignment 1--instance Outputable Alignment where-  ppr (Alignment m) = ppr m-{--************************************************************************-*                                                                      *-         One-shot information-*                                                                      *-************************************************************************--}---- | If the 'Id' is a lambda-bound variable then it may have lambda-bound--- variable info. Sometimes we know whether the lambda binding this variable--- is a \"one-shot\" lambda; that is, whether it is applied at most once.------ This information may be useful in optimisation, as computations may--- safely be floated inside such a lambda without risk of duplicating--- work.-data OneShotInfo-  = NoOneShotInfo -- ^ No information-  | OneShotLam    -- ^ The lambda is applied at most once.-  deriving (Eq)---- | It is always safe to assume that an 'Id' has no lambda-bound variable information-noOneShotInfo :: OneShotInfo-noOneShotInfo = NoOneShotInfo--isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool-isOneShotInfo OneShotLam = True-isOneShotInfo _          = False--hasNoOneShotInfo NoOneShotInfo = True-hasNoOneShotInfo _             = False--worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo-worstOneShot NoOneShotInfo _             = NoOneShotInfo-worstOneShot OneShotLam    os            = os--bestOneShot NoOneShotInfo os         = os-bestOneShot OneShotLam    _          = OneShotLam--pprOneShotInfo :: OneShotInfo -> SDoc-pprOneShotInfo NoOneShotInfo = empty-pprOneShotInfo OneShotLam    = text "OneShot"--instance Outputable OneShotInfo where-    ppr = pprOneShotInfo--{--************************************************************************-*                                                                      *-           Swap flag-*                                                                      *-************************************************************************--}--data SwapFlag-  = NotSwapped  -- Args are: actual,   expected-  | IsSwapped   -- Args are: expected, actual--instance Outputable SwapFlag where-  ppr IsSwapped  = text "Is-swapped"-  ppr NotSwapped = text "Not-swapped"--flipSwap :: SwapFlag -> SwapFlag-flipSwap IsSwapped  = NotSwapped-flipSwap NotSwapped = IsSwapped--isSwapped :: SwapFlag -> Bool-isSwapped IsSwapped  = True-isSwapped NotSwapped = False--unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b-unSwap NotSwapped f a b = f a b-unSwap IsSwapped  f a b = f b a---{- *********************************************************************-*                                                                      *-           Promotion flag-*                                                                      *-********************************************************************* -}---- | Is a TyCon a promoted data constructor or just a normal type constructor?-data PromotionFlag-  = NotPromoted-  | IsPromoted-  deriving ( Eq, Data )--isPromoted :: PromotionFlag -> Bool-isPromoted IsPromoted  = True-isPromoted NotPromoted = False--instance Outputable PromotionFlag where-  ppr NotPromoted = text "NotPromoted"-  ppr IsPromoted  = text "IsPromoted"--{--************************************************************************-*                                                                      *-\subsection[FunctionOrData]{FunctionOrData}-*                                                                      *-************************************************************************--}--data FunctionOrData = IsFunction | IsData-    deriving (Eq, Ord, Data)--instance Outputable FunctionOrData where-    ppr IsFunction = text "(function)"-    ppr IsData     = text "(data)"--{--************************************************************************-*                                                                      *-\subsection[Version]{Module and identifier version numbers}-*                                                                      *-************************************************************************--}--type Version = Int--bumpVersion :: Version -> Version-bumpVersion v = v+1--initialVersion :: Version-initialVersion = 1--{--************************************************************************-*                                                                      *-                Deprecations-*                                                                      *-************************************************************************--}---- | A String Literal in the source, including its original raw format for use by--- source to source manipulation tools.-data StringLiteral = StringLiteral-                       { sl_st :: SourceText, -- literal raw source.-                                              -- See not [Literal source text]-                         sl_fs :: FastString  -- literal string value-                       } deriving Data--instance Eq StringLiteral where-  (StringLiteral _ a) == (StringLiteral _ b) = a == b--instance Outputable StringLiteral where-  ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)---- | Warning Text------ reason/explanation from a WARNING or DEPRECATED pragma-data WarningTxt = WarningTxt (Located SourceText)-                             [Located StringLiteral]-                | DeprecatedTxt (Located SourceText)-                                [Located StringLiteral]-    deriving (Eq, Data)--instance Outputable WarningTxt where-    ppr (WarningTxt    lsrc ws)-      = case unLoc lsrc of-          NoSourceText   -> pp_ws ws-          SourceText src -> text src <+> pp_ws ws <+> text "#-}"--    ppr (DeprecatedTxt lsrc  ds)-      = case unLoc lsrc of-          NoSourceText   -> pp_ws ds-          SourceText src -> text src <+> pp_ws ds <+> text "#-}"--pp_ws :: [Located StringLiteral] -> SDoc-pp_ws [l] = ppr $ unLoc l-pp_ws ws-  = text "["-    <+> vcat (punctuate comma (map (ppr . unLoc) ws))-    <+> text "]"---pprWarningTxtForMsg :: WarningTxt -> SDoc-pprWarningTxtForMsg (WarningTxt    _ ws)-                     = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))-pprWarningTxtForMsg (DeprecatedTxt _ ds)-                     = text "Deprecated:" <+>-                       doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))--{--************************************************************************-*                                                                      *-                Rules-*                                                                      *-************************************************************************--}--type RuleName = FastString--pprRuleName :: RuleName -> SDoc-pprRuleName rn = doubleQuotes (ftext rn)--{--************************************************************************-*                                                                      *-\subsection[Fixity]{Fixity info}-*                                                                      *-************************************************************************--}---------------------------data Fixity = Fixity SourceText Int FixityDirection-  -- Note [Pragma source text]-  deriving Data--instance Outputable Fixity where-    ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec]--instance Eq Fixity where -- Used to determine if two fixities conflict-  (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2---------------------------data FixityDirection = InfixL | InfixR | InfixN-                     deriving (Eq, Data)--instance Outputable FixityDirection where-    ppr InfixL = text "infixl"-    ppr InfixR = text "infixr"-    ppr InfixN = text "infix"---------------------------maxPrecedence, minPrecedence :: Int-maxPrecedence = 9-minPrecedence = 0--defaultFixity :: Fixity-defaultFixity = Fixity NoSourceText maxPrecedence InfixL--negateFixity, funTyFixity :: Fixity--- Wired-in fixities-negateFixity = Fixity NoSourceText 6 InfixL  -- Fixity of unary negate-funTyFixity  = Fixity NoSourceText (-1) InfixR  -- Fixity of '->', see #15235--{--Consider--\begin{verbatim}-        a `op1` b `op2` c-\end{verbatim}-@(compareFixity op1 op2)@ tells which way to arrange application, or-whether there's an error.--}--compareFixity :: Fixity -> Fixity-              -> (Bool,         -- Error please-                  Bool)         -- Associate to the right: a op1 (b op2 c)-compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)-  = case prec1 `compare` prec2 of-        GT -> left-        LT -> right-        EQ -> case (dir1, dir2) of-                        (InfixR, InfixR) -> right-                        (InfixL, InfixL) -> left-                        _                -> error_please-  where-    right        = (False, True)-    left         = (False, False)-    error_please = (True,  False)---- |Captures the fixity of declarations as they are parsed. This is not--- necessarily the same as the fixity declaration, as the normal fixity may be--- overridden using parens or backticks.-data LexicalFixity = Prefix | Infix deriving (Data,Eq)--instance Outputable LexicalFixity where-  ppr Prefix = text "Prefix"-  ppr Infix  = text "Infix"--{--************************************************************************-*                                                                      *-\subsection[Top-level/local]{Top-level/not-top level flag}-*                                                                      *-************************************************************************--}--data TopLevelFlag-  = TopLevel-  | NotTopLevel--isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool--isNotTopLevel NotTopLevel = True-isNotTopLevel TopLevel    = False--isTopLevel TopLevel     = True-isTopLevel NotTopLevel  = False--instance Outputable TopLevelFlag where-  ppr TopLevel    = text "<TopLevel>"-  ppr NotTopLevel = text "<NotTopLevel>"--{--************************************************************************-*                                                                      *-                Boxity flag-*                                                                      *-************************************************************************--}--data Boxity-  = Boxed-  | Unboxed-  deriving( Eq, Data )--isBoxed :: Boxity -> Bool-isBoxed Boxed   = True-isBoxed Unboxed = False--instance Outputable Boxity where-  ppr Boxed   = text "Boxed"-  ppr Unboxed = text "Unboxed"--{--************************************************************************-*                                                                      *-                Recursive/Non-Recursive flag-*                                                                      *-************************************************************************--}---- | Recursivity Flag-data RecFlag = Recursive-             | NonRecursive-             deriving( Eq, Data )--isRec :: RecFlag -> Bool-isRec Recursive    = True-isRec NonRecursive = False--isNonRec :: RecFlag -> Bool-isNonRec Recursive    = False-isNonRec NonRecursive = True--boolToRecFlag :: Bool -> RecFlag-boolToRecFlag True  = Recursive-boolToRecFlag False = NonRecursive--instance Outputable RecFlag where-  ppr Recursive    = text "Recursive"-  ppr NonRecursive = text "NonRecursive"--{--************************************************************************-*                                                                      *-                Code origin-*                                                                      *-************************************************************************--}--data Origin = FromSource-            | Generated-            deriving( Eq, Data )--isGenerated :: Origin -> Bool-isGenerated Generated = True-isGenerated FromSource = False--instance Outputable Origin where-  ppr FromSource  = text "FromSource"-  ppr Generated   = text "Generated"--{--************************************************************************-*                                                                      *-                Instance overlap flag-*                                                                      *-************************************************************************--}---- | The semantics allowed for overlapping instances for a particular--- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a--- explanation of the `isSafeOverlap` field.------ - 'ApiAnnotation.AnnKeywordId' :---      'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or---                              @'\{-\# OVERLAPPING'@ or---                              @'\{-\# OVERLAPS'@ or---                              @'\{-\# INCOHERENT'@,---      'ApiAnnotation.AnnClose' @`\#-\}`@,---- For details on above see note [Api annotations] in ApiAnnotation-data OverlapFlag = OverlapFlag-  { overlapMode   :: OverlapMode-  , isSafeOverlap :: Bool-  } deriving (Eq, Data)--setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag-setOverlapModeMaybe f Nothing  = f-setOverlapModeMaybe f (Just m) = f { overlapMode = m }--hasIncoherentFlag :: OverlapMode -> Bool-hasIncoherentFlag mode =-  case mode of-    Incoherent   _ -> True-    _              -> False--hasOverlappableFlag :: OverlapMode -> Bool-hasOverlappableFlag mode =-  case mode of-    Overlappable _ -> True-    Overlaps     _ -> True-    Incoherent   _ -> True-    _              -> False--hasOverlappingFlag :: OverlapMode -> Bool-hasOverlappingFlag mode =-  case mode of-    Overlapping  _ -> True-    Overlaps     _ -> True-    Incoherent   _ -> True-    _              -> False--data OverlapMode  -- See Note [Rules for instance lookup] in InstEnv-  = NoOverlap SourceText-                  -- See Note [Pragma source text]-    -- ^ This instance must not overlap another `NoOverlap` instance.-    -- However, it may be overlapped by `Overlapping` instances,-    -- and it may overlap `Overlappable` instances.---  | Overlappable SourceText-                  -- See Note [Pragma source text]-    -- ^ Silently ignore this instance if you find a-    -- more specific one that matches the constraint-    -- you are trying to resolve-    ---    -- Example: constraint (Foo [Int])-    --   instance                      Foo [Int]-    --   instance {-# OVERLAPPABLE #-} Foo [a]-    ---    -- Since the second instance has the Overlappable flag,-    -- the first instance will be chosen (otherwise-    -- its ambiguous which to choose)---  | Overlapping SourceText-                  -- See Note [Pragma source text]-    -- ^ Silently ignore any more general instances that may be-    --   used to solve the constraint.-    ---    -- Example: constraint (Foo [Int])-    --   instance {-# OVERLAPPING #-} Foo [Int]-    --   instance                     Foo [a]-    ---    -- Since the first instance has the Overlapping flag,-    -- the second---more general---instance will be ignored (otherwise-    -- it is ambiguous which to choose)---  | Overlaps SourceText-                  -- See Note [Pragma source text]-    -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.--  | Incoherent SourceText-                  -- See Note [Pragma source text]-    -- ^ Behave like Overlappable and Overlapping, and in addition pick-    -- an an arbitrary one if there are multiple matching candidates, and-    -- don't worry about later instantiation-    ---    -- Example: constraint (Foo [b])-    -- instance {-# INCOHERENT -} Foo [Int]-    -- instance                   Foo [a]-    -- Without the Incoherent flag, we'd complain that-    -- instantiating 'b' would change which instance-    -- was chosen. See also note [Incoherent instances] in InstEnv--  deriving (Eq, Data)---instance Outputable OverlapFlag where-   ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)--instance Outputable OverlapMode where-   ppr (NoOverlap    _) = empty-   ppr (Overlappable _) = text "[overlappable]"-   ppr (Overlapping  _) = text "[overlapping]"-   ppr (Overlaps     _) = text "[overlap ok]"-   ppr (Incoherent   _) = text "[incoherent]"--pprSafeOverlap :: Bool -> SDoc-pprSafeOverlap True  = text "[safe]"-pprSafeOverlap False = empty--{--************************************************************************-*                                                                      *-                Precedence-*                                                                      *-************************************************************************--}---- | A general-purpose pretty-printing precedence type.-newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show)--- See Note [Precedence in types]--topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec :: PprPrec-topPrec = PprPrec 0 -- No parens-sigPrec = PprPrec 1 -- Explicit type signatures-funPrec = PprPrec 2 -- Function args; no parens for constructor apps-                    -- See [Type operator precedence] for why both-                    -- funPrec and opPrec exist.-opPrec  = PprPrec 2 -- Infix operator-starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *)-                     -- See Note [Star kind precedence]-appPrec  = PprPrec 4 -- Constructor args; no parens for atomic--maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc-maybeParen ctxt_prec inner_prec pretty-  | ctxt_prec < inner_prec = pretty-  | otherwise              = parens pretty--{- Note [Precedence in types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Many pretty-printing functions have type-    ppr_ty :: PprPrec -> Type -> SDoc--The PprPrec gives the binding strength of the context.  For example, in-   T ty1 ty2-we will pretty-print 'ty1' and 'ty2' with the call-  (ppr_ty appPrec ty)-to indicate that the context is that of an argument of a TyConApp.--We use this consistently for Type and HsType.--Note [Type operator precedence]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't keep the fixity of type operators in the operator. So the-pretty printer follows the following precedence order:--   TyConPrec         Type constructor application-   TyOpPrec/FunPrec  Operator application and function arrow--We have funPrec and opPrec to represent the precedence of function-arrow and type operators respectively, but currently we implement-funPrec == opPrec, so that we don't distinguish the two. Reason:-it's hard to parse a type like-    a ~ b => c * d -> e - f--By treating opPrec = funPrec we end up with more parens-    (a ~ b) => (c * d) -> (e - f)--But the two are different constructors of PprPrec so we could make-(->) bind more or less tightly if we wanted.--Note [Star kind precedence]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-We parenthesize the (*) kind to avoid two issues:--1. Printing invalid or incorrect code.-   For example, instead of  type F @(*) x = x-         GHC used to print  type F @*   x = x-   However, (@*) is a type operator, not a kind application.--2. Printing kinds that are correct but hard to read.-   Should  Either * Int  be read as  Either (*) Int-                              or as  (*) Either Int  ?-   This depends on whether -XStarIsType is enabled, but it would be-   easier if we didn't have to check for the flag when reading the code.--At the same time, we cannot parenthesize (*) blindly.-Consider this Haskell98 kind:          ((* -> *) -> *) -> *-With parentheses, it is less readable: (((*) -> (*)) -> (*)) -> (*)--The solution is to assign a special precedence to (*), 'starPrec', which is-higher than 'funPrec' but lower than 'appPrec':--   F * * *   becomes  F (*) (*) (*)-   F A * B   becomes  F A (*) B-   Proxy *   becomes  Proxy (*)-   a * -> *  becomes  a (*) -> *--}--{--************************************************************************-*                                                                      *-                Tuples-*                                                                      *-************************************************************************--}--data TupleSort-  = BoxedTuple-  | UnboxedTuple-  | ConstraintTuple-  deriving( Eq, Data )--instance Outputable TupleSort where-  ppr ts = text $-    case ts of-      BoxedTuple      -> "BoxedTuple"-      UnboxedTuple    -> "UnboxedTuple"-      ConstraintTuple -> "ConstraintTuple"--tupleSortBoxity :: TupleSort -> Boxity-tupleSortBoxity BoxedTuple      = Boxed-tupleSortBoxity UnboxedTuple    = Unboxed-tupleSortBoxity ConstraintTuple = Boxed--boxityTupleSort :: Boxity -> TupleSort-boxityTupleSort Boxed   = BoxedTuple-boxityTupleSort Unboxed = UnboxedTuple--tupleParens :: TupleSort -> SDoc -> SDoc-tupleParens BoxedTuple      p = parens p-tupleParens UnboxedTuple    p = text "(#" <+> p <+> ptext (sLit "#)")-tupleParens ConstraintTuple p   -- In debug-style write (% Eq a, Ord b %)-  = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)"))-               (parens p)--{--************************************************************************-*                                                                      *-                Sums-*                                                                      *-************************************************************************--}--sumParens :: SDoc -> SDoc-sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")---- | Pretty print an alternative in an unboxed sum e.g. "| a | |".-pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use-               -> a           -- ^ The things to be pretty printed-               -> ConTag      -- ^ Alternative (one-based)-               -> Arity       -- ^ Arity-               -> SDoc        -- ^ 'SDoc' where the alternative havs been pretty-                              -- printed and finally packed into a paragraph.-pprAlternative pp x alt arity =-    fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar)--{--************************************************************************-*                                                                      *-\subsection[Generic]{Generic flag}-*                                                                      *-************************************************************************--This is the "Embedding-Projection pair" datatype, it contains-two pieces of code (normally either RenamedExpr's or Id's)-If we have a such a pair (EP from to), the idea is that 'from' and 'to'-represents functions of type--        from :: T -> Tring-        to   :: Tring -> T--And we should have--        to (from x) = x--T and Tring are arbitrary, but typically T is the 'main' type while-Tring is the 'representation' type.  (This just helps us remember-whether to use 'from' or 'to'.--}---- | Embedding Projection pair-data EP a = EP { fromEP :: a,   -- :: T -> Tring-                 toEP   :: a }  -- :: Tring -> T--{--Embedding-projection pairs are used in several places:--First of all, each type constructor has an EP associated with it, the-code in EP converts (datatype T) from T to Tring and back again.--Secondly, when we are filling in Generic methods (in the typechecker,-tcMethodBinds), we are constructing bimaps by induction on the structure-of the type of the method signature.---************************************************************************-*                                                                      *-\subsection{Occurrence information}-*                                                                      *-************************************************************************--This data type is used exclusively by the simplifier, but it appears in a-SubstResult, which is currently defined in VarEnv, which is pretty near-the base of the module hierarchy.  So it seemed simpler to put the-defn of OccInfo here, safely at the bottom--}---- | identifier Occurrence Information-data OccInfo-  = ManyOccs        { occ_tail    :: !TailCallInfo }-                        -- ^ There are many occurrences, or unknown occurrences--  | IAmDead             -- ^ Marks unused variables.  Sometimes useful for-                        -- lambda and case-bound variables.--  | OneOcc          { occ_in_lam  :: !InsideLam-                    , occ_one_br  :: !OneBranch-                    , occ_int_cxt :: !InterestingCxt-                    , occ_tail    :: !TailCallInfo }-                        -- ^ Occurs exactly once (per branch), not inside a rule--  -- | This identifier breaks a loop of mutually recursive functions. The field-  -- marks whether it is only a loop breaker due to a reference in a rule-  | IAmALoopBreaker { occ_rules_only :: !RulesOnly-                    , occ_tail       :: !TailCallInfo }-                        -- Note [LoopBreaker OccInfo]-  deriving (Eq)--type RulesOnly = Bool--{--Note [LoopBreaker OccInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~-   IAmALoopBreaker True  <=> A "weak" or rules-only loop breaker-                             Do not preInlineUnconditionally--   IAmALoopBreaker False <=> A "strong" loop breaker-                             Do not inline at all--See OccurAnal Note [Weak loop breakers]--}--noOccInfo :: OccInfo-noOccInfo = ManyOccs { occ_tail = NoTailCallInfo }--isManyOccs :: OccInfo -> Bool-isManyOccs ManyOccs{} = True-isManyOccs _          = False--seqOccInfo :: OccInfo -> ()-seqOccInfo occ = occ `seq` ()---------------------- | Interesting Context-data InterestingCxt-  = IsInteresting-    -- ^ Function: is applied-    --   Data value: scrutinised by a case with at least one non-DEFAULT branch-  | NotInteresting-  deriving (Eq)---- | If there is any 'interesting' identifier occurrence, then the--- aggregated occurrence info of that identifier is considered interesting.-instance Semi.Semigroup InterestingCxt where-  NotInteresting <> x = x-  IsInteresting  <> _ = IsInteresting--instance Monoid InterestingCxt where-  mempty = NotInteresting-  mappend = (Semi.<>)---------------------- | Inside Lambda-data InsideLam-  = IsInsideLam-    -- ^ Occurs inside a non-linear lambda-    -- Substituting a redex for this occurrence is-    -- dangerous because it might duplicate work.-  | NotInsideLam-  deriving (Eq)---- | If any occurrence of an identifier is inside a lambda, then the--- occurrence info of that identifier marks it as occurring inside a lambda-instance Semi.Semigroup InsideLam where-  NotInsideLam <> x = x-  IsInsideLam  <> _ = IsInsideLam--instance Monoid InsideLam where-  mempty = NotInsideLam-  mappend = (Semi.<>)--------------------data OneBranch-  = InOneBranch-    -- ^ One syntactic occurrence: Occurs in only one case branch-    -- so no code-duplication issue to worry about-  | MultipleBranches-  deriving (Eq)--------------------data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo]-                  | NoTailCallInfo-  deriving (Eq)--tailCallInfo :: OccInfo -> TailCallInfo-tailCallInfo IAmDead   = NoTailCallInfo-tailCallInfo other     = occ_tail other--zapOccTailCallInfo :: OccInfo -> OccInfo-zapOccTailCallInfo IAmDead   = IAmDead-zapOccTailCallInfo occ       = occ { occ_tail = NoTailCallInfo }--isAlwaysTailCalled :: OccInfo -> Bool-isAlwaysTailCalled occ-  = case tailCallInfo occ of AlwaysTailCalled{} -> True-                             NoTailCallInfo     -> False--instance Outputable TailCallInfo where-  ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ]-  ppr _                     = empty--------------------strongLoopBreaker, weakLoopBreaker :: OccInfo-strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo-weakLoopBreaker   = IAmALoopBreaker True  NoTailCallInfo--isWeakLoopBreaker :: OccInfo -> Bool-isWeakLoopBreaker (IAmALoopBreaker{}) = True-isWeakLoopBreaker _                   = False--isStrongLoopBreaker :: OccInfo -> Bool-isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True-  -- Loop-breaker that breaks a non-rule cycle-isStrongLoopBreaker _                                            = False--isDeadOcc :: OccInfo -> Bool-isDeadOcc IAmDead = True-isDeadOcc _       = False--isOneOcc :: OccInfo -> Bool-isOneOcc (OneOcc {}) = True-isOneOcc _           = False--zapFragileOcc :: OccInfo -> OccInfo--- Keep only the most robust data: deadness, loop-breaker-hood-zapFragileOcc (OneOcc {}) = noOccInfo-zapFragileOcc occ         = zapOccTailCallInfo occ--instance Outputable OccInfo where-  -- only used for debugging; never parsed.  KSW 1999-07-  ppr (ManyOccs tails)     = pprShortTailCallInfo tails-  ppr IAmDead              = text "Dead"-  ppr (IAmALoopBreaker rule_only tails)-        = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails-        where-          pp_ro | rule_only = char '!'-                | otherwise = empty-  ppr (OneOcc inside_lam one_branch int_cxt tail_info)-        = text "Once" <> pp_lam inside_lam <> pp_br one_branch <> pp_args int_cxt <> pp_tail-        where-          pp_lam IsInsideLam     = char 'L'-          pp_lam NotInsideLam    = empty-          pp_br MultipleBranches = char '*'-          pp_br InOneBranch      = empty-          pp_args IsInteresting  = char '!'-          pp_args NotInteresting = empty-          pp_tail                = pprShortTailCallInfo tail_info--pprShortTailCallInfo :: TailCallInfo -> SDoc-pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar)-pprShortTailCallInfo NoTailCallInfo        = empty--{--Note [TailCallInfo]-~~~~~~~~~~~~~~~~~~~-The occurrence analyser determines what can be made into a join point, but it-doesn't change the binder into a JoinId because then it would be inconsistent-with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to-change the IdDetails.--The AlwaysTailCalled marker actually means slightly more than simply that the-function is always tail-called. See Note [Invariants on join points].--This info is quite fragile and should not be relied upon unless the occurrence-analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of-the join-point-hood of a binder; a join id itself will not be marked-AlwaysTailCalled.--Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that-being tail-called would mean that the variable could only appear once per branch-(thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join-point can also be invoked from other join points, not just from case branches:--  let j1 x = ...-      j2 y = ... j1 z {- tail call -} ...-  in case w of-       A -> j1 v-       B -> j2 u-       C -> j2 q--Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get-ManyOccs and j2 will get `OneOcc { occ_one_br = True }`.--************************************************************************-*                                                                      *-                Default method specification-*                                                                      *-************************************************************************--The DefMethSpec enumeration just indicates what sort of default method-is used for a class. It is generated from source code, and present in-interface files; it is converted to Class.DefMethInfo before begin put in a-Class object.--}---- | Default Method Specification-data DefMethSpec ty-  = VanillaDM     -- Default method given with polymorphic code-  | GenericDM ty  -- Default method given with code of this type--instance Outputable (DefMethSpec ty) where-  ppr VanillaDM      = text "{- Has default method -}"-  ppr (GenericDM {}) = text "{- Has generic default method -}"--{--************************************************************************-*                                                                      *-\subsection{Success flag}-*                                                                      *-************************************************************************--}--data SuccessFlag = Succeeded | Failed--instance Outputable SuccessFlag where-    ppr Succeeded = text "Succeeded"-    ppr Failed    = text "Failed"--successIf :: Bool -> SuccessFlag-successIf True  = Succeeded-successIf False = Failed--succeeded, failed :: SuccessFlag -> Bool-succeeded Succeeded = True-succeeded Failed    = False--failed Succeeded = False-failed Failed    = True--{--************************************************************************-*                                                                      *-\subsection{Source Text}-*                                                                      *-************************************************************************-Keeping Source Text for source to source conversions--Note [Pragma source text]-~~~~~~~~~~~~~~~~~~~~~~~~~-The lexer does a case-insensitive match for pragmas, as well as-accepting both UK and US spelling variants.--So--  {-# SPECIALISE #-}-  {-# SPECIALIZE #-}-  {-# Specialize #-}--will all generate ITspec_prag token for the start of the pragma.--In order to be able to do source to source conversions, the original-source text for the token needs to be preserved, hence the-`SourceText` field.--So the lexer will then generate--  ITspec_prag "{ -# SPECIALISE"-  ITspec_prag "{ -# SPECIALIZE"-  ITspec_prag "{ -# Specialize"--for the cases above.- [without the space between '{' and '-', otherwise this comment won't parse]---Note [Literal source text]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The lexer/parser converts literals from their original source text-versions to an appropriate internal representation. This is a problem-for tools doing source to source conversions, so the original source-text is stored in literals where this can occur.--Motivating examples for HsLit--  HsChar          '\n'       == '\x20`-  HsCharPrim      '\x41`#    == `A`-  HsString        "\x20\x41" == " A"-  HsStringPrim    "\x20"#    == " "#-  HsInt           001        == 1-  HsIntPrim       002#       == 2#-  HsWordPrim      003##      == 3##-  HsInt64Prim     004##      == 4##-  HsWord64Prim    005##      == 5##-  HsInteger       006        == 6--For OverLitVal--  HsIntegral      003      == 0x003-  HsIsString      "\x41nd" == "And"--}-- -- Note [Literal source text],[Pragma source text]-data SourceText = SourceText String-                | NoSourceText -- ^ For when code is generated, e.g. TH,-                               -- deriving. The pretty printer will then make-                               -- its own representation of the item.-                deriving (Data, Show, Eq )--instance Outputable SourceText where-  ppr (SourceText s) = text "SourceText" <+> text s-  ppr NoSourceText   = text "NoSourceText"---- | Special combinator for showing string literals.-pprWithSourceText :: SourceText -> SDoc -> SDoc-pprWithSourceText NoSourceText     d = d-pprWithSourceText (SourceText src) _ = text src--{--************************************************************************-*                                                                      *-\subsection{Activation}-*                                                                      *-************************************************************************--When a rule or inlining is active--}---- | Phase Number-type PhaseNum = Int  -- Compilation phase-                     -- Phases decrease towards zero-                     -- Zero is the last phase--data CompilerPhase-  = Phase PhaseNum-  | InitialPhase    -- The first phase -- number = infinity!--instance Outputable CompilerPhase where-   ppr (Phase n)    = int n-   ppr InitialPhase = text "InitialPhase"--activeAfterInitial :: Activation--- Active in the first phase after the initial phase--- Currently we have just phases [2,1,0]-activeAfterInitial = ActiveAfter NoSourceText 2--activeDuringFinal :: Activation--- Active in the final simplification phase (which is repeated)-activeDuringFinal = ActiveAfter NoSourceText 0---- See note [Pragma source text]-data Activation = NeverActive-                | AlwaysActive-                | ActiveBefore SourceText PhaseNum-                  -- Active only *strictly before* this phase-                | ActiveAfter SourceText PhaseNum-                  -- Active in this phase and later-                deriving( Eq, Data )-                  -- Eq used in comparing rules in GHC.Hs.Decls---- | Rule Match Information-data RuleMatchInfo = ConLike                    -- See Note [CONLIKE pragma]-                   | FunLike-                   deriving( Eq, Data, Show )-        -- Show needed for Lexer.x--data InlinePragma            -- Note [InlinePragma]-  = InlinePragma-      { inl_src    :: SourceText -- Note [Pragma source text]-      , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act]--      , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n-                                     --            explicit (non-type, non-dictionary) args-                                     --   That is, inl_sat describes the number of *source-code*-                                     --   arguments the thing must be applied to.  We add on the-                                     --   number of implicit, dictionary arguments when making-                                     --   the Unfolding, and don't look at inl_sat further--      , inl_act    :: Activation     -- Says during which phases inlining is allowed-                                     -- See Note [inl_inline and inl_act]--      , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?-    } deriving( Eq, Data )---- | Inline Specification-data InlineSpec   -- What the user's INLINE pragma looked like-  = Inline       -- User wrote INLINE-  | Inlinable    -- User wrote INLINABLE-  | NoInline     -- User wrote NOINLINE-  | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE-                 -- e.g. in `defaultInlinePragma` or when created by CSE-  deriving( Eq, Data, Show )-        -- Show needed for Lexer.x--{- Note [InlinePragma]-~~~~~~~~~~~~~~~~~~~~~~-This data type mirrors what you can write in an INLINE or NOINLINE pragma in-the source program.--If you write nothing at all, you get defaultInlinePragma:-   inl_inline = NoUserInline-   inl_act    = AlwaysActive-   inl_rule   = FunLike--It's not possible to get that combination by *writing* something, so-if an Id has defaultInlinePragma it means the user didn't specify anything.--If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding.--If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.makeCorePair--Note [inl_inline and inl_act]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* inl_inline says what the user wrote: did she say INLINE, NOINLINE,-  INLINABLE, or nothing at all--* inl_act says in what phases the unfolding is active or inactive-  E.g  If you write INLINE[1]    then inl_act will be set to ActiveAfter 1-       If you write NOINLINE[1]  then inl_act will be set to ActiveBefore 1-       If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1-  So note that inl_act does not say what pragma you wrote: it just-  expresses its consequences--* inl_act just says when the unfolding is active; it doesn't say what-  to inline.  If you say INLINE f, then f's inl_act will be AlwaysActive,-  but in addition f will get a "stable unfolding" with UnfoldingGuidance-  that tells the inliner to be pretty eager about it.--Note [CONLIKE pragma]-~~~~~~~~~~~~~~~~~~~~~-The ConLike constructor of a RuleMatchInfo is aimed at the following.-Consider first-    {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-}-    g b bs = let x = b:bs in ..x...x...(r x)...-Now, the rule applies to the (r x) term, because GHC "looks through"-the definition of 'x' to see that it is (b:bs).--Now consider-    {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}-    g v = let x = f v in ..x...x...(r x)...-Normally the (r x) would *not* match the rule, because GHC would be-scared about duplicating the redex (f v), so it does not "look-through" the bindings.--However the CONLIKE modifier says to treat 'f' like a constructor in-this situation, and "look through" the unfolding for x.  So (r x)-fires, yielding (f (v+1)).--This is all controlled with a user-visible pragma:-     {-# NOINLINE CONLIKE [1] f #-}--The main effects of CONLIKE are:--    - The occurrence analyser (OccAnal) and simplifier (Simplify) treat-      CONLIKE thing like constructors, by ANF-ing them--    - New function GHC.Core.Utils.exprIsExpandable is like exprIsCheap, but-      additionally spots applications of CONLIKE functions--    - A CoreUnfolding has a field that caches exprIsExpandable--    - The rule matcher consults this field.  See-      Note [Expanding variables] in GHC.Core.Rules.--}--isConLike :: RuleMatchInfo -> Bool-isConLike ConLike = True-isConLike _       = False--isFunLike :: RuleMatchInfo -> Bool-isFunLike FunLike = True-isFunLike _       = False--noUserInlineSpec :: InlineSpec -> Bool-noUserInlineSpec NoUserInline = True-noUserInlineSpec _            = False--defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma-  :: InlinePragma-defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"-                                   , inl_act = AlwaysActive-                                   , inl_rule = FunLike-                                   , inl_inline = NoUserInline-                                   , inl_sat = Nothing }--alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }-neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }--inlinePragmaSpec :: InlinePragma -> InlineSpec-inlinePragmaSpec = inl_inline---- A DFun has an always-active inline activation so that--- exprIsConApp_maybe can "see" its unfolding--- (However, its actual Unfolding is a DFunUnfolding, which is---  never inlined other than via exprIsConApp_maybe.)-dfunInlinePragma   = defaultInlinePragma { inl_act  = AlwaysActive-                                         , inl_rule = ConLike }--isDefaultInlinePragma :: InlinePragma -> Bool-isDefaultInlinePragma (InlinePragma { inl_act = activation-                                    , inl_rule = match_info-                                    , inl_inline = inline })-  = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info--isInlinePragma :: InlinePragma -> Bool-isInlinePragma prag = case inl_inline prag of-                        Inline -> True-                        _      -> False--isInlinablePragma :: InlinePragma -> Bool-isInlinablePragma prag = case inl_inline prag of-                           Inlinable -> True-                           _         -> False--isAnyInlinePragma :: InlinePragma -> Bool--- INLINE or INLINABLE-isAnyInlinePragma prag = case inl_inline prag of-                        Inline    -> True-                        Inlinable -> True-                        _         -> False--inlinePragmaSat :: InlinePragma -> Maybe Arity-inlinePragmaSat = inl_sat--inlinePragmaActivation :: InlinePragma -> Activation-inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation--inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo-inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info--setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma-setInlinePragmaActivation prag activation = prag { inl_act = activation }--setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma-setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }--instance Outputable Activation where-   ppr AlwaysActive       = empty-   ppr NeverActive        = brackets (text "~")-   ppr (ActiveBefore _ n) = brackets (char '~' <> int n)-   ppr (ActiveAfter  _ n) = brackets (int n)--instance Outputable RuleMatchInfo where-   ppr ConLike = text "CONLIKE"-   ppr FunLike = text "FUNLIKE"--instance Outputable InlineSpec where-   ppr Inline       = text "INLINE"-   ppr NoInline     = text "NOINLINE"-   ppr Inlinable    = text "INLINABLE"-   ppr NoUserInline = text "NOUSERINLINE" -- what is better?--instance Outputable InlinePragma where-  ppr = pprInline--pprInline :: InlinePragma -> SDoc-pprInline = pprInline' True--pprInlineDebug :: InlinePragma -> SDoc-pprInlineDebug = pprInline' False--pprInline' :: Bool           -- True <=> do not display the inl_inline field-           -> InlinePragma-           -> SDoc-pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation-                                    , inl_rule = info, inl_sat = mb_arity })-    = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info-    where-      pp_inl x = if emptyInline then empty else ppr x--      pp_act Inline   AlwaysActive = empty-      pp_act NoInline NeverActive  = empty-      pp_act _        act          = ppr act--      pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar)-             | otherwise           = empty-      pp_info | isFunLike info = empty-              | otherwise      = ppr info--isActive :: CompilerPhase -> Activation -> Bool-isActive InitialPhase AlwaysActive      = True-isActive InitialPhase (ActiveBefore {}) = True-isActive InitialPhase _                 = False-isActive (Phase p)    act               = isActiveIn p act--isActiveIn :: PhaseNum -> Activation -> Bool-isActiveIn _ NeverActive        = False-isActiveIn _ AlwaysActive       = True-isActiveIn p (ActiveAfter _ n)  = p <= n-isActiveIn p (ActiveBefore _ n) = p >  n--competesWith :: Activation -> Activation -> Bool--- See Note [Activation competition]-competesWith NeverActive       _                = False-competesWith _                 NeverActive      = False-competesWith AlwaysActive      _                = True--competesWith (ActiveBefore {})  AlwaysActive      = True-competesWith (ActiveBefore {})  (ActiveBefore {}) = True-competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b--competesWith (ActiveAfter {})  AlwaysActive      = False-competesWith (ActiveAfter {})  (ActiveBefore {}) = False-competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b--{- Note [Competing activations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Sometimes a RULE and an inlining may compete, or two RULES.-See Note [Rules and inlining/other rules] in GHC.HsToCore.--We say that act1 "competes with" act2 iff-   act1 is active in the phase when act2 *becomes* active-NB: remember that phases count *down*: 2, 1, 0!--It's too conservative to ensure that the two are never simultaneously-active.  For example, a rule might be always active, and an inlining-might switch on in phase 2.  We could switch off the rule, but it does-no harm.--}--isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool-isNeverActive NeverActive = True-isNeverActive _           = False--isAlwaysActive AlwaysActive = True-isAlwaysActive _            = False--isEarlyActive AlwaysActive      = True-isEarlyActive (ActiveBefore {}) = True-isEarlyActive _                 = False---- | Integral Literal------ Used (instead of Integer) to represent negative zegative zero which is--- required for NegativeLiterals extension to correctly parse `-0::Double`--- as negative zero. See also #13211.-data IntegralLit-  = IL { il_text :: SourceText-       , il_neg :: Bool -- See Note [Negative zero]-       , il_value :: Integer-       }-  deriving (Data, Show)--mkIntegralLit :: Integral a => a -> IntegralLit-mkIntegralLit i = IL { il_text = SourceText (show i_integer)-                     , il_neg = i < 0-                     , il_value = i_integer }-  where-    i_integer :: Integer-    i_integer = toInteger i--negateIntegralLit :: IntegralLit -> IntegralLit-negateIntegralLit (IL text neg value)-  = case text of-      SourceText ('-':src) -> IL (SourceText src)       False    (negate value)-      SourceText      src  -> IL (SourceText ('-':src)) True     (negate value)-      NoSourceText         -> IL NoSourceText          (not neg) (negate value)---- | Fractional Literal------ Used (instead of Rational) to represent exactly the floating point literal that we--- encountered in the user's source program. This allows us to pretty-print exactly what--- the user wrote, which is important e.g. for floating point numbers that can't represented--- as Doubles (we used to via Double for pretty-printing). See also #2245.-data FractionalLit-  = FL { fl_text :: SourceText     -- How the value was written in the source-       , fl_neg :: Bool            -- See Note [Negative zero]-       , fl_value :: Rational      -- Numeric value of the literal-       }-  deriving (Data, Show)-  -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on--mkFractionalLit :: Real a => a -> FractionalLit-mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))-                           -- Converting to a Double here may technically lose-                           -- precision (see #15502). We could alternatively-                           -- convert to a Rational for the most accuracy, but-                           -- it would cause Floats and Doubles to be displayed-                           -- strangely, so we opt not to do this. (In contrast-                           -- to mkIntegralLit, where we always convert to an-                           -- Integer for the highest accuracy.)-                       , fl_neg = r < 0-                       , fl_value = toRational r }--negateFractionalLit :: FractionalLit -> FractionalLit-negateFractionalLit (FL text neg value)-  = case text of-      SourceText ('-':src) -> FL (SourceText src)     False value-      SourceText      src  -> FL (SourceText ('-':src)) True  value-      NoSourceText         -> FL NoSourceText (not neg) (negate value)--integralFractionalLit :: Bool -> Integer -> FractionalLit-integralFractionalLit neg i = FL { fl_text = SourceText (show i),-                                   fl_neg = neg,-                                   fl_value = fromInteger i }---- Comparison operations are needed when grouping literals--- for compiling pattern-matching (module GHC.HsToCore.Match.Literal)--instance Eq IntegralLit where-  (==) = (==) `on` il_value--instance Ord IntegralLit where-  compare = compare `on` il_value--instance Outputable IntegralLit where-  ppr (IL (SourceText src) _ _) = text src-  ppr (IL NoSourceText _ value) = text (show value)--instance Eq FractionalLit where-  (==) = (==) `on` fl_value--instance Ord FractionalLit where-  compare = compare `on` fl_value--instance Outputable FractionalLit where-  ppr f = pprWithSourceText (fl_text f) (rational (fl_value f))--{--************************************************************************-*                                                                      *-    IntWithInf-*                                                                      *-************************************************************************--Represents an integer or positive infinity---}---- | An integer or infinity-data IntWithInf = Int {-# UNPACK #-} !Int-                | Infinity-  deriving Eq---- | A representation of infinity-infinity :: IntWithInf-infinity = Infinity--instance Ord IntWithInf where-  compare Infinity Infinity = EQ-  compare (Int _)  Infinity = LT-  compare Infinity (Int _)  = GT-  compare (Int a)  (Int b)  = a `compare` b--instance Outputable IntWithInf where-  ppr Infinity = char '∞'-  ppr (Int n)  = int n--instance Num IntWithInf where-  (+) = plusWithInf-  (*) = mulWithInf--  abs Infinity = Infinity-  abs (Int n)  = Int (abs n)--  signum Infinity = Int 1-  signum (Int n)  = Int (signum n)--  fromInteger = Int . fromInteger--  (-) = panic "subtracting IntWithInfs"--intGtLimit :: Int -> IntWithInf -> Bool-intGtLimit _ Infinity = False-intGtLimit n (Int m)  = n > m---- | Add two 'IntWithInf's-plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf-plusWithInf Infinity _        = Infinity-plusWithInf _        Infinity = Infinity-plusWithInf (Int a)  (Int b)  = Int (a + b)---- | Multiply two 'IntWithInf's-mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf-mulWithInf Infinity _        = Infinity-mulWithInf _        Infinity = Infinity-mulWithInf (Int a)  (Int b)  = Int (a * b)---- | Turn a positive number into an 'IntWithInf', where 0 represents infinity-treatZeroAsInf :: Int -> IntWithInf-treatZeroAsInf 0 = Infinity-treatZeroAsInf n = Int n---- | Inject any integer into an 'IntWithInf'-mkIntWithInf :: Int -> IntWithInf-mkIntWithInf = Int--data SpliceExplicitFlag-          = ExplicitSplice | -- ^ <=> $(f x y)-            ImplicitSplice   -- ^ <=> f x y,  i.e. a naked top level expression-    deriving Data--{- *********************************************************************-*                                                                      *-                        Types vs Kinds-*                                                                      *-********************************************************************* -}---- | Flag to see whether we're type-checking terms or kind-checking types-data TypeOrKind = TypeLevel | KindLevel-  deriving Eq--instance Outputable TypeOrKind where-  ppr TypeLevel = text "TypeLevel"-  ppr KindLevel = text "KindLevel"--isTypeLevel :: TypeOrKind -> Bool-isTypeLevel TypeLevel = True-isTypeLevel KindLevel = False--isKindLevel :: TypeOrKind -> Bool-isKindLevel TypeLevel = False-isKindLevel KindLevel = True
− compiler/basicTypes/ConLike.hs 
@@ -1,196 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1998--\section[ConLike]{@ConLike@: Constructor-like things}--}--{-# LANGUAGE CPP #-}--module ConLike (-          ConLike(..)-        , conLikeArity-        , conLikeFieldLabels-        , conLikeInstOrigArgTys-        , conLikeExTyCoVars-        , conLikeName-        , conLikeStupidTheta-        , conLikeWrapId_maybe-        , conLikeImplBangs-        , conLikeFullSig-        , conLikeResTy-        , conLikeFieldType-        , conLikesWithFields-        , conLikeIsInfix-    ) where--#include "HsVersions.h"--import GhcPrelude--import DataCon-import PatSyn-import Outputable-import Unique-import Util-import Name-import BasicTypes-import TyCoRep (Type, ThetaType)-import Var-import Type (mkTyConApp)--import qualified Data.Data as Data--{--************************************************************************-*                                                                      *-\subsection{Constructor-like things}-*                                                                      *-************************************************************************--}---- | A constructor-like thing-data ConLike = RealDataCon DataCon-             | PatSynCon PatSyn--{--************************************************************************-*                                                                      *-\subsection{Instances}-*                                                                      *-************************************************************************--}--instance Eq ConLike where-    (==) = eqConLike--eqConLike :: ConLike -> ConLike -> Bool-eqConLike x y = getUnique x == getUnique y---- There used to be an Ord ConLike instance here that used Unique for ordering.--- It was intentionally removed to prevent determinism problems.--- See Note [Unique Determinism] in Unique.--instance Uniquable ConLike where-    getUnique (RealDataCon dc) = getUnique dc-    getUnique (PatSynCon ps)   = getUnique ps--instance NamedThing ConLike where-    getName (RealDataCon dc) = getName dc-    getName (PatSynCon ps)   = getName ps--instance Outputable ConLike where-    ppr (RealDataCon dc) = ppr dc-    ppr (PatSynCon ps) = ppr ps--instance OutputableBndr ConLike where-    pprInfixOcc (RealDataCon dc) = pprInfixOcc dc-    pprInfixOcc (PatSynCon ps) = pprInfixOcc ps-    pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc-    pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps--instance Data.Data ConLike where-    -- don't traverse?-    toConstr _   = abstractConstr "ConLike"-    gunfold _ _  = error "gunfold"-    dataTypeOf _ = mkNoRepType "ConLike"---- | Number of arguments-conLikeArity :: ConLike -> Arity-conLikeArity (RealDataCon data_con) = dataConSourceArity data_con-conLikeArity (PatSynCon pat_syn)    = patSynArity pat_syn---- | Names of fields used for selectors-conLikeFieldLabels :: ConLike -> [FieldLabel]-conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con-conLikeFieldLabels (PatSynCon pat_syn)    = patSynFieldLabels pat_syn---- | Returns just the instantiated /value/ argument types of a 'ConLike',--- (excluding dictionary args)-conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type]-conLikeInstOrigArgTys (RealDataCon data_con) tys =-    dataConInstOrigArgTys data_con tys-conLikeInstOrigArgTys (PatSynCon pat_syn) tys =-    patSynInstArgTys pat_syn tys---- | Existentially quantified type/coercion variables-conLikeExTyCoVars :: ConLike -> [TyCoVar]-conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1-conLikeExTyCoVars (PatSynCon psyn1)   = patSynExTyVars psyn1--conLikeName :: ConLike -> Name-conLikeName (RealDataCon data_con) = dataConName data_con-conLikeName (PatSynCon pat_syn)    = patSynName pat_syn---- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in:------ > data Eq a => T a = ...--- It is empty for `PatSynCon` as they do not allow such contexts.-conLikeStupidTheta :: ConLike -> ThetaType-conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con-conLikeStupidTheta (PatSynCon {})         = []---- | Returns the `Id` of the wrapper. This is also known as the builder in--- some contexts. The value is Nothing only in the case of unidirectional--- pattern synonyms.-conLikeWrapId_maybe :: ConLike -> Maybe Id-conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con-conLikeWrapId_maybe (PatSynCon pat_syn)    = fst <$> patSynBuilder pat_syn---- | Returns the strictness information for each constructor-conLikeImplBangs :: ConLike -> [HsImplBang]-conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con-conLikeImplBangs (PatSynCon pat_syn)    =-    replicate (patSynArity pat_syn) HsLazy---- | Returns the type of the whole pattern-conLikeResTy :: ConLike -> [Type] -> Type-conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys-conLikeResTy (PatSynCon ps)    tys = patSynInstResTy ps tys---- | The \"full signature\" of the 'ConLike' returns, in order:------ 1) The universally quantified type variables------ 2) The existentially quantified type/coercion variables------ 3) The equality specification------ 4) The provided theta (the constraints provided by a match)------ 5) The required theta (the constraints required for a match)------ 6) The original argument types (i.e. before---    any change of the representation of the type)------ 7) The original result type-conLikeFullSig :: ConLike-               -> ([TyVar], [TyCoVar], [EqSpec]-                   -- Why tyvars for universal but tycovars for existential?-                   -- See Note [Existential coercion variables] in DataCon-                  , ThetaType, ThetaType, [Type], Type)-conLikeFullSig (RealDataCon con) =-  let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con-  -- Required theta is empty as normal data cons require no additional-  -- constraints for a match-  in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty)-conLikeFullSig (PatSynCon pat_syn) =- let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn- -- eqSpec is empty- in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty)---- | Extract the type for any given labelled field of the 'ConLike'-conLikeFieldType :: ConLike -> FieldLabelString -> Type-conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label-conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label----- | The ConLikes that have *all* the given fields-conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]-conLikesWithFields con_likes lbls = filter has_flds con_likes-  where has_flds dc = all (has_fld dc) lbls-        has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)--conLikeIsInfix :: ConLike -> Bool-conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc-conLikeIsInfix (PatSynCon ps)   = patSynIsInfix  ps
− compiler/basicTypes/ConLike.hs-boot 
@@ -1,9 +0,0 @@-module ConLike where-import {-# SOURCE #-} DataCon (DataCon)-import {-# SOURCE #-} PatSyn (PatSyn)-import Name ( Name )--data ConLike = RealDataCon DataCon-             | PatSynCon PatSyn--conLikeName :: ConLike -> Name
− compiler/basicTypes/Cpr.hs 
@@ -1,163 +0,0 @@-{-# LANGUAGE GeneralisedNewtypeDeriving #-}--- | Types for the Constructed Product Result lattice. "CprAnal" and "WwLib"--- are its primary customers via 'idCprInfo'.-module Cpr (-    CprResult, topCpr, botCpr, conCpr, asConCpr,-    CprType (..), topCprType, botCprType, conCprType,-    lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy,-    CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig-  ) where--import GhcPrelude--import BasicTypes-import Outputable-import Binary------- * CprResult------- | The constructed product result lattice.------ @---                    NoCPR---                      |---                 ConCPR ConTag---                      |---                    BotCPR--- @-data CprResult = NoCPR          -- ^ Top of the lattice-               | ConCPR !ConTag -- ^ Returns a constructor from a data type-               | BotCPR         -- ^ Bottom of the lattice-               deriving( Eq, Show )--lubCpr :: CprResult -> CprResult -> CprResult-lubCpr (ConCPR t1) (ConCPR t2)-  | t1 == t2               = ConCPR t1-lubCpr BotCPR      cpr     = cpr-lubCpr cpr         BotCPR  = cpr-lubCpr _           _       = NoCPR--topCpr :: CprResult-topCpr = NoCPR--botCpr :: CprResult-botCpr = BotCPR--conCpr :: ConTag -> CprResult-conCpr = ConCPR--trimCpr :: CprResult -> CprResult-trimCpr ConCPR{} = NoCPR-trimCpr cpr      = cpr--asConCpr :: CprResult -> Maybe ConTag-asConCpr (ConCPR t)  = Just t-asConCpr NoCPR       = Nothing-asConCpr BotCPR      = Nothing------- * CprType------- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper.-data CprType-  = CprType-  { ct_arty :: !Arity     -- ^ Number of value arguments the denoted expression-                          --   eats before returning the 'ct_cpr'-  , ct_cpr  :: !CprResult -- ^ 'CprResult' eventually unleashed when applied to-                          --   'ct_arty' arguments-  }--instance Eq CprType where-  a == b =  ct_cpr a == ct_cpr b-         && (ct_arty a == ct_arty b || ct_cpr a == topCpr)--topCprType :: CprType-topCprType = CprType 0 topCpr--botCprType :: CprType-botCprType = CprType 0 botCpr -- TODO: Figure out if arity 0 does what we want... Yes it does: arity zero means we may unleash it under any number of incoming arguments--conCprType :: ConTag -> CprType-conCprType con_tag = CprType 0 (conCpr con_tag)--lubCprType :: CprType -> CprType -> CprType-lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2)-  -- The arity of bottom CPR types can be extended arbitrarily.-  | cpr1 == botCpr && n1 <= n2 = ty2-  | cpr2 == botCpr && n2 <= n1 = ty1-  -- There might be non-bottom CPR types with mismatching arities.-  -- Consider test DmdAnalGADTs. We want to return top in these cases.-  | n1 == n2                   = CprType n1 (lubCpr cpr1 cpr2)-  | otherwise                  = topCprType--applyCprTy :: CprType -> CprType-applyCprTy (CprType n res)-  | n > 0         = CprType (n-1) res-  | res == botCpr = botCprType-  | otherwise     = topCprType--abstractCprTy :: CprType -> CprType-abstractCprTy (CprType n res)-  | res == topCpr = topCprType-  | otherwise     = CprType (n+1) res--ensureCprTyArity :: Arity -> CprType -> CprType-ensureCprTyArity n ty@(CprType m _)-  | n == m    = ty-  | otherwise = topCprType--trimCprTy :: CprType -> CprType-trimCprTy (CprType arty res) = CprType arty (trimCpr res)---- | The arity of the wrapped 'CprType' is the arity at which it is safe--- to unleash. See Note [Understanding DmdType and StrictSig] in Demand-newtype CprSig = CprSig { getCprSig :: CprType }-  deriving (Eq, Binary)---- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig'--- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in--- Demand-mkCprSigForArity :: Arity -> CprType -> CprSig-mkCprSigForArity arty ty = CprSig (ensureCprTyArity arty ty)--topCprSig :: CprSig-topCprSig = CprSig topCprType--mkCprSig :: Arity -> CprResult -> CprSig-mkCprSig arty cpr = CprSig (CprType arty cpr)--seqCprSig :: CprSig -> ()-seqCprSig sig = sig `seq` ()--instance Outputable CprResult where-  ppr NoCPR        = empty-  ppr (ConCPR n)   = char 'm' <> int n-  ppr BotCPR       = char 'b'--instance Outputable CprType where-  ppr (CprType arty res) = ppr arty <> ppr res---- | Only print the CPR result-instance Outputable CprSig where-  ppr (CprSig ty) = ppr (ct_cpr ty)--instance Binary CprResult where-  put_ bh (ConCPR n)   = do { putByte bh 0; put_ bh n }-  put_ bh NoCPR        = putByte bh 1-  put_ bh BotCPR       = putByte bh 2--  get  bh = do-          h <- getByte bh-          case h of-            0 -> do { n <- get bh; return (ConCPR n) }-            1 -> return NoCPR-            _ -> return BotCPR--instance Binary CprType where-  put_ bh (CprType arty cpr) = do-    put_ bh arty-    put_ bh cpr-  get  bh = CprType <$> get bh <*> get bh
− compiler/basicTypes/DataCon.hs 
@@ -1,1468 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1998--\section[DataCon]{@DataCon@: Data Constructors}--}--{-# LANGUAGE CPP, DeriveDataTypeable #-}--module DataCon (-        -- * Main data types-        DataCon, DataConRep(..),-        SrcStrictness(..), SrcUnpackedness(..),-        HsSrcBang(..), HsImplBang(..),-        StrictnessMark(..),-        ConTag,--        -- ** Equality specs-        EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType,-        eqSpecPair, eqSpecPreds,-        substEqSpec, filterEqSpec,--        -- ** Field labels-        FieldLbl(..), FieldLabel, FieldLabelString,--        -- ** Type construction-        mkDataCon, fIRST_TAG,--        -- ** Type deconstruction-        dataConRepType, dataConInstSig, dataConFullSig,-        dataConName, dataConIdentity, dataConTag, dataConTagZ,-        dataConTyCon, dataConOrigTyCon,-        dataConUserType,-        dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars,-        dataConUserTyVars, dataConUserTyVarBinders,-        dataConEqSpec, dataConTheta,-        dataConStupidTheta,-        dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,-        dataConInstOrigArgTys, dataConRepArgTys,-        dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,-        dataConSrcBangs,-        dataConSourceArity, dataConRepArity,-        dataConIsInfix,-        dataConWorkId, dataConWrapId, dataConWrapId_maybe,-        dataConImplicitTyThings,-        dataConRepStrictness, dataConImplBangs, dataConBoxer,--        splitDataProductType_maybe,--        -- ** Predicates on DataCons-        isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,-        isUnboxedSumCon,-        isVanillaDataCon, classDataCon, dataConCannotMatch,-        dataConUserTyVarsArePermuted,-        isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,-        specialPromotedDc,--        -- ** Promotion related functions-        promoteDataCon-    ) where--#include "HsVersions.h"--import GhcPrelude--import {-# SOURCE #-} MkId( DataConBoxer )-import Type-import Coercion-import Unify-import TyCon-import FieldLabel-import Class-import Name-import PrelNames-import Predicate-import Var-import Outputable-import Util-import BasicTypes-import FastString-import Module-import Binary-import UniqSet-import Unique( mkAlphaTyVarUnique )--import Data.ByteString (ByteString)-import qualified Data.ByteString.Builder as BSB-import qualified Data.ByteString.Lazy    as LBS-import qualified Data.Data as Data-import Data.Char-import Data.List( find )--{--Data constructor representation-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the following Haskell data type declaration--        data T = T !Int ![Int]--Using the strictness annotations, GHC will represent this as--        data T = T Int# [Int]--That is, the Int has been unboxed.  Furthermore, the Haskell source construction--        T e1 e2--is translated to--        case e1 of { I# x ->-        case e2 of { r ->-        T x r }}--That is, the first argument is unboxed, and the second is evaluated.  Finally,-pattern matching is translated too:--        case e of { T a b -> ... }--becomes--        case e of { T a' b -> let a = I# a' in ... }--To keep ourselves sane, we name the different versions of the data constructor-differently, as follows.---Note [Data Constructor Naming]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Each data constructor C has two, and possibly up to four, Names associated with it:--                   OccName   Name space   Name of   Notes- ---------------------------------------------------------------------------- The "data con itself"   C     DataName   DataCon   In dom( GlobalRdrEnv )- The "worker data con"   C     VarName    Id        The worker- The "wrapper data con"  $WC   VarName    Id        The wrapper- The "newtype coercion"  :CoT  TcClsName  TyCon--EVERY data constructor (incl for newtypes) has the former two (the-data con itself, and its worker.  But only some data constructors have a-wrapper (see Note [The need for a wrapper]).--Each of these three has a distinct Unique.  The "data con itself" name-appears in the output of the renamer, and names the Haskell-source-data constructor.  The type checker translates it into either the wrapper Id-(if it exists) or worker Id (otherwise).--The data con has one or two Ids associated with it:--The "worker Id", is the actual data constructor.-* Every data constructor (newtype or data type) has a worker--* The worker is very like a primop, in that it has no binding.--* For a *data* type, the worker *is* the data constructor;-  it has no unfolding--* For a *newtype*, the worker has a compulsory unfolding which-  does a cast, e.g.-        newtype T = MkT Int-        The worker for MkT has unfolding-                \\(x:Int). x `cast` sym CoT-  Here CoT is the type constructor, witnessing the FC axiom-        axiom CoT : T = Int--The "wrapper Id", \$WC, goes as follows--* Its type is exactly what it looks like in the source program.--* It is an ordinary function, and it gets a top-level binding-  like any other function.--* The wrapper Id isn't generated for a data type if there is-  nothing for the wrapper to do.  That is, if its defn would be-        \$wC = C--Note [Data constructor workers and wrappers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* Algebraic data types-  - Always have a worker, with no unfolding-  - May or may not have a wrapper; see Note [The need for a wrapper]--* Newtypes-  - Always have a worker, which has a compulsory unfolding (just a cast)-  - May or may not have a wrapper; see Note [The need for a wrapper]--* INVARIANT: the dictionary constructor for a class-             never has a wrapper.--* Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments--* The wrapper (if it exists) takes dcOrigArgTys as its arguments-  The worker takes dataConRepArgTys as its arguments-  If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys--* The 'NoDataConRep' case of DataConRep is important. Not only is it-  efficient, but it also ensures that the wrapper is replaced by the-  worker (because it *is* the worker) even when there are no-  args. E.g. in-               f (:) x-  the (:) *is* the worker.  This is really important in rule matching,-  (We could match on the wrappers, but that makes it less likely that-  rules will match when we bring bits of unfoldings together.)--Note [The need for a wrapper]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Why might the wrapper have anything to do?  The full story is-in wrapper_reqd in MkId.mkDataConRep.--* Unboxing strict fields (with -funbox-strict-fields)-        data T = MkT !(Int,Int)-        \$wMkT :: (Int,Int) -> T-        \$wMkT (x,y) = MkT x y-  Notice that the worker has two fields where the wapper has-  just one.  That is, the worker has type-                MkT :: Int -> Int -> T--* Equality constraints for GADTs-        data T a where { MkT :: a -> T [a] }--  The worker gets a type with explicit equality-  constraints, thus:-        MkT :: forall a b. (a=[b]) => b -> T a--  The wrapper has the programmer-specified type:-        \$wMkT :: a -> T [a]-        \$wMkT a x = MkT [a] a [a] x-  The third argument is a coercion-        [a] :: [a]~[a]--* Data family instances may do a cast on the result--* Type variables may be permuted; see MkId-  Note [Data con wrappers and GADT syntax]---Note [The stupid context]-~~~~~~~~~~~~~~~~~~~~~~~~~-Data types can have a context:--        data (Eq a, Ord b) => T a b = T1 a b | T2 a--and that makes the constructors have a context too-(notice that T2's context is "thinned"):--        T1 :: (Eq a, Ord b) => a -> b -> T a b-        T2 :: (Eq a) => a -> T a b--Furthermore, this context pops up when pattern matching-(though GHC hasn't implemented this, but it is in H98, and-I've fixed GHC so that it now does):--        f (T2 x) = x-gets inferred type-        f :: Eq a => T a b -> a--I say the context is "stupid" because the dictionaries passed-are immediately discarded -- they do nothing and have no benefit.-It's a flaw in the language.--        Up to now [March 2002] I have put this stupid context into the-        type of the "wrapper" constructors functions, T1 and T2, but-        that turned out to be jolly inconvenient for generics, and-        record update, and other functions that build values of type T-        (because they don't have suitable dictionaries available).--        So now I've taken the stupid context out.  I simply deal with-        it separately in the type checker on occurrences of a-        constructor, either in an expression or in a pattern.--        [May 2003: actually I think this decision could easily be-        reversed now, and probably should be.  Generics could be-        disabled for types with a stupid context; record updates now-        (H98) needs the context too; etc.  It's an unforced change, so-        I'm leaving it for now --- but it does seem odd that the-        wrapper doesn't include the stupid context.]--[July 04] With the advent of generalised data types, it's less obvious-what the "stupid context" is.  Consider-        C :: forall a. Ord a => a -> a -> T (Foo a)-Does the C constructor in Core contain the Ord dictionary?  Yes, it must:--        f :: T b -> Ordering-        f = /\b. \x:T b.-            case x of-                C a (d:Ord a) (p:a) (q:a) -> compare d p q--Note that (Foo a) might not be an instance of Ord.--************************************************************************-*                                                                      *-\subsection{Data constructors}-*                                                                      *-************************************************************************--}---- | A data constructor------ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',---             'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma'---- For details on above see note [Api annotations] in ApiAnnotation-data DataCon-  = MkData {-        dcName    :: Name,      -- This is the name of the *source data con*-                                -- (see "Note [Data Constructor Naming]" above)-        dcUnique :: Unique,     -- Cached from Name-        dcTag    :: ConTag,     -- ^ Tag, used for ordering 'DataCon's--        -- Running example:-        ---        --      *** As declared by the user-        --  data T a b c where-        --    MkT :: forall c y x b. (x~y,Ord x) => x -> y -> T (x,y) b c--        --      *** As represented internally-        --  data T a b c where-        --    MkT :: forall a b c. forall x y. (a~(x,y),x~y,Ord x)-        --        => x -> y -> T a b c-        ---        -- The next six fields express the type of the constructor, in pieces-        -- e.g.-        ---        --      dcUnivTyVars       = [a,b,c]-        --      dcExTyCoVars       = [x,y]-        --      dcUserTyVarBinders = [c,y,x,b]-        --      dcEqSpec           = [a~(x,y)]-        --      dcOtherTheta       = [x~y, Ord x]-        --      dcOrigArgTys       = [x,y]-        --      dcRepTyCon         = T--        -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE-        -- TYVARS FOR THE PARENT TyCon. (This is a change (Oct05): previously,-        -- vanilla datacons guaranteed to have the same type variables as their-        -- parent TyCon, but that seems ugly.) They can be different in the case-        -- where a GADT constructor uses different names for the universal-        -- tyvars than does the tycon. For example:-        ---        --   data H a where-        --     MkH :: b -> H b-        ---        -- Here, the tyConTyVars of H will be [a], but the dcUnivTyVars of MkH-        -- will be [b].--        dcVanilla :: Bool,      -- True <=> This is a vanilla Haskell 98 data constructor-                                --          Its type is of form-                                --              forall a1..an . t1 -> ... tm -> T a1..an-                                --          No existentials, no coercions, nothing.-                                -- That is: dcExTyCoVars = dcEqSpec = dcOtherTheta = []-                -- NB 1: newtypes always have a vanilla data con-                -- NB 2: a vanilla constructor can still be declared in GADT-style-                --       syntax, provided its type looks like the above.-                --       The declaration format is held in the TyCon (algTcGadtSyntax)--        -- Universally-quantified type vars [a,b,c]-        -- INVARIANT: length matches arity of the dcRepTyCon-        -- INVARIANT: result type of data con worker is exactly (T a b c)-        -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with-        --            the tyConTyVars of the parent TyCon-        dcUnivTyVars     :: [TyVar],--        -- Existentially-quantified type and coercion vars [x,y]-        -- For an example involving coercion variables,-        -- Why tycovars? See Note [Existential coercion variables]-        dcExTyCoVars     :: [TyCoVar],--        -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames-        -- Reason: less confusing, and easier to generate Iface syntax--        -- The type/coercion vars in the order the user wrote them [c,y,x,b]-        -- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the set-        --            of tyvars (*not* covars) of dcExTyCoVars unioned with the-        --            set of dcUnivTyVars whose tyvars do not appear in dcEqSpec-        -- See Note [DataCon user type variable binders]-        dcUserTyVarBinders :: [TyVarBinder],--        dcEqSpec :: [EqSpec],   -- Equalities derived from the result type,-                                -- _as written by the programmer_.-                                -- Only non-dependent GADT equalities (dependent-                                -- GADT equalities are in the covars of-                                -- dcExTyCoVars).--                -- This field allows us to move conveniently between the two ways-                -- of representing a GADT constructor's type:-                --      MkT :: forall a b. (a ~ [b]) => b -> T a-                --      MkT :: forall b. b -> T [b]-                -- Each equality is of the form (a ~ ty), where 'a' is one of-                -- the universally quantified type variables--                -- The next two fields give the type context of the data constructor-                --      (aside from the GADT constraints,-                --       which are given by the dcExpSpec)-                -- In GADT form, this is *exactly* what the programmer writes, even if-                -- the context constrains only universally quantified variables-                --      MkT :: forall a b. (a ~ b, Ord b) => a -> T a b-        dcOtherTheta :: ThetaType,  -- The other constraints in the data con's type-                                    -- other than those in the dcEqSpec--        dcStupidTheta :: ThetaType,     -- The context of the data type declaration-                                        --      data Eq a => T a = ...-                                        -- or, rather, a "thinned" version thereof-                -- "Thinned", because the Report says-                -- to eliminate any constraints that don't mention-                -- tyvars free in the arg types for this constructor-                ---                -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars-                -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon-                ---                -- "Stupid", because the dictionaries aren't used for anything.-                -- Indeed, [as of March 02] they are no longer in the type of-                -- the wrapper Id, because that makes it harder to use the wrap-id-                -- to rebuild values after record selection or in generics.--        dcOrigArgTys :: [Type],         -- Original argument types-                                        -- (before unboxing and flattening of strict fields)-        dcOrigResTy :: Type,            -- Original result type, as seen by the user-                -- NB: for a data instance, the original user result type may-                -- differ from the DataCon's representation TyCon.  Example-                --      data instance T [a] where MkT :: a -> T [a]-                -- The OrigResTy is T [a], but the dcRepTyCon might be :T123--        -- Now the strictness annotations and field labels of the constructor-        dcSrcBangs :: [HsSrcBang],-                -- See Note [Bangs on data constructor arguments]-                ---                -- The [HsSrcBang] as written by the programmer.-                ---                -- Matches 1-1 with dcOrigArgTys-                -- Hence length = dataConSourceArity dataCon--        dcFields  :: [FieldLabel],-                -- Field labels for this constructor, in the-                -- same order as the dcOrigArgTys;-                -- length = 0 (if not a record) or dataConSourceArity.--        -- The curried worker function that corresponds to the constructor:-        -- It doesn't have an unfolding; the code generator saturates these Ids-        -- and allocates a real constructor when it finds one.-        dcWorkId :: Id,--        -- Constructor representation-        dcRep      :: DataConRep,--        -- Cached; see Note [DataCon arities]-        -- INVARIANT: dcRepArity    == length dataConRepArgTys + count isCoVar (dcExTyCoVars)-        -- INVARIANT: dcSourceArity == length dcOrigArgTys-        dcRepArity    :: Arity,-        dcSourceArity :: Arity,--        -- Result type of constructor is T t1..tn-        dcRepTyCon  :: TyCon,           -- Result tycon, T--        dcRepType   :: Type,    -- Type of the constructor-                                --      forall a x y. (a~(x,y), x~y, Ord x) =>-                                --        x -> y -> T a-                                -- (this is *not* of the constructor wrapper Id:-                                --  see Note [Data con representation] below)-        -- Notice that the existential type parameters come *second*.-        -- Reason: in a case expression we may find:-        --      case (e :: T t) of-        --        MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ...-        -- It's convenient to apply the rep-type of MkT to 't', to get-        --      forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t-        -- and use that to check the pattern.  Mind you, this is really only-        -- used in GHC.Core.Lint.---        dcInfix :: Bool,        -- True <=> declared infix-                                -- Used for Template Haskell and 'deriving' only-                                -- The actual fixity is stored elsewhere--        dcPromoted :: TyCon    -- The promoted TyCon-                               -- See Note [Promoted data constructors] in TyCon-  }---{- Note [TyVarBinders in DataCons]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For the TyVarBinders in a DataCon and PatSyn:-- * Each argument flag is Inferred or Specified.-   None are Required. (A DataCon is a term-level function; see-   Note [No Required TyCoBinder in terms] in TyCoRep.)--Why do we need the TyVarBinders, rather than just the TyVars?  So that-we can construct the right type for the DataCon with its foralls-attributed the correct visibility.  That in turn governs whether you-can use visible type application at a call of the data constructor.--See also [DataCon user type variable binders] for an extended discussion on the-order in which TyVarBinders appear in a DataCon.--Note [Existential coercion variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--For now (Aug 2018) we can't write coercion quantifications in source Haskell, but-we can in Core. Consider having:--  data T :: forall k. k -> k -> Constraint where-    MkT :: forall k (a::k) (b::k). forall k' (c::k') (co::k'~k). (b~(c|>co))-        => T k a b--  dcUnivTyVars       = [k,a,b]-  dcExTyCoVars       = [k',c,co]-  dcUserTyVarBinders = [k,a,k',c]-  dcEqSpec           = [b~(c|>co)]-  dcOtherTheta       = []-  dcOrigArgTys       = []-  dcRepTyCon         = T--  Function call 'dataConKindEqSpec' returns [k'~k]--Note [DataCon arities]-~~~~~~~~~~~~~~~~~~~~~~-dcSourceArity does not take constraints into account,-but dcRepArity does.  For example:-   MkT :: Ord a => a -> T a-    dcSourceArity = 1-    dcRepArity    = 2--Note [DataCon user type variable binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In System FC, data constructor type signatures always quantify over all of-their universal type variables, followed by their existential type variables.-Normally, this isn't a problem, as most datatypes naturally quantify their type-variables in this order anyway. For example:--  data T a b = forall c. MkT b c--Here, we have `MkT :: forall {k} (a :: k) (b :: *) (c :: *). b -> c -> T a b`,-where k, a, and b are universal and c is existential. (The inferred variable k-isn't available for TypeApplications, hence why it's in braces.) This is a-perfectly reasonable order to use, as the syntax of H98-style datatypes-(+ ExistentialQuantification) suggests it.--Things become more complicated when GADT syntax enters the picture. Consider-this example:--  data X a where-    MkX :: forall b a. b -> Proxy a -> X a--If we adopt the earlier approach of quantifying all the universal variables-followed by all the existential ones, GHC would come up with this type-signature for MkX:--  MkX :: forall {k} (a :: k) (b :: *). b -> Proxy a -> X a--But this is not what we want at all! After all, if a user were to use-TypeApplications on MkX, they would expect to instantiate `b` before `a`,-as that's the order in which they were written in the `forall`. (See #11721.)-Instead, we'd like GHC to come up with this type signature:--  MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a--In fact, even if we left off the explicit forall:--  data X a where-    MkX :: b -> Proxy a -> X a--Then a user should still expect `b` to be quantified before `a`, since-according to the rules of TypeApplications, in the absence of `forall` GHC-performs a stable topological sort on the type variables in the user-written-type signature, which would place `b` before `a`.--But as noted above, enacting this behavior is not entirely trivial, as System-FC demands the variables go in universal-then-existential order under the hood.-Our solution is thus to equip DataCon with two different sets of type-variables:--* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential-  type/coercion variables, respectively. Their order is irrelevant for the-  purposes of TypeApplications, and as a consequence, they do not come equipped-  with visibilities (that is, they are TyVars/TyCoVars instead of-  TyCoVarBinders).-* dcUserTyVarBinders, for the type variables binders in the order in which they-  originally arose in the user-written type signature. Their order *does* matter-  for TypeApplications, so they are full TyVarBinders, complete with-  visibilities.--This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders-consists precisely of:--* The set of tyvars in dcUnivTyVars whose type variables do not appear in-  dcEqSpec, unioned with:-* The set of tyvars (*not* covars) in dcExTyCoVars-  No covars here because because they're not user-written--The word "set" is used above because the order in which the tyvars appear in-dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or-dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of-(tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the-ordering, they in fact share the same type variables (with the same Uniques). We-sometimes refer to this as "the dcUserTyVarBinders invariant".--dcUserTyVarBinders, as the name suggests, is the one that users will see most of-the time. It's used when computing the type signature of a data constructor (see-dataConUserType), and as a result, it's what matters from a TypeApplications-perspective.--}---- | Data Constructor Representation--- See Note [Data constructor workers and wrappers]-data DataConRep-  = -- NoDataConRep means that the data con has no wrapper-    NoDataConRep--    -- DCR means that the data con has a wrapper-  | DCR { dcr_wrap_id :: Id   -- Takes src args, unboxes/flattens,-                              -- and constructs the representation--        , dcr_boxer   :: DataConBoxer--        , dcr_arg_tys :: [Type]  -- Final, representation argument types,-                                 -- after unboxing and flattening,-                                 -- and *including* all evidence args--        , dcr_stricts :: [StrictnessMark]  -- 1-1 with dcr_arg_tys-                -- See also Note [Data-con worker strictness] in MkId.hs--        , dcr_bangs :: [HsImplBang]  -- The actual decisions made (including failures)-                                     -- about the original arguments; 1-1 with orig_arg_tys-                                     -- See Note [Bangs on data constructor arguments]--    }------------------------------- | Haskell Source Bang------ Bangs on data constructor arguments as the user wrote them in the--- source code.------ @(HsSrcBang _ SrcUnpack SrcLazy)@ and--- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we--- emit a warning (in checkValidDataCon) and treat it like--- @(HsSrcBang _ NoSrcUnpack SrcLazy)@-data HsSrcBang =-  HsSrcBang SourceText -- Note [Pragma source text] in BasicTypes-            SrcUnpackedness-            SrcStrictness-  deriving Data.Data---- | Haskell Implementation Bang------ Bangs of data constructor arguments as generated by the compiler--- after consulting HsSrcBang, flags, etc.-data HsImplBang-  = HsLazy    -- ^ Lazy field, or one with an unlifted type-  | HsStrict  -- ^ Strict but not unpacked field-  | HsUnpack (Maybe Coercion)-    -- ^ Strict and unpacked field-    -- co :: arg-ty ~ product-ty HsBang-  deriving Data.Data---- | Source Strictness------ What strictness annotation the user wrote-data SrcStrictness = SrcLazy -- ^ Lazy, ie '~'-                   | SrcStrict -- ^ Strict, ie '!'-                   | NoSrcStrict -- ^ no strictness annotation-     deriving (Eq, Data.Data)---- | Source Unpackedness------ What unpackedness the user requested-data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified-                     | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified-                     | NoSrcUnpack -- ^ no unpack pragma-     deriving (Eq, Data.Data)-------------------------------- StrictnessMark is internal only, used to indicate strictness--- of the DataCon *worker* fields-data StrictnessMark = MarkedStrict | NotMarkedStrict---- | An 'EqSpec' is a tyvar/type pair representing an equality made in--- rejigging a GADT constructor-data EqSpec = EqSpec TyVar-                     Type---- | Make a non-dependent 'EqSpec'-mkEqSpec :: TyVar -> Type -> EqSpec-mkEqSpec tv ty = EqSpec tv ty--eqSpecTyVar :: EqSpec -> TyVar-eqSpecTyVar (EqSpec tv _) = tv--eqSpecType :: EqSpec -> Type-eqSpecType (EqSpec _ ty) = ty--eqSpecPair :: EqSpec -> (TyVar, Type)-eqSpecPair (EqSpec tv ty) = (tv, ty)--eqSpecPreds :: [EqSpec] -> ThetaType-eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty-                   | EqSpec tv ty <- spec ]---- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec--- is mapped in the substitution, it is mapped to a type variable, not--- a full type.-substEqSpec :: TCvSubst -> EqSpec -> EqSpec-substEqSpec subst (EqSpec tv ty)-  = EqSpec tv' (substTy subst ty)-  where-    tv' = getTyVar "substEqSpec" (substTyVar subst tv)---- | Filter out any 'TyVar's mentioned in an 'EqSpec'.-filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar]-filterEqSpec eq_spec-  = filter not_in_eq_spec-  where-    not_in_eq_spec var = all (not . (== var) . eqSpecTyVar) eq_spec--instance Outputable EqSpec where-  ppr (EqSpec tv ty) = ppr (tv, ty)--{- Note [Bangs on data constructor arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  data T = MkT !Int {-# UNPACK #-} !Int Bool--When compiling the module, GHC will decide how to represent-MkT, depending on the optimisation level, and settings of-flags like -funbox-small-strict-fields.--Terminology:-  * HsSrcBang:  What the user wrote-                Constructors: HsSrcBang--  * HsImplBang: What GHC decided-                Constructors: HsLazy, HsStrict, HsUnpack--* If T was defined in this module, MkT's dcSrcBangs field-  records the [HsSrcBang] of what the user wrote; in the example-    [ HsSrcBang _ NoSrcUnpack SrcStrict-    , HsSrcBang _ SrcUnpack SrcStrict-    , HsSrcBang _ NoSrcUnpack NoSrcStrictness]--* However, if T was defined in an imported module, the importing module-  must follow the decisions made in the original module, regardless of-  the flag settings in the importing module.-  Also see Note [Bangs on imported data constructors] in MkId--* The dcr_bangs field of the dcRep field records the [HsImplBang]-  If T was defined in this module, Without -O the dcr_bangs might be-    [HsStrict, HsStrict, HsLazy]-  With -O it might be-    [HsStrict, HsUnpack _, HsLazy]-  With -funbox-small-strict-fields it might be-    [HsUnpack, HsUnpack _, HsLazy]-  With -XStrictData it might be-    [HsStrict, HsUnpack _, HsStrict]--Note [Data con representation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The dcRepType field contains the type of the representation of a constructor-This may differ from the type of the constructor *Id* (built-by MkId.mkDataConId) for two reasons:-        a) the constructor Id may be overloaded, but the dictionary isn't stored-           e.g.    data Eq a => T a = MkT a a--        b) the constructor may store an unboxed version of a strict field.--Here's an example illustrating both:-        data Ord a => T a = MkT Int! a-Here-        T :: Ord a => Int -> a -> T a-but the rep type is-        Trep :: Int# -> a -> T a-Actually, the unboxed part isn't implemented yet!----************************************************************************-*                                                                      *-\subsection{Instances}-*                                                                      *-************************************************************************--}--instance Eq DataCon where-    a == b = getUnique a == getUnique b-    a /= b = getUnique a /= getUnique b--instance Uniquable DataCon where-    getUnique = dcUnique--instance NamedThing DataCon where-    getName = dcName--instance Outputable DataCon where-    ppr con = ppr (dataConName con)--instance OutputableBndr DataCon where-    pprInfixOcc con = pprInfixName (dataConName con)-    pprPrefixOcc con = pprPrefixName (dataConName con)--instance Data.Data DataCon where-    -- don't traverse?-    toConstr _   = abstractConstr "DataCon"-    gunfold _ _  = error "gunfold"-    dataTypeOf _ = mkNoRepType "DataCon"--instance Outputable HsSrcBang where-    ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark--instance Outputable HsImplBang where-    ppr HsLazy                  = text "Lazy"-    ppr (HsUnpack Nothing)      = text "Unpacked"-    ppr (HsUnpack (Just co))    = text "Unpacked" <> parens (ppr co)-    ppr HsStrict                = text "StrictNotUnpacked"--instance Outputable SrcStrictness where-    ppr SrcLazy     = char '~'-    ppr SrcStrict   = char '!'-    ppr NoSrcStrict = empty--instance Outputable SrcUnpackedness where-    ppr SrcUnpack   = text "{-# UNPACK #-}"-    ppr SrcNoUnpack = text "{-# NOUNPACK #-}"-    ppr NoSrcUnpack = empty--instance Outputable StrictnessMark where-    ppr MarkedStrict    = text "!"-    ppr NotMarkedStrict = empty--instance Binary SrcStrictness where-    put_ bh SrcLazy     = putByte bh 0-    put_ bh SrcStrict   = putByte bh 1-    put_ bh NoSrcStrict = putByte bh 2--    get bh =-      do h <- getByte bh-         case h of-           0 -> return SrcLazy-           1 -> return SrcStrict-           _ -> return NoSrcStrict--instance Binary SrcUnpackedness where-    put_ bh SrcNoUnpack = putByte bh 0-    put_ bh SrcUnpack   = putByte bh 1-    put_ bh NoSrcUnpack = putByte bh 2--    get bh =-      do h <- getByte bh-         case h of-           0 -> return SrcNoUnpack-           1 -> return SrcUnpack-           _ -> return NoSrcUnpack---- | Compare strictness annotations-eqHsBang :: HsImplBang -> HsImplBang -> Bool-eqHsBang HsLazy               HsLazy              = True-eqHsBang HsStrict             HsStrict            = True-eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)  = True-eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2))-  = eqType (coercionType c1) (coercionType c2)-eqHsBang _ _                                       = False--isBanged :: HsImplBang -> Bool-isBanged (HsUnpack {}) = True-isBanged (HsStrict {}) = True-isBanged HsLazy        = False--isSrcStrict :: SrcStrictness -> Bool-isSrcStrict SrcStrict = True-isSrcStrict _ = False--isSrcUnpacked :: SrcUnpackedness -> Bool-isSrcUnpacked SrcUnpack = True-isSrcUnpacked _ = False--isMarkedStrict :: StrictnessMark -> Bool-isMarkedStrict NotMarkedStrict = False-isMarkedStrict _               = True   -- All others are strict--{- *********************************************************************-*                                                                      *-\subsection{Construction}-*                                                                      *-********************************************************************* -}---- | Build a new data constructor-mkDataCon :: Name-          -> Bool           -- ^ Is the constructor declared infix?-          -> TyConRepName   -- ^  TyConRepName for the promoted TyCon-          -> [HsSrcBang]    -- ^ Strictness/unpack annotations, from user-          -> [FieldLabel]   -- ^ Field labels for the constructor,-                            -- if it is a record, otherwise empty-          -> [TyVar]        -- ^ Universals.-          -> [TyCoVar]      -- ^ Existentials.-          -> [TyVarBinder]  -- ^ User-written 'TyVarBinder's.-                            --   These must be Inferred/Specified.-                            --   See @Note [TyVarBinders in DataCons]@-          -> [EqSpec]       -- ^ GADT equalities-          -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper-          -> [KnotTied Type]    -- ^ Original argument types-          -> KnotTied Type      -- ^ Original result type-          -> RuntimeRepInfo     -- ^ See comments on 'TyCon.RuntimeRepInfo'-          -> KnotTied TyCon     -- ^ Representation type constructor-          -> ConTag             -- ^ Constructor tag-          -> ThetaType          -- ^ The "stupid theta", context of the data-                                -- declaration e.g. @data Eq a => T a ...@-          -> Id                 -- ^ Worker Id-          -> DataConRep         -- ^ Representation-          -> DataCon-  -- Can get the tag from the TyCon--mkDataCon name declared_infix prom_info-          arg_stricts   -- Must match orig_arg_tys 1-1-          fields-          univ_tvs ex_tvs user_tvbs-          eq_spec theta-          orig_arg_tys orig_res_ty rep_info rep_tycon tag-          stupid_theta work_id rep--- Warning: mkDataCon is not a good place to check certain invariants.--- If the programmer writes the wrong result type in the decl, thus:---      data T a where { MkT :: S }--- then it's possible that the univ_tvs may hit an assertion failure--- if you pull on univ_tvs.  This case is checked by checkValidDataCon,--- so the error is detected properly... it's just that assertions here--- are a little dodgy.--  = con-  where-    is_vanilla = null ex_tvs && null eq_spec && null theta--    con = MkData {dcName = name, dcUnique = nameUnique name,-                  dcVanilla = is_vanilla, dcInfix = declared_infix,-                  dcUnivTyVars = univ_tvs,-                  dcExTyCoVars = ex_tvs,-                  dcUserTyVarBinders = user_tvbs,-                  dcEqSpec = eq_spec,-                  dcOtherTheta = theta,-                  dcStupidTheta = stupid_theta,-                  dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,-                  dcRepTyCon = rep_tycon,-                  dcSrcBangs = arg_stricts,-                  dcFields = fields, dcTag = tag, dcRepType = rep_ty,-                  dcWorkId = work_id,-                  dcRep = rep,-                  dcSourceArity = length orig_arg_tys,-                  dcRepArity = length rep_arg_tys + count isCoVar ex_tvs,-                  dcPromoted = promoted }--        -- The 'arg_stricts' passed to mkDataCon are simply those for the-        -- source-language arguments.  We add extra ones for the-        -- dictionary arguments right here.--    rep_arg_tys = dataConRepArgTys con--    rep_ty =-      case rep of-        -- If the DataCon has no wrapper, then the worker's type *is* the-        -- user-facing type, so we can simply use dataConUserType.-        NoDataConRep -> dataConUserType con-        -- If the DataCon has a wrapper, then the worker's type is never seen-        -- by the user. The visibilities we pick do not matter here.-        DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $-                 mkVisFunTys rep_arg_tys $-                 mkTyConApp rep_tycon (mkTyVarTys univ_tvs)--      -- See Note [Promoted data constructors] in TyCon-    prom_tv_bndrs = [ mkNamedTyConBinder vis tv-                    | Bndr tv vis <- user_tvbs ]--    fresh_names = freshNames (map getName user_tvbs)-      -- fresh_names: make sure that the "anonymous" tyvars don't-      -- clash in name or unique with the universal/existential ones.-      -- Tiresome!  And unnecessary because these tyvars are never looked at-    prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t)-     {- Invisible -}   | (n,t) <- fresh_names `zip` theta ]-    prom_arg_bndrs   = [ mkAnonTyConBinder VisArg (mkTyVar n t)-     {- Visible -}     | (n,t) <- dropList theta fresh_names `zip` orig_arg_tys ]-    prom_bndrs       = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs-    prom_res_kind    = orig_res_ty-    promoted         = mkPromotedDataCon con name prom_info prom_bndrs-                                         prom_res_kind roles rep_info--    roles = map (\tv -> if isTyVar tv then Nominal else Phantom)-                (univ_tvs ++ ex_tvs)-            ++ map (const Representational) (theta ++ orig_arg_tys)--freshNames :: [Name] -> [Name]--- Make an infinite list of Names whose Uniques and OccNames--- differ from those in the 'avoid' list-freshNames avoids-  = [ mkSystemName uniq occ-    | n <- [0..]-    , let uniq = mkAlphaTyVarUnique n-          occ = mkTyVarOccFS (mkFastString ('x' : show n))--    , not (uniq `elementOfUniqSet` avoid_uniqs)-    , not (occ `elemOccSet` avoid_occs) ]--  where-    avoid_uniqs :: UniqSet Unique-    avoid_uniqs = mkUniqSet (map getUnique avoids)--    avoid_occs :: OccSet-    avoid_occs = mkOccSet (map getOccName avoids)---- | The 'Name' of the 'DataCon', giving it a unique, rooted identification-dataConName :: DataCon -> Name-dataConName = dcName---- | The tag used for ordering 'DataCon's-dataConTag :: DataCon -> ConTag-dataConTag  = dcTag--dataConTagZ :: DataCon -> ConTagZ-dataConTagZ con = dataConTag con - fIRST_TAG---- | The type constructor that we are building via this data constructor-dataConTyCon :: DataCon -> TyCon-dataConTyCon = dcRepTyCon---- | The original type constructor used in the definition of this data--- constructor.  In case of a data family instance, that will be the family--- type constructor.-dataConOrigTyCon :: DataCon -> TyCon-dataConOrigTyCon dc-  | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc-  | otherwise                                          = dcRepTyCon dc---- | The representation type of the data constructor, i.e. the sort--- type that will represent values of this type at runtime-dataConRepType :: DataCon -> Type-dataConRepType = dcRepType---- | Should the 'DataCon' be presented infix?-dataConIsInfix :: DataCon -> Bool-dataConIsInfix = dcInfix---- | The universally-quantified type variables of the constructor-dataConUnivTyVars :: DataCon -> [TyVar]-dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = tvbs---- | The existentially-quantified type/coercion variables of the constructor--- including dependent (kind-) GADT equalities-dataConExTyCoVars :: DataCon -> [TyCoVar]-dataConExTyCoVars (MkData { dcExTyCoVars = tvbs }) = tvbs---- | Both the universal and existential type/coercion variables of the constructor-dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar]-dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs })-  = univ_tvs ++ ex_tvs---- See Note [DataCon user type variable binders]--- | The type variables of the constructor, in the order the user wrote them-dataConUserTyVars :: DataCon -> [TyVar]-dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs---- See Note [DataCon user type variable binders]--- | 'TyCoVarBinder's for the type variables of the constructor, in the order the--- user wrote them-dataConUserTyVarBinders :: DataCon -> [TyVarBinder]-dataConUserTyVarBinders = dcUserTyVarBinders---- | Equalities derived from the result type of the data constructor, as written--- by the programmer in any GADT declaration. This includes *all* GADT-like--- equalities, including those written in by hand by the programmer.-dataConEqSpec :: DataCon -> [EqSpec]-dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })-  = dataConKindEqSpec con-    ++ eq_spec ++-    [ spec   -- heterogeneous equality-    | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta-    , tc `hasKey` heqTyConKey-    , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of-                    (Just tv1, _) -> [mkEqSpec tv1 ty2]-                    (_, Just tv2) -> [mkEqSpec tv2 ty1]-                    _             -> []-    ] ++-    [ spec   -- homogeneous equality-    | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta-    , tc `hasKey` eqTyConKey-    , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of-                    (Just tv1, _) -> [mkEqSpec tv1 ty2]-                    (_, Just tv2) -> [mkEqSpec tv2 ty1]-                    _             -> []-    ]---- | Dependent (kind-level) equalities in a constructor.--- There are extracted from the existential variables.--- See Note [Existential coercion variables]-dataConKindEqSpec :: DataCon -> [EqSpec]-dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs})-  -- It is used in 'dataConEqSpec' (maybe also 'dataConFullSig' in the future),-  -- which are frequently used functions.-  -- For now (Aug 2018) this function always return empty set as we don't really-  -- have coercion variables.-  -- In the future when we do, we might want to cache this information in DataCon-  -- so it won't be computed every time when aforementioned functions are called.-  = [ EqSpec tv ty-    | cv <- ex_tcvs-    , isCoVar cv-    , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv-          tv = getTyVar "dataConKindEqSpec" ty1-    ]---- | The *full* constraints on the constructor type, including dependent GADT--- equalities.-dataConTheta :: DataCon -> ThetaType-dataConTheta con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })-  = eqSpecPreds (dataConKindEqSpec con ++ eq_spec) ++ theta---- | Get the Id of the 'DataCon' worker: a function that is the "actual"--- constructor and has no top level binding in the program. The type may--- be different from the obvious one written in the source program. Panics--- if there is no such 'Id' for this 'DataCon'-dataConWorkId :: DataCon -> Id-dataConWorkId dc = dcWorkId dc---- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual"--- constructor so it has the type visible in the source program: c.f.--- 'dataConWorkId'.--- Returns Nothing if there is no wrapper, which occurs for an algebraic data--- constructor and also for a newtype (whose constructor is inlined--- compulsorily)-dataConWrapId_maybe :: DataCon -> Maybe Id-dataConWrapId_maybe dc = case dcRep dc of-                           NoDataConRep -> Nothing-                           DCR { dcr_wrap_id = wrap_id } -> Just wrap_id---- | Returns an Id which looks like the Haskell-source constructor by using--- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to--- the worker (see 'dataConWorkId')-dataConWrapId :: DataCon -> Id-dataConWrapId dc = case dcRep dc of-                     NoDataConRep-> dcWorkId dc    -- worker=wrapper-                     DCR { dcr_wrap_id = wrap_id } -> wrap_id---- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently,--- the union of the 'dataConWorkId' and the 'dataConWrapId'-dataConImplicitTyThings :: DataCon -> [TyThing]-dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep })-  = [AnId work] ++ wrap_ids-  where-    wrap_ids = case rep of-                 NoDataConRep               -> []-                 DCR { dcr_wrap_id = wrap } -> [AnId wrap]---- | The labels for the fields of this particular 'DataCon'-dataConFieldLabels :: DataCon -> [FieldLabel]-dataConFieldLabels = dcFields---- | Extract the type for any given labelled field of the 'DataCon'-dataConFieldType :: DataCon -> FieldLabelString -> Type-dataConFieldType con label = case dataConFieldType_maybe con label of-      Just (_, ty) -> ty-      Nothing      -> pprPanic "dataConFieldType" (ppr con <+> ppr label)---- | Extract the label and type for any given labelled field of the--- 'DataCon', or return 'Nothing' if the field does not belong to it-dataConFieldType_maybe :: DataCon -> FieldLabelString-                       -> Maybe (FieldLabel, Type)-dataConFieldType_maybe con label-  = find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con)---- | Strictness/unpack annotations, from user; or, for imported--- DataCons, from the interface file--- The list is in one-to-one correspondence with the arity of the 'DataCon'--dataConSrcBangs :: DataCon -> [HsSrcBang]-dataConSrcBangs = dcSrcBangs---- | Source-level arity of the data constructor-dataConSourceArity :: DataCon -> Arity-dataConSourceArity (MkData { dcSourceArity = arity }) = arity---- | Gives the number of actual fields in the /representation/ of the--- data constructor. This may be more than appear in the source code;--- the extra ones are the existentially quantified dictionaries-dataConRepArity :: DataCon -> Arity-dataConRepArity (MkData { dcRepArity = arity }) = arity---- | Return whether there are any argument types for this 'DataCon's original source type--- See Note [DataCon arities]-isNullarySrcDataCon :: DataCon -> Bool-isNullarySrcDataCon dc = dataConSourceArity dc == 0---- | Return whether there are any argument types for this 'DataCon's runtime representation type--- See Note [DataCon arities]-isNullaryRepDataCon :: DataCon -> Bool-isNullaryRepDataCon dc = dataConRepArity dc == 0--dataConRepStrictness :: DataCon -> [StrictnessMark]--- ^ Give the demands on the arguments of a--- Core constructor application (Con dc args)-dataConRepStrictness dc = case dcRep dc of-                            NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc]-                            DCR { dcr_stricts = strs } -> strs--dataConImplBangs :: DataCon -> [HsImplBang]--- The implementation decisions about the strictness/unpack of each--- source program argument to the data constructor-dataConImplBangs dc-  = case dcRep dc of-      NoDataConRep              -> replicate (dcSourceArity dc) HsLazy-      DCR { dcr_bangs = bangs } -> bangs--dataConBoxer :: DataCon -> Maybe DataConBoxer-dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer-dataConBoxer _ = Nothing--dataConInstSig-  :: DataCon-  -> [Type]    -- Instantiate the *universal* tyvars with these types-  -> ([TyCoVar], ThetaType, [Type])  -- Return instantiated existentials-                                     -- theta and arg tys--- ^ Instantiate the universal tyvars of a data con,---   returning---     ( instantiated existentials---     , instantiated constraints including dependent GADT equalities---         which are *also* listed in the instantiated existentials---     , instantiated args)-dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs-                           , dcOrigArgTys = arg_tys })-               univ_tys-  = ( ex_tvs'-    , substTheta subst (dataConTheta con)-    , substTys   subst arg_tys)-  where-    univ_subst = zipTvSubst univ_tvs univ_tys-    (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs----- | The \"full signature\" of the 'DataCon' returns, in order:------ 1) The result of 'dataConUnivTyVars'------ 2) The result of 'dataConExTyCoVars'------ 3) The non-dependent GADT equalities.---    Dependent GADT equalities are implied by coercion variables in---    return value (2).------ 4) The other constraints of the data constructor type, excluding GADT--- equalities------ 5) The original argument types to the 'DataCon' (i.e. before---    any change of the representation of the type)------ 6) The original result type of the 'DataCon'-dataConFullSig :: DataCon-               -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type)-dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs,-                        dcEqSpec = eq_spec, dcOtherTheta = theta,-                        dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})-  = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)--dataConOrigResTy :: DataCon -> Type-dataConOrigResTy dc = dcOrigResTy dc---- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in:------ > data Eq a => T a = ...-dataConStupidTheta :: DataCon -> ThetaType-dataConStupidTheta dc = dcStupidTheta dc--dataConUserType :: DataCon -> Type--- ^ The user-declared type of the data constructor--- in the nice-to-read form:------ > T :: forall a b. a -> b -> T [a]------ rather than:------ > T :: forall a c. forall b. (c~[a]) => a -> b -> T c------ The type variables are quantified in the order that the user wrote them.--- See @Note [DataCon user type variable binders]@.------ NB: If the constructor is part of a data instance, the result type--- mentions the family tycon, not the internal one.-dataConUserType (MkData { dcUserTyVarBinders = user_tvbs,-                          dcOtherTheta = theta, dcOrigArgTys = arg_tys,-                          dcOrigResTy = res_ty })-  = mkForAllTys user_tvbs $-    mkInvisFunTys theta $-    mkVisFunTys arg_tys $-    res_ty---- | Finds the instantiated types of the arguments required to construct a--- 'DataCon' representation--- NB: these INCLUDE any dictionary args---     but EXCLUDE the data-declaration context, which is discarded--- It's all post-flattening etc; this is a representation type-dataConInstArgTys :: DataCon    -- ^ A datacon with no existentials or equality constraints-                                -- However, it can have a dcTheta (notably it can be a-                                -- class dictionary, with superclasses)-                  -> [Type]     -- ^ Instantiated at these types-                  -> [Type]-dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs,-                              dcExTyCoVars = ex_tvs}) inst_tys- = ASSERT2( univ_tvs `equalLength` inst_tys-          , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)-   ASSERT2( null ex_tvs, ppr dc )-   map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc)---- | Returns just the instantiated /value/ argument types of a 'DataCon',--- (excluding dictionary args)-dataConInstOrigArgTys-        :: DataCon      -- Works for any DataCon-        -> [Type]       -- Includes existential tyvar args, but NOT-                        -- equality constraints or dicts-        -> [Type]--- For vanilla datacons, it's all quite straightforward--- But for the call in GHC.HsToCore.Match.Constructor, we really do want just--- the value args-dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,-                                  dcUnivTyVars = univ_tvs,-                                  dcExTyCoVars = ex_tvs}) inst_tys-  = ASSERT2( tyvars `equalLength` inst_tys-           , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )-    map (substTy subst) arg_tys-  where-    tyvars = univ_tvs ++ ex_tvs-    subst  = zipTCvSubst tyvars inst_tys---- | Returns the argument types of the wrapper, excluding all dictionary arguments--- and without substituting for any type variables-dataConOrigArgTys :: DataCon -> [Type]-dataConOrigArgTys dc = dcOrigArgTys dc---- | Returns the arg types of the worker, including *all* non-dependent--- evidence, after any flattening has been done and without substituting for--- any type variables-dataConRepArgTys :: DataCon -> [Type]-dataConRepArgTys (MkData { dcRep = rep-                         , dcEqSpec = eq_spec-                         , dcOtherTheta = theta-                         , dcOrigArgTys = orig_arg_tys })-  = case rep of-      NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys-      DCR { dcr_arg_tys = arg_tys } -> arg_tys---- | The string @package:module.name@ identifying a constructor, which is attached--- to its info table and used by the GHCi debugger and the heap profiler-dataConIdentity :: DataCon -> ByteString--- We want this string to be UTF-8, so we get the bytes directly from the FastStrings.-dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat-   [ BSB.byteString $ bytesFS (unitIdFS (moduleUnitId mod))-   , BSB.int8 $ fromIntegral (ord ':')-   , BSB.byteString $ bytesFS (moduleNameFS (moduleName mod))-   , BSB.int8 $ fromIntegral (ord '.')-   , BSB.byteString $ bytesFS (occNameFS (nameOccName name))-   ]-  where name = dataConName dc-        mod  = ASSERT( isExternalName name ) nameModule name--isTupleDataCon :: DataCon -> Bool-isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc--isUnboxedTupleCon :: DataCon -> Bool-isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc--isUnboxedSumCon :: DataCon -> Bool-isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc---- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors-isVanillaDataCon :: DataCon -> Bool-isVanillaDataCon dc = dcVanilla dc---- | Should this DataCon be allowed in a type even without -XDataKinds?--- Currently, only Lifted & Unlifted-specialPromotedDc :: DataCon -> Bool-specialPromotedDc = isKindTyCon . dataConTyCon--classDataCon :: Class -> DataCon-classDataCon clas = case tyConDataCons (classTyCon clas) of-                      (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr-                      [] -> panic "classDataCon"--dataConCannotMatch :: [Type] -> DataCon -> Bool--- Returns True iff the data con *definitely cannot* match a---                  scrutinee of type (T tys)---                  where T is the dcRepTyCon for the data con-dataConCannotMatch tys con-  -- See (U6) in Note [Implementing unsafeCoerce]-  -- in base:Unsafe.Coerce-  | dataConName con == unsafeReflDataConName-                      = False-  | null inst_theta   = False   -- Common-  | all isTyVarTy tys = False   -- Also common-  | otherwise         = typesCantMatch (concatMap predEqs inst_theta)-  where-    (_, inst_theta, _) = dataConInstSig con tys--    -- TODO: could gather equalities from superclasses too-    predEqs pred = case classifyPredType pred of-                     EqPred NomEq ty1 ty2         -> [(ty1, ty2)]-                     ClassPred eq args-                       | eq `hasKey` eqTyConKey-                       , [_, ty1, ty2] <- args    -> [(ty1, ty2)]-                       | eq `hasKey` heqTyConKey-                       , [_, _, ty1, ty2] <- args -> [(ty1, ty2)]-                     _                            -> []---- | Were the type variables of the data con written in a different order--- than the regular order (universal tyvars followed by existential tyvars)?------ This is not a cheap test, so we minimize its use in GHC as much as possible.--- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in--- "MkId", and so 'dataConUserTyVarsArePermuted' is only called at most once--- during a data constructor's lifetime.---- See Note [DataCon user type variable binders], as well as--- Note [Data con wrappers and GADT syntax] for an explanation of what--- mkDataConRep is doing with this function.-dataConUserTyVarsArePermuted :: DataCon -> Bool-dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs-                                     , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec-                                     , dcUserTyVarBinders = user_tvbs }) =-  (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs--{--%************************************************************************-%*                                                                      *-        Promoting of data types to the kind level-*                                                                      *-************************************************************************---}--promoteDataCon :: DataCon -> TyCon-promoteDataCon (MkData { dcPromoted = tc }) = tc--{--************************************************************************-*                                                                      *-\subsection{Splitting products}-*                                                                      *-************************************************************************--}---- | Extract the type constructor, type argument, data constructor and it's--- /representation/ argument types from a type if it is a product type.------ Precisely, we return @Just@ for any type that is all of:------  * Concrete (i.e. constructors visible)------  * Single-constructor------  * Not existentially quantified------ Whether the type is a @data@ type or a @newtype@-splitDataProductType_maybe-        :: Type                         -- ^ A product type, perhaps-        -> Maybe (TyCon,                -- The type constructor-                  [Type],               -- Type args of the tycon-                  DataCon,              -- The data constructor-                  [Type])               -- Its /representation/ arg types--        -- Rejecting existentials is conservative.  Maybe some things-        -- could be made to work with them, but I'm not going to sweat-        -- it through till someone finds it's important.--splitDataProductType_maybe ty-  | Just (tycon, ty_args) <- splitTyConApp_maybe ty-  , Just con <- isDataProductTyCon_maybe tycon-  = Just (tycon, ty_args, con, dataConInstArgTys con ty_args)-  | otherwise-  = Nothing-
− compiler/basicTypes/DataCon.hs-boot 
@@ -1,34 +0,0 @@-module DataCon where--import GhcPrelude-import Var( TyVar, TyCoVar, TyVarBinder )-import Name( Name, NamedThing )-import {-# SOURCE #-} TyCon( TyCon )-import FieldLabel ( FieldLabel )-import Unique ( Uniquable )-import Outputable ( Outputable, OutputableBndr )-import BasicTypes (Arity)-import {-# SOURCE #-} TyCoRep ( Type, ThetaType )--data DataCon-data DataConRep-data EqSpec--dataConName      :: DataCon -> Name-dataConTyCon     :: DataCon -> TyCon-dataConExTyCoVars :: DataCon -> [TyCoVar]-dataConUserTyVars :: DataCon -> [TyVar]-dataConUserTyVarBinders :: DataCon -> [TyVarBinder]-dataConSourceArity  :: DataCon -> Arity-dataConFieldLabels :: DataCon -> [FieldLabel]-dataConInstOrigArgTys  :: DataCon -> [Type] -> [Type]-dataConStupidTheta :: DataCon -> ThetaType-dataConFullSig :: DataCon-               -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type)-isUnboxedSumCon :: DataCon -> Bool--instance Eq DataCon-instance Uniquable DataCon-instance NamedThing DataCon-instance Outputable DataCon-instance OutputableBndr DataCon
− compiler/basicTypes/Demand.hs 
@@ -1,2005 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[Demand]{@Demand@: A decoupled implementation of a demand domain}--}--{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module Demand (-        StrDmd, UseDmd(..), Count,--        Demand, DmdShell, CleanDemand, getStrDmd, getUseDmd,-        mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd,-        toCleanDmd,-        absDmd, topDmd, botDmd, seqDmd,-        lubDmd, bothDmd,-        lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd,-        isTopDmd, isAbsDmd, isSeqDmd,-        peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd,-        addCaseBndrDmd,--        DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,-        nopDmdType, botDmdType, mkDmdType,-        addDemand, ensureArgs,-        BothDmdArg, mkBothDmdArg, toBothDmdArg,--        DmdEnv, emptyDmdEnv,-        peelFV, findIdDemand,--        Divergence(..), lubDivergence, isBotDiv, isTopDiv, topDiv, botDiv,-        appIsBottom, isBottomingSig, pprIfaceStrictSig,-        StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,-        nopSig, botSig, cprProdSig,-        isTopSig, hasDemandEnvSig,-        splitStrictSig, strictSigDmdEnv,-        increaseStrictSigArity, etaExpandStrictSig,--        seqDemand, seqDemandList, seqDmdType, seqStrictSig,--        evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd,-        splitDmdTy, splitFVs,-        deferAfterIO,-        postProcessUnsat, postProcessDmdType,--        splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds,-        mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig,-        dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots,-        TypeShape(..), peelTsFuns, trimToType,--        useCount, isUsedOnce, reuseEnv,-        killUsageDemand, killUsageSig, zapUsageDemand, zapUsageEnvSig,-        zapUsedOnceDemand, zapUsedOnceSig,-        strictifyDictDmd, strictifyDmd--     ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Driver.Session-import Outputable-import Var ( Var )-import VarEnv-import UniqFM-import Util-import BasicTypes-import Binary-import Maybes           ( orElse )--import Type            ( Type )-import TyCon           ( isNewTyCon, isClassTyCon )-import DataCon         ( splitDataProductType_maybe )--{--************************************************************************-*                                                                      *-        Joint domain for Strictness and Absence-*                                                                      *-************************************************************************--}--data JointDmd s u = JD { sd :: s, ud :: u }-  deriving ( Eq, Show )--getStrDmd :: JointDmd s u -> s-getStrDmd = sd--getUseDmd :: JointDmd s u -> u-getUseDmd = ud---- Pretty-printing-instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where-  ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u)---- Well-formedness preserving constructors for the joint domain-mkJointDmd :: s -> u -> JointDmd s u-mkJointDmd s u = JD { sd = s, ud = u }--mkJointDmds :: [s] -> [u] -> [JointDmd s u]-mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as---{--************************************************************************-*                                                                      *-            Strictness domain-*                                                                      *-************************************************************************--          Lazy-           |-        HeadStr-        /     \-    SCall      SProd-        \     /-        HyperStr--Note [Exceptions and strictness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to smart about catching exceptions, but we aren't anymore.-See #14998 for the way it's resolved at the moment.--Here's a historic breakdown:--Apparently, exception handling prim-ops didn't use to have any special-strictness signatures, thus defaulting to topSig, which assumes they use their-arguments lazily. Joachim was the first to realise that we could provide richer-information. Thus, in 0558911f91c (Dec 13), he added signatures to-primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call-their argument, which is useful information for usage analysis. Still with a-'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine.--In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a-'strictApply1Dmd' leads to substantial performance gains. That was at the cost-of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in-28638dfe79e (Dec 15).--Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712,-Ben opened #11222. Simon made the demand analyser "understand catch" in-9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call-its argument strictly, but also swallow any thrown exceptions in-'postProcessDivergence'. This was realized by extending the 'Str' constructor of-'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and-adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element-between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330,-so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17).--This left the other variants like 'catchRetry#' having 'catchArgDmd', which is-where #14998 picked up. Item 1 was concerned with measuring the impact of also-making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that-there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7-(Apr 18). There was a lot of dead code resulting from that change, that we-removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and-removed any code that was dealing with the peculiarities.--Where did the speed-ups vanish to? In #14998, item 3 established that-turning 'catch#' strict in its first argument didn't bring back any of the-alleged performance benefits. Item 2 of that ticket finally found out that it-was entirely due to 'catchException's new (since #11555) definition, which-was simply--    catchException !io handler = catch io handler--While 'catchException' is arguably the saner semantics for 'catch', it is an-internal helper function in "GHC.IO". Its use in-"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences:-Remove the bang and you find the regressions we originally wanted to avoid with-'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO".--So history keeps telling us that the only possibly correct strictness annotation-for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really-is not strict in its argument: Just try this in GHCi--  :set -XScopedTypeVariables-  import Control.Exception-  catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this")--Any analysis that assumes otherwise will be broken in some way or another-(beyond `-fno-pendantic-bottoms`).--}---- | Vanilla strictness domain-data StrDmd-  = HyperStr             -- ^ Hyper-strict (bottom of the lattice).-                         -- See Note [HyperStr and Use demands]--  | SCall StrDmd         -- ^ Call demand-                         -- Used only for values of function type--  | SProd [ArgStr]       -- ^ Product-                         -- Used only for values of product type-                         -- Invariant: not all components are HyperStr (use HyperStr)-                         --            not all components are Lazy     (use HeadStr)--  | HeadStr              -- ^ Head-Strict-                         -- A polymorphic demand: used for values of all types,-                         --                       including a type variable--  deriving ( Eq, Show )---- | Strictness of a function argument.-type ArgStr = Str StrDmd---- | Strictness demand.-data Str s = Lazy  -- ^ Lazy (top of the lattice)-           | Str s -- ^ Strict-  deriving ( Eq, Show )---- Well-formedness preserving constructors for the Strictness domain-strBot, strTop :: ArgStr-strBot = Str HyperStr-strTop = Lazy--mkSCall :: StrDmd -> StrDmd-mkSCall HyperStr = HyperStr-mkSCall s        = SCall s--mkSProd :: [ArgStr] -> StrDmd-mkSProd sx-  | any isHyperStr sx = HyperStr-  | all isLazy     sx = HeadStr-  | otherwise         = SProd sx--isLazy :: ArgStr -> Bool-isLazy Lazy     = True-isLazy (Str {}) = False--isHyperStr :: ArgStr -> Bool-isHyperStr (Str HyperStr) = True-isHyperStr _              = False---- Pretty-printing-instance Outputable StrDmd where-  ppr HyperStr      = char 'B'-  ppr (SCall s)     = char 'C' <> parens (ppr s)-  ppr HeadStr       = char 'S'-  ppr (SProd sx)    = char 'S' <> parens (hcat (map ppr sx))--instance Outputable ArgStr where-  ppr (Str s) = ppr s-  ppr Lazy    = char 'L'--lubArgStr :: ArgStr -> ArgStr -> ArgStr-lubArgStr Lazy     _        = Lazy-lubArgStr _        Lazy     = Lazy-lubArgStr (Str s1) (Str s2) = Str (s1 `lubStr` s2)--lubStr :: StrDmd -> StrDmd -> StrDmd-lubStr HyperStr s              = s-lubStr (SCall s1) HyperStr     = SCall s1-lubStr (SCall _)  HeadStr      = HeadStr-lubStr (SCall s1) (SCall s2)   = SCall (s1 `lubStr` s2)-lubStr (SCall _)  (SProd _)    = HeadStr-lubStr (SProd sx) HyperStr     = SProd sx-lubStr (SProd _)  HeadStr      = HeadStr-lubStr (SProd s1) (SProd s2)-    | s1 `equalLength` s2      = mkSProd (zipWith lubArgStr s1 s2)-    | otherwise                = HeadStr-lubStr (SProd _) (SCall _)     = HeadStr-lubStr HeadStr   _             = HeadStr--bothArgStr :: ArgStr -> ArgStr -> ArgStr-bothArgStr Lazy     s        = s-bothArgStr s        Lazy     = s-bothArgStr (Str s1) (Str s2) = Str (s1 `bothStr` s2)--bothStr :: StrDmd -> StrDmd -> StrDmd-bothStr HyperStr _             = HyperStr-bothStr HeadStr s              = s-bothStr (SCall _)  HyperStr    = HyperStr-bothStr (SCall s1) HeadStr     = SCall s1-bothStr (SCall s1) (SCall s2)  = SCall (s1 `bothStr` s2)-bothStr (SCall _)  (SProd _)   = HyperStr  -- Weird--bothStr (SProd _)  HyperStr    = HyperStr-bothStr (SProd s1) HeadStr     = SProd s1-bothStr (SProd s1) (SProd s2)-    | s1 `equalLength` s2      = mkSProd (zipWith bothArgStr s1 s2)-    | otherwise                = HyperStr  -- Weird-bothStr (SProd _) (SCall _)    = HyperStr---- utility functions to deal with memory leaks-seqStrDmd :: StrDmd -> ()-seqStrDmd (SProd ds)   = seqStrDmdList ds-seqStrDmd (SCall s)    = seqStrDmd s-seqStrDmd _            = ()--seqStrDmdList :: [ArgStr] -> ()-seqStrDmdList [] = ()-seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds--seqArgStr :: ArgStr -> ()-seqArgStr Lazy    = ()-seqArgStr (Str s) = seqStrDmd s---- Splitting polymorphic demands-splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr]-splitArgStrProdDmd n Lazy    = Just (replicate n Lazy)-splitArgStrProdDmd n (Str s) = splitStrProdDmd n s--splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr]-splitStrProdDmd n HyperStr   = Just (replicate n strBot)-splitStrProdDmd n HeadStr    = Just (replicate n strTop)-splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n),-                                     text "splitStrProdDmd" $$ ppr n $$ ppr ds )-                               Just ds-splitStrProdDmd _ (SCall {}) = Nothing-      -- This can happen when the programmer uses unsafeCoerce,-      -- and we don't then want to crash the compiler (#9208)--{--************************************************************************-*                                                                      *-            Absence domain-*                                                                      *-************************************************************************--         Used-         /   \-     UCall   UProd-         \   /-         UHead-          |-  Count x --        |-       Abs--}---- | Domain for genuine usage-data UseDmd-  = UCall Count UseDmd   -- ^ Call demand for absence.-                         -- Used only for values of function type--  | UProd [ArgUse]       -- ^ Product.-                         -- Used only for values of product type-                         -- See Note [Don't optimise UProd(Used) to Used]-                         ---                         -- Invariant: Not all components are Abs-                         -- (in that case, use UHead)--  | UHead                -- ^ May be used but its sub-components are-                         -- definitely *not* used.  For product types, UHead-                         -- is equivalent to U(AAA); see mkUProd.-                         ---                         -- UHead is needed only to express the demand-                         -- of 'seq' and 'case' which are polymorphic;-                         -- i.e. the scrutinised value is of type 'a'-                         -- rather than a product type. That's why we-                         -- can't use UProd [A,A,A]-                         ---                         -- Since (UCall _ Abs) is ill-typed, UHead doesn't-                         -- make sense for lambdas--  | Used                 -- ^ May be used and its sub-components may be used.-                         -- (top of the lattice)-  deriving ( Eq, Show )---- Extended usage demand for absence and counting-type ArgUse = Use UseDmd--data Use u-  = Abs             -- Definitely unused-                    -- Bottom of the lattice--  | Use Count u     -- May be used with some cardinality-  deriving ( Eq, Show )---- | Abstract counting of usages-data Count = One | Many-  deriving ( Eq, Show )---- Pretty-printing-instance Outputable ArgUse where-  ppr Abs           = char 'A'-  ppr (Use Many a)   = ppr a-  ppr (Use One  a)   = char '1' <> char '*' <> ppr a--instance Outputable UseDmd where-  ppr Used           = char 'U'-  ppr (UCall c a)    = char 'C' <> ppr c <> parens (ppr a)-  ppr UHead          = char 'H'-  ppr (UProd as)     = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as)))--instance Outputable Count where-  ppr One  = char '1'-  ppr Many = text ""--useBot, useTop :: ArgUse-useBot     = Abs-useTop     = Use Many Used--mkUCall :: Count -> UseDmd -> UseDmd---mkUCall c Used = Used c-mkUCall c a  = UCall c a--mkUProd :: [ArgUse] -> UseDmd-mkUProd ux-  | all (== Abs) ux    = UHead-  | otherwise          = UProd ux--lubCount :: Count -> Count -> Count-lubCount _ Many = Many-lubCount Many _ = Many-lubCount x _    = x--lubArgUse :: ArgUse -> ArgUse -> ArgUse-lubArgUse Abs x                   = x-lubArgUse x Abs                   = x-lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2)--lubUse :: UseDmd -> UseDmd -> UseDmd-lubUse UHead       u               = u-lubUse (UCall c u) UHead           = UCall c u-lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2)-lubUse (UCall _ _) _               = Used-lubUse (UProd ux) UHead            = UProd ux-lubUse (UProd ux1) (UProd ux2)-     | ux1 `equalLength` ux2       = UProd $ zipWith lubArgUse ux1 ux2-     | otherwise                   = Used-lubUse (UProd {}) (UCall {})       = Used--- lubUse (UProd {}) Used             = Used-lubUse (UProd ux) Used             = UProd (map (`lubArgUse` useTop) ux)-lubUse Used       (UProd ux)       = UProd (map (`lubArgUse` useTop) ux)-lubUse Used _                      = Used  -- Note [Used should win]---- `both` is different from `lub` in its treatment of counting; if--- `both` is computed for two used, the result always has---  cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain).---  Also,  x `bothUse` x /= x (for anything but Abs).--bothArgUse :: ArgUse -> ArgUse -> ArgUse-bothArgUse Abs x                   = x-bothArgUse x Abs                   = x-bothArgUse (Use _ a1) (Use _ a2)   = Use Many (bothUse a1 a2)---bothUse :: UseDmd -> UseDmd -> UseDmd-bothUse UHead       u               = u-bothUse (UCall c u) UHead           = UCall c u---- Exciting special treatment of inner demand for call demands:---    use `lubUse` instead of `bothUse`!-bothUse (UCall _ u1) (UCall _ u2)   = UCall Many (u1 `lubUse` u2)--bothUse (UCall {}) _                = Used-bothUse (UProd ux) UHead            = UProd ux-bothUse (UProd ux1) (UProd ux2)-      | ux1 `equalLength` ux2       = UProd $ zipWith bothArgUse ux1 ux2-      | otherwise                   = Used-bothUse (UProd {}) (UCall {})       = Used--- bothUse (UProd {}) Used             = Used  -- Note [Used should win]-bothUse Used (UProd ux)             = UProd (map (`bothArgUse` useTop) ux)-bothUse (UProd ux) Used             = UProd (map (`bothArgUse` useTop) ux)-bothUse Used _                      = Used  -- Note [Used should win]--peelUseCall :: UseDmd -> Maybe (Count, UseDmd)-peelUseCall (UCall c u)   = Just (c,u)-peelUseCall _             = Nothing--addCaseBndrDmd :: Demand    -- On the case binder-               -> [Demand]  -- On the components of the constructor-               -> [Demand]  -- Final demands for the components of the constructor--- See Note [Demand on case-alternative binders]-addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds-  = case mu of-     Abs     -> alt_dmds-     Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us)-             where-                Just ss = splitArgStrProdDmd arity ms  -- Guaranteed not to be a call-                Just us = splitUseProdDmd      arity u   -- Ditto-  where-    arity = length alt_dmds--{- Note [Demand on case-alternative binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The demand on a binder in a case alternative comes-  (a) From the demand on the binder itself-  (b) From the demand on the case binder-Forgetting (b) led directly to #10148.--Example. Source code:-  f x@(p,_) = if p then foo x else True--  foo (p,True) = True-  foo (p,q)    = foo (q,p)--After strictness analysis:-  f = \ (x_an1 [Dmd=<S(SL),1*U(U,1*U)>] :: (Bool, Bool)) ->-      case x_an1-      of wild_X7 [Dmd=<L,1*U(1*U,1*U)>]-      { (p_an2 [Dmd=<S,1*U>], ds_dnz [Dmd=<L,A>]) ->-      case p_an2 of _ {-        False -> GHC.Types.True;-        True -> foo wild_X7 }--It's true that ds_dnz is *itself* absent, but the use of wild_X7 means-that it is very much alive and demanded.  See #10148 for how the-consequences play out.--This is needed even for non-product types, in case the case-binder-is used but the components of the case alternative are not.--Note [Don't optimise UProd(Used) to Used]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-These two UseDmds:-   UProd [Used, Used]   and    Used-are semantically equivalent, but we do not turn the former into-the latter, for a regrettable-subtle reason.  Suppose we did.-then-  f (x,y) = (y,x)-would get-  StrDmd = Str  = SProd [Lazy, Lazy]-  UseDmd = Used = UProd [Used, Used]-But with the joint demand of <Str, Used> doesn't convey any clue-that there is a product involved, and so the worthSplittingFun-will not fire.  (We'd need to use the type as well to make it fire.)-Moreover, consider-  g h p@(_,_) = h p-This too would get <Str, Used>, but this time there really isn't any-point in w/w since the components of the pair are not used at all.--So the solution is: don't aggressively collapse UProd [Used,Used] to-Used; instead leave it as-is. In effect we are using the UseDmd to do a-little bit of boxity analysis.  Not very nice.--Note [Used should win]-~~~~~~~~~~~~~~~~~~~~~~-Both in lubUse and bothUse we want (Used `both` UProd us) to be Used.-Why?  Because Used carries the implication the whole thing is used,-box and all, so we don't want to w/w it.  If we use it both boxed and-unboxed, then we are definitely using the box, and so we are quite-likely to pay a reboxing cost.  So we make Used win here.--Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer--Baseline: (A) Not making Used win (UProd wins)-Compare with: (B) making Used win for lub and both--            Min          -0.3%     -5.6%    -10.7%    -11.0%    -33.3%-            Max          +0.3%    +45.6%    +11.5%    +11.5%     +6.9%- Geometric Mean          -0.0%     +0.5%     +0.3%     +0.2%     -0.8%--Baseline: (B) Making Used win for both lub and both-Compare with: (C) making Used win for both, but UProd win for lub--            Min          -0.1%     -0.3%     -7.9%     -8.0%     -6.5%-            Max          +0.1%     +1.0%    +21.0%    +21.0%     +0.5%- Geometric Mean          +0.0%     +0.0%     -0.0%     -0.1%     -0.1%--}---- If a demand is used multiple times (i.e. reused), than any use-once--- mentioned there, that is not protected by a UCall, can happen many times.-markReusedDmd :: ArgUse -> ArgUse-markReusedDmd Abs         = Abs-markReusedDmd (Use _ a)   = Use Many (markReused a)--markReused :: UseDmd -> UseDmd-markReused (UCall _ u)      = UCall Many u   -- No need to recurse here-markReused (UProd ux)       = UProd (map markReusedDmd ux)-markReused u                = u--isUsedMU :: ArgUse -> Bool--- True <=> markReusedDmd d = d-isUsedMU Abs          = True-isUsedMU (Use One _)  = False-isUsedMU (Use Many u) = isUsedU u--isUsedU :: UseDmd -> Bool--- True <=> markReused d = d-isUsedU Used           = True-isUsedU UHead          = True-isUsedU (UProd us)     = all isUsedMU us-isUsedU (UCall One _)  = False-isUsedU (UCall Many _) = True  -- No need to recurse---- Squashing usage demand demands-seqUseDmd :: UseDmd -> ()-seqUseDmd (UProd ds)   = seqArgUseList ds-seqUseDmd (UCall c d)  = c `seq` seqUseDmd d-seqUseDmd _            = ()--seqArgUseList :: [ArgUse] -> ()-seqArgUseList []     = ()-seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds--seqArgUse :: ArgUse -> ()-seqArgUse (Use c u)  = c `seq` seqUseDmd u-seqArgUse _          = ()---- Splitting polymorphic Maybe-Used demands-splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse]-splitUseProdDmd n Used        = Just (replicate n useTop)-splitUseProdDmd n UHead       = Just (replicate n Abs)-splitUseProdDmd n (UProd ds)  = WARN( not (ds `lengthIs` n),-                                      text "splitUseProdDmd" $$ ppr n-                                                             $$ ppr ds )-                                Just ds-splitUseProdDmd _ (UCall _ _) = Nothing-      -- This can happen when the programmer uses unsafeCoerce,-      -- and we don't then want to crash the compiler (#9208)--useCount :: Use u -> Count-useCount Abs         = One-useCount (Use One _) = One-useCount _           = Many---{--************************************************************************-*                                                                      *-         Clean demand for Strictness and Usage-*                                                                      *-************************************************************************--This domain differst from JointDemand in the sense that pure absence-is taken away, i.e., we deal *only* with non-absent demands.--Note [Strict demands]-~~~~~~~~~~~~~~~~~~~~~-isStrictDmd returns true only of demands that are-   both strict-   and  used-In particular, it is False for <HyperStr, Abs>, which can and does-arise in, say (#7319)-   f x = raise# <some exception>-Then 'x' is not used, so f gets strictness <HyperStr,Abs> -> .-Now the w/w generates-   fx = let x <HyperStr,Abs> = absentError "unused"-        in raise <some exception>-At this point we really don't want to convert to-   fx = case absentError "unused" of x -> raise <some exception>-Since the program is going to diverge, this swaps one error for another,-but it's really a bad idea to *ever* evaluate an absent argument.-In #7319 we get-   T7319.exe: Oops!  Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}]--Note [Dealing with call demands]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Call demands are constructed and deconstructed coherently for-strictness and absence. For instance, the strictness signature for the-following function--f :: (Int -> (Int, Int)) -> (Int, Bool)-f g = (snd (g 3), True)--should be: <L,C(U(AU))>m--}--type CleanDemand = JointDmd StrDmd UseDmd-     -- A demand that is at least head-strict--bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand-bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2})-  = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 }--mkHeadStrict :: CleanDemand -> CleanDemand-mkHeadStrict cd = cd { sd = HeadStr }--mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand-mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use One a }-mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use Many a }--evalDmd :: Demand--- Evaluated strictly, and used arbitrarily deeply-evalDmd = JD { sd = Str HeadStr, ud = useTop }--mkProdDmd :: [Demand] -> CleanDemand-mkProdDmd dx-  = JD { sd = mkSProd $ map getStrDmd dx-       , ud = mkUProd $ map getUseDmd dx }---- | Wraps the 'CleanDemand' with a one-shot call demand: @d@ -> @C1(d)@.-mkCallDmd :: CleanDemand -> CleanDemand-mkCallDmd (JD {sd = d, ud = u})-  = JD { sd = mkSCall d, ud = mkUCall One u }---- | @mkCallDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s.-mkCallDmds :: Arity -> CleanDemand -> CleanDemand-mkCallDmds arity cd = iterate mkCallDmd cd !! arity---- See Note [Demand on the worker] in WorkWrap-mkWorkerDemand :: Int -> Demand-mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) }-  where go 0 = Used-        go n = mkUCall One $ go (n-1)--cleanEvalDmd :: CleanDemand-cleanEvalDmd = JD { sd = HeadStr, ud = Used }--cleanEvalProdDmd :: Arity -> CleanDemand-cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) }---{--************************************************************************-*                                                                      *-           Demand: Combining Strictness and Usage-*                                                                      *-************************************************************************--}--type Demand = JointDmd ArgStr ArgUse--lubDmd :: Demand -> Demand -> Demand-lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})- = JD { sd = s1 `lubArgStr` s2-      , ud = a1 `lubArgUse` a2 }--bothDmd :: Demand -> Demand -> Demand-bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})- = JD { sd = s1 `bothArgStr` s2-      , ud = a1 `bothArgUse` a2 }--lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd :: Demand--strictApply1Dmd = JD { sd = Str (SCall HeadStr)-                     , ud = Use Many (UCall One Used) }--lazyApply1Dmd = JD { sd = Lazy-                   , ud = Use One (UCall One Used) }---- Second argument of catch#:---    uses its arg at most once, applies it once---    but is lazy (might not be called at all)-lazyApply2Dmd = JD { sd = Lazy-                   , ud = Use One (UCall One (UCall One Used)) }--absDmd :: Demand-absDmd = JD { sd = Lazy, ud = Abs }--topDmd :: Demand-topDmd = JD { sd = Lazy, ud = useTop }--botDmd :: Demand-botDmd = JD { sd = strBot, ud = useBot }--seqDmd :: Demand-seqDmd = JD { sd = Str HeadStr, ud = Use One UHead }--oneifyDmd :: JointDmd s (Use u) -> JointDmd s (Use u)-oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a }-oneifyDmd jd                            = jd--isTopDmd :: Demand -> Bool--- Used to suppress pretty-printing of an uninformative demand-isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True-isTopDmd _                                    = False--isAbsDmd :: JointDmd (Str s) (Use u) -> Bool-isAbsDmd (JD {ud = Abs}) = True   -- The strictness part can be HyperStr-isAbsDmd _               = False  -- for a bottom demand--isSeqDmd :: Demand -> Bool-isSeqDmd (JD {sd = Str HeadStr, ud = Use _ UHead}) = True-isSeqDmd _                                                = False--isUsedOnce :: JointDmd (Str s) (Use u) -> Bool-isUsedOnce (JD { ud = a }) = case useCount a of-                               One  -> True-                               Many -> False---- More utility functions for strictness-seqDemand :: Demand -> ()-seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u--seqDemandList :: [Demand] -> ()-seqDemandList [] = ()-seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds--isStrictDmd :: JointDmd (Str s) (Use u) -> Bool--- See Note [Strict demands]-isStrictDmd (JD {ud = Abs})  = False-isStrictDmd (JD {sd = Lazy}) = False-isStrictDmd _                = True--isWeakDmd :: Demand -> Bool-isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a--cleanUseDmd_maybe :: Demand -> Maybe UseDmd-cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u-cleanUseDmd_maybe _                     = Nothing--splitFVs :: Bool   -- Thunk-         -> DmdEnv -> (DmdEnv, DmdEnv)-splitFVs is_thunk rhs_fvs-  | is_thunk  = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs-                -- It's OK to use nonDetFoldUFM_Directly because we-                -- immediately forget the ordering by putting the elements-                -- in the envs again-  | otherwise = partitionVarEnv isWeakDmd rhs_fvs-  where-    add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv)-      | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv)-      | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u })-                    , addToUFM_Directly sig_fv  uniq (JD { sd = s,    ud = Abs }) )--data TypeShape = TsFun TypeShape-               | TsProd [TypeShape]-               | TsUnk--instance Outputable TypeShape where-  ppr TsUnk        = text "TsUnk"-  ppr (TsFun ts)   = text "TsFun" <> parens (ppr ts)-  ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)---- | @peelTsFuns n ts@ tries to peel off @n@ 'TsFun' constructors from @ts@ and--- returns 'Just' the wrapped 'TypeShape' on success, and 'Nothing' otherwise.-peelTsFuns :: Arity -> TypeShape -> Maybe TypeShape-peelTsFuns 0 ts         = Just ts-peelTsFuns n (TsFun ts) = peelTsFuns (n-1) ts-peelTsFuns _ _          = Nothing--trimToType :: Demand -> TypeShape -> Demand--- See Note [Trimming a demand to a type]-trimToType (JD { sd = ms, ud = mu }) ts-  = JD (go_ms ms ts) (go_mu mu ts)-  where-    go_ms :: ArgStr -> TypeShape -> ArgStr-    go_ms Lazy    _  = Lazy-    go_ms (Str s) ts = Str (go_s s ts)--    go_s :: StrDmd -> TypeShape -> StrDmd-    go_s HyperStr    _            = HyperStr-    go_s (SCall s)   (TsFun ts)   = SCall (go_s s ts)-    go_s (SProd mss) (TsProd tss)-      | equalLength mss tss       = SProd (zipWith go_ms mss tss)-    go_s _           _            = HeadStr--    go_mu :: ArgUse -> TypeShape -> ArgUse-    go_mu Abs _ = Abs-    go_mu (Use c u) ts = Use c (go_u u ts)--    go_u :: UseDmd -> TypeShape -> UseDmd-    go_u UHead       _          = UHead-    go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts)-    go_u (UProd mus) (TsProd tss)-      | equalLength mus tss      = UProd (zipWith go_mu mus tss)-    go_u _           _           = Used--{--Note [Trimming a demand to a type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this:--  f :: a -> Bool-  f x = case ... of-          A g1 -> case (x |> g1) of (p,q) -> ...-          B    -> error "urk"--where A,B are the constructors of a GADT.  We'll get a U(U,U) demand-on x from the A branch, but that's a stupid demand for x itself, which-has type 'a'. Indeed we get ASSERTs going off (notably in-splitUseProdDmd, #8569).--Bottom line: we really don't want to have a binder whose demand is more-deeply-nested than its type.  There are various ways to tackle this.-When processing (x |> g1), we could "trim" the incoming demand U(U,U)-to match x's type.  But I'm currently doing so just at the moment when-we pin a demand on a binder, in DmdAnal.findBndrDmd.---Note [Threshold demands]-~~~~~~~~~~~~~~~~~~~~~~~~-Threshold usage demand is generated to figure out if-cardinality-instrumented demands of a binding's free variables should-be unleashed. See also [Aggregated demand for cardinality].--Note [Replicating polymorphic demands]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Some demands can be considered as polymorphic. Generally, it is-applicable to such beasts as tops, bottoms as well as Head-Used and-Head-stricts demands. For instance,--S ~ S(L, ..., L)--Also, when top or bottom is occurred as a result demand, it in fact-can be expanded to saturate a callee's arity.--}--splitProdDmd_maybe :: Demand -> Maybe [Demand]--- Split a product into its components, iff there is any--- useful information to be extracted thereby--- The demand is not necessarily strict!-splitProdDmd_maybe (JD { sd = s, ud = u })-  = case (s,u) of-      (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u-                                -> Just (mkJointDmds sx ux)-      (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s-                                -> Just (mkJointDmds sx ux)-      (Lazy,  Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)-      _ -> Nothing--{--************************************************************************-*                                                                      *-                   Termination-*                                                                      *-************************************************************************--Divergence:     Dunno-               /-          Diverges--In a fixpoint iteration, start from Diverges--}--data Divergence-  = Diverges    -- Definitely diverges-  | Dunno       -- Might diverge or converge-  deriving( Eq, Show )--lubDivergence :: Divergence -> Divergence ->Divergence-lubDivergence Diverges r        = r-lubDivergence r        Diverges = r-lubDivergence Dunno    Dunno    = Dunno--- This needs to commute with defaultDmd, i.e.--- defaultDmd (r1 `lubDivergence` r2) = defaultDmd r1 `lubDmd` defaultDmd r2--- (See Note [Default demand on free variables] for why)--bothDivergence :: Divergence -> Divergence -> Divergence--- See Note [Asymmetry of 'both' for DmdType and Divergence]-bothDivergence _ Diverges = Diverges-bothDivergence r Dunno    = r--- This needs to commute with defaultDmd, i.e.--- defaultDmd (r1 `bothDivergence` r2) = defaultDmd r1 `bothDmd` defaultDmd r2--- (See Note [Default demand on free variables] for why)--instance Outputable Divergence where-  ppr Diverges      = char 'b'-  ppr Dunno         = empty----------------------------------------------------------------------------- Combined demand result                                             ------------------------------------------------------------------------------- [cprRes] lets us switch off CPR analysis--- by making sure that everything uses TopRes-topDiv, botDiv :: Divergence-topDiv = Dunno-botDiv = Diverges--isTopDiv :: Divergence -> Bool-isTopDiv Dunno = True-isTopDiv _     = False---- | True if the result diverges or throws an exception-isBotDiv :: Divergence -> Bool-isBotDiv Diverges = True-isBotDiv _        = False---- See Notes [Default demand on free variables]--- and [defaultDmd vs. resTypeArgDmd]-defaultDmd :: Divergence -> Demand-defaultDmd Dunno = absDmd-defaultDmd _     = botDmd  -- Diverges--resTypeArgDmd :: Divergence -> Demand--- TopRes and BotRes are polymorphic, so that---      BotRes === (Bot -> BotRes) === ...---      TopRes === (Top -> TopRes) === ...--- This function makes that concrete--- Also see Note [defaultDmd vs. resTypeArgDmd]-resTypeArgDmd Dunno = topDmd-resTypeArgDmd _     = botDmd   -- Diverges--{--Note [defaultDmd and resTypeArgDmd]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--These functions are similar: They express the demand on something not-explicitly mentioned in the environment resp. the argument list. Yet they are-different:- * Variables not mentioned in the free variables environment are definitely-   unused, so we can use absDmd there.- * Further arguments *can* be used, of course. Hence topDmd is used.---************************************************************************-*                                                                      *-           Demand environments and types-*                                                                      *-************************************************************************--}--type DmdEnv = VarEnv Demand   -- See Note [Default demand on free variables]--data DmdType = DmdType-                  DmdEnv        -- Demand on explicitly-mentioned-                                --      free variables-                  [Demand]      -- Demand on arguments-                  Divergence     -- See [Nature of result demand]--{--Note [Nature of result demand]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A Divergence contains information about termination (currently distinguishing-definite divergence and no information; it is possible to include definite-convergence here), and CPR information about the result.--The semantics of this depends on whether we are looking at a DmdType, i.e. the-demand put on by an expression _under a specific incoming demand_ on its-environment, or at a StrictSig describing a demand transformer.--For a- * DmdType, the termination information is true given the demand it was-   generated with, while for- * a StrictSig it holds after applying enough arguments.--The CPR information, though, is valid after the number of arguments mentioned-in the type is given. Therefore, when forgetting the demand on arguments, as in-dmdAnalRhs, this needs to be considered (via removeDmdTyArgs).--Consider-  b2 x y = x `seq` y `seq` error (show x)-this has a strictness signature of-  <S><S>b-meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but-for "b2 1 2 `seq` ()" we get definite divergence.--For comparison,-  b1 x = x `seq` error (show x)-has a strictness signature of-  <S>b-and "b1 1 `seq` ()" is known to terminate.--Now consider a function h with signature "<C(S)>", and the expression-  e1 = h b1-now h puts a demand of <C(S)> onto its argument, and the demand transformer-turns it into-  <S>b-Now the Divergence "b" does apply to us, even though "b1 `seq` ()" does not-diverge, and we do not anything being passed to b.--Note [Asymmetry of 'both' for DmdType and Divergence]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-'both' for DmdTypes is *asymmetrical*, because there is only one-result!  For example, given (e1 e2), we get a DmdType dt1 for e1, use-its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2).-Similarly with-  case e of { p -> rhs }-we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then-compute (dt_rhs `bothType` dt_scrut).--We- 1. combine the information on the free variables,- 2. take the demand on arguments from the first argument- 3. combine the termination results, but- 4. take CPR info from the first argument.--3 and 4 are implemented in bothDivergence.--}---- Equality needed for fixpoints in DmdAnal-instance Eq DmdType where-  (==) (DmdType fv1 ds1 div1)-       (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2-         -- It's OK to use nonDetUFMToList here because we're testing for-         -- equality and even though the lists will be in some arbitrary-         -- Unique order, it is the same order for both-                              && ds1 == ds2 && div1 == div2--lubDmdType :: DmdType -> DmdType -> DmdType-lubDmdType d1 d2-  = DmdType lub_fv lub_ds lub_div-  where-    n = max (dmdTypeDepth d1) (dmdTypeDepth d2)-    (DmdType fv1 ds1 r1) = ensureArgs n d1-    (DmdType fv2 ds2 r2) = ensureArgs n d2--    lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2)-    lub_ds  = zipWithEqual "lubDmdType" lubDmd ds1 ds2-    lub_div = lubDivergence r1 r2--{--Note [The need for BothDmdArg]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Previously, the right argument to bothDmdType, as well as the return value of-dmdAnalStar via postProcessDmdType, was a DmdType. But bothDmdType only needs-to know about the free variables and termination information, but nothing about-the demand put on arguments, nor cpr information. So we make that explicit by-only passing the relevant information.--}--type BothDmdArg = (DmdEnv, Divergence)--mkBothDmdArg :: DmdEnv -> BothDmdArg-mkBothDmdArg env = (env, Dunno)--toBothDmdArg :: DmdType -> BothDmdArg-toBothDmdArg (DmdType fv _ r) = (fv, go r)-  where-    go Dunno    = Dunno-    go Diverges = Diverges--bothDmdType :: DmdType -> BothDmdArg -> DmdType-bothDmdType (DmdType fv1 ds1 r1) (fv2, t2)-    -- See Note [Asymmetry of 'both' for DmdType and Divergence]-    -- 'both' takes the argument/result info from its *first* arg,-    -- using its second arg just for its free-var info.-  = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2))-            ds1-            (r1 `bothDivergence` t2)--instance Outputable DmdType where-  ppr (DmdType fv ds res)-    = hsep [hcat (map ppr ds) <> ppr res,-            if null fv_elts then empty-            else braces (fsep (map pp_elt fv_elts))]-    where-      pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd-      fv_elts = nonDetUFMToList fv-        -- It's OK to use nonDetUFMToList here because we only do it for-        -- pretty printing--emptyDmdEnv :: VarEnv Demand-emptyDmdEnv = emptyVarEnv---- nopDmdType is the demand of doing nothing--- (lazy, absent, no CPR information, no termination information).--- Note that it is ''not'' the top of the lattice (which would be "may use everything"),--- so it is (no longer) called topDmd-nopDmdType, botDmdType :: DmdType-nopDmdType = DmdType emptyDmdEnv [] topDiv-botDmdType = DmdType emptyDmdEnv [] botDiv--isTopDmdType :: DmdType -> Bool-isTopDmdType (DmdType env [] res)-  | isTopDiv res && isEmptyVarEnv env = True-isTopDmdType _                        = False--mkDmdType :: DmdEnv -> [Demand] -> Divergence -> DmdType-mkDmdType fv ds res = DmdType fv ds res--dmdTypeDepth :: DmdType -> Arity-dmdTypeDepth (DmdType _ ds _) = length ds---- | This makes sure we can use the demand type with n arguments.--- It extends the argument list with the correct resTypeArgDmd.--- It also adjusts the Divergence: Divergence survives additional arguments,--- CPR information does not (and definite converge also would not).-ensureArgs :: Arity -> DmdType -> DmdType-ensureArgs n d | n == depth = d-               | otherwise  = DmdType fv ds' r'-  where depth = dmdTypeDepth d-        DmdType fv ds r = d--        ds' = take n (ds ++ repeat (resTypeArgDmd r))-        r' = case r of    -- See [Nature of result demand]-              Dunno -> topDiv-              _     -> r---seqDmdType :: DmdType -> ()-seqDmdType (DmdType env ds res) =-  seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` ()--seqDmdEnv :: DmdEnv -> ()-seqDmdEnv env = seqEltsUFM seqDemandList env--splitDmdTy :: DmdType -> (Demand, DmdType)--- Split off one function argument--- We already have a suitable demand on all--- free vars, so no need to add more!-splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)-splitDmdTy ty@(DmdType _ [] res_ty)       = (resTypeArgDmd res_ty, ty)---- When e is evaluated after executing an IO action, and d is e's demand, then--- what of this demand should we consider, given that the IO action can cleanly--- exit?--- * We have to kill all strictness demands (i.e. lub with a lazy demand)--- * We can keep usage information (i.e. lub with an absent demand)--- * We have to kill definite divergence--- * We can keep CPR information.--- See Note [IO hack in the demand analyser] in DmdAnal-deferAfterIO :: DmdType -> DmdType-deferAfterIO d@(DmdType _ _ res) =-    case d `lubDmdType` nopDmdType of-        DmdType fv ds _ -> DmdType fv ds (defer_res res)-  where-  defer_res r@(Dunno {}) = r-  defer_res _            = topDiv  -- Diverges--strictenDmd :: Demand -> CleanDemand-strictenDmd (JD { sd = s, ud = u})-  = JD { sd = poke_s s, ud = poke_u u }-  where-    poke_s Lazy      = HeadStr-    poke_s (Str s)   = s-    poke_u Abs       = UHead-    poke_u (Use _ u) = u---- Deferring and peeling--type DmdShell   -- Describes the "outer shell"-                -- of a Demand-   = JointDmd (Str ()) (Use ())--toCleanDmd :: Demand -> (DmdShell, CleanDemand)--- Splits a Demand into its "shell" and the inner "clean demand"-toCleanDmd (JD { sd = s, ud = u })-  = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' })-    -- See Note [Analyzing with lazy demand and lambdas]-    -- See Note [Analysing with absent demand]-  where-    (ss, s') = case s of-                Str s' -> (Str (), s')-                Lazy   -> (Lazy,   HeadStr)--    (us, u') = case u of-                 Use c u' -> (Use c (), u')-                 Abs      -> (Abs,      Used)---- This is used in dmdAnalStar when post-processing--- a function's argument demand. So we only care about what--- does to free variables, and whether it terminates.--- see Note [The need for BothDmdArg]-postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg-postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty)-    = (postProcessDmdEnv du fv, postProcessDivergence ss res_ty)--postProcessDivergence :: Str () -> Divergence -> Divergence-postProcessDivergence Lazy _   = topDiv-postProcessDivergence _    res = res--postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv-postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env-  | Abs <- us       = emptyDmdEnv-    -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild-    -- of the environment. Be careful, bad things will happen if this doesn't-    -- match postProcessDmd (see #13977).-  | Str _ <- ss-  , Use One _ <- us = env-  | otherwise       = mapVarEnv (postProcessDmd ds) env-  -- For the Absent case just discard all usage information-  -- We only processed the thing at all to analyse the body-  -- See Note [Always analyse in virgin pass]--reuseEnv :: DmdEnv -> DmdEnv-reuseEnv = mapVarEnv (postProcessDmd-                        (JD { sd = Str (), ud = Use Many () }))--postProcessUnsat :: DmdShell -> DmdType -> DmdType-postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty)-  = DmdType (postProcessDmdEnv ds fv)-            (map (postProcessDmd ds) args)-            (postProcessDivergence ss res_ty)--postProcessDmd :: DmdShell -> Demand -> Demand-postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a})-  = JD { sd = s', ud = a' }-  where-    s' = case ss of-           Lazy  -> Lazy-           Str _ -> s-    a' = case us of-           Abs        -> Abs-           Use Many _ -> markReusedDmd a-           Use One  _ -> a---- Peels one call level from the demand, and also returns--- whether it was unsaturated (separately for strictness and usage)-peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell)--- Exploiting the fact that--- on the strictness side      C(B) = B--- and on the usage side       C(U) = U-peelCallDmd (JD {sd = s, ud = u})-  = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us })-  where-    (s', ss) = case s of-                 SCall s' -> (s',       Str ())-                 HyperStr -> (HyperStr, Str ())-                 _        -> (HeadStr,  Lazy)-    (u', us) = case u of-                 UCall c u' -> (u',   Use c    ())-                 _          -> (Used, Use Many ())-       -- The _ cases for usage includes UHead which seems a bit wrong-       -- because the body isn't used at all!-       -- c.f. the Abs case in toCleanDmd---- Peels that multiple nestings of calls clean demand and also returns--- whether it was unsaturated (separately for strictness and usage--- see Note [Demands from unsaturated function calls]-peelManyCalls :: Int -> CleanDemand -> DmdShell-peelManyCalls n (JD { sd = str, ud = abs })-  = JD { sd = go_str n str, ud = go_abs n abs }-  where-    go_str :: Int -> StrDmd -> Str ()  -- True <=> unsaturated, defer-    go_str 0 _          = Str ()-    go_str _ HyperStr   = Str () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr)-    go_str n (SCall d') = go_str (n-1) d'-    go_str _ _          = Lazy--    go_abs :: Int -> UseDmd -> Use ()      -- Many <=> unsaturated, or at least-    go_abs 0 _              = Use One ()   --          one UCall Many in the demand-    go_abs n (UCall One d') = go_abs (n-1) d'-    go_abs _ _              = Use Many ()--{--Note [Demands from unsaturated function calls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Consider a demand transformer d1 -> d2 -> r for f.-If a sufficiently detailed demand is fed into this transformer,-e.g <C(C(S)), C1(C1(S))> arising from "f x1 x2" in a strict, use-once context,-then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for-the free variable environment) and furthermore the result information r is the-one we want to use.--An anonymous lambda is also an unsaturated function all (needs one argument,-none given), so this applies to that case as well.--But the demand fed into f might be less than <C(C(S)), C1(C1(S))>. There are a few cases:- * Not enough demand on the strictness side:-   - In that case, we need to zap all strictness in the demand on arguments and-     free variables.-   - Furthermore, we remove CPR information. It could be left, but given the incoming-     demand is not enough to evaluate so far we just do not bother.-   - And finally termination information: If r says that f diverges for sure,-     then this holds when the demand guarantees that two arguments are going to-     be passed. If the demand is lower, we may just as well converge.-     If we were tracking definite convegence, than that would still hold under-     a weaker demand than expected by the demand transformer.- * Not enough demand from the usage side: The missing usage can be expanded-   using UCall Many, therefore this is subsumed by the third case:- * At least one of the uses has a cardinality of Many.-   - Even if f puts a One demand on any of its argument or free variables, if-     we call f multiple times, we may evaluate this argument or free variable-     multiple times. So forget about any occurrence of "One" in the demand.--In dmdTransformSig, we call peelManyCalls to find out if we are in any of these-cases, and then call postProcessUnsat to reduce the demand appropriately.--Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use-peelCallDmd, which peels only one level, but also returns the demand put on the-body of the function.--}--peelFV :: DmdType -> Var -> (DmdType, Demand)-peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)-                               (DmdType fv' ds res, dmd)-  where-  fv' = fv `delVarEnv` id-  -- See Note [Default demand on free variables]-  dmd  = lookupVarEnv fv id `orElse` defaultDmd res--addDemand :: Demand -> DmdType -> DmdType-addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res--findIdDemand :: DmdType -> Var -> Demand-findIdDemand (DmdType fv _ res) id-  = lookupVarEnv fv id `orElse` defaultDmd res--{--Note [Default demand on free variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the variable is not mentioned in the environment of a demand type,-its demand is taken to be a result demand of the type.-    For the strictness component,-     if the result demand is a Diverges, then we use HyperStr-                                         else we use Lazy-    For the usage component, we use Absent.-So we use either absDmd or botDmd.--Also note the equations for lubDivergence (resp. bothDivergence) noted there.--Note [Always analyse in virgin pass]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Tricky point: make sure that we analyse in the 'virgin' pass. Consider-   rec { f acc x True  = f (...rec { g y = ...g... }...)-         f acc x False = acc }-In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type.-That might mean that we analyse the sub-expression containing the-E = "...rec g..." stuff in a bottom demand.  Suppose we *didn't analyse*-E, but just returned botType.--Then in the *next* (non-virgin) iteration for 'f', we might analyse E-in a weaker demand, and that will trigger doing a fixpoint iteration-for g.  But *because it's not the virgin pass* we won't start g's-iteration at bottom.  Disaster.  (This happened in $sfibToList' of-nofib/spectral/fibheaps.)--So in the virgin pass we make sure that we do analyse the expression-at least once, to initialise its signatures.--Note [Analyzing with lazy demand and lambdas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The insight for analyzing lambdas follows from the fact that for-strictness S = C(L). This polymorphic expansion is critical for-cardinality analysis of the following example:--{-# NOINLINE build #-}-build g = (g (:) [], g (:) [])--h c z = build (\x ->-                let z1 = z ++ z-                 in if c-                    then \y -> x (y ++ z1)-                    else \y -> x (z1 ++ y))--One can see that `build` assigns to `g` demand <L,C(C1(U))>.-Therefore, when analyzing the lambda `(\x -> ...)`, we-expect each lambda \y -> ... to be annotated as "one-shot"-one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a-demand <C(C(..), C(C1(U))>.--This is achieved by, first, converting the lazy demand L into the-strict S by the second clause of the analysis.--Note [Analysing with absent demand]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we analyse an expression with demand <L,A>.  The "A" means-"absent", so this expression will never be needed.  What should happen?-There are several wrinkles:--* We *do* want to analyse the expression regardless.-  Reason: Note [Always analyse in virgin pass]--  But we can post-process the results to ignore all the usage-  demands coming back. This is done by postProcessDmdType.--* In a previous incarnation of GHC we needed to be extra careful in the-  case of an *unlifted type*, because unlifted values are evaluated-  even if they are not used.  Example (see #9254):-     f :: (() -> (# Int#, () #)) -> ()-          -- Strictness signature is-          --    <C(S(LS)), 1*C1(U(A,1*U()))>-          -- I.e. calls k, but discards first component of result-     f k = case k () of (# _, r #) -> r--     g :: Int -> ()-     g y = f (\n -> (# case y of I# y2 -> y2, n #))--  Here f's strictness signature says (correctly) that it calls its-  argument function and ignores the first component of its result.-  This is correct in the sense that it'd be fine to (say) modify the-  function so that always returned 0# in the first component.--  But in function g, we *will* evaluate the 'case y of ...', because-  it has type Int#.  So 'y' will be evaluated.  So we must record this-  usage of 'y', else 'g' will say 'y' is absent, and will w/w so that-  'y' is bound to an aBSENT_ERROR thunk.--  However, the argument of toCleanDmd always satisfies the let/app-  invariant; so if it is unlifted it is also okForSpeculation, and so-  can be evaluated in a short finite time -- and that rules out nasty-  cases like the one above.  (I'm not quite sure why this was a-  problem in an earlier version of GHC, but it isn't now.)---************************************************************************-*                                                                      *-                     Demand signatures-*                                                                      *-************************************************************************--In a let-bound Id we record its strictness info.-In principle, this strictness info is a demand transformer, mapping-a demand on the Id into a DmdType, which gives-        a) the free vars of the Id's value-        b) the Id's arguments-        c) an indication of the result of applying-           the Id to its arguments--However, in fact we store in the Id an extremely emascuated demand-transfomer, namely--                a single DmdType-(Nevertheless we dignify StrictSig as a distinct type.)--This DmdType gives the demands unleashed by the Id when it is applied-to as many arguments as are given in by the arg demands in the DmdType.-Also see Note [Nature of result demand] for the meaning of a Divergence in a-strictness signature.--If an Id is applied to less arguments than its arity, it means that-the demand on the function at a call site is weaker than the vanilla-call demand, used for signature inference. Therefore we place a top-demand on all arguments. Otherwise, the demand is specified by Id's-signature.--For example, the demand transformer described by the demand signature-        StrictSig (DmdType {x -> <S,1*U>} <L,A><L,U(U,U)>m)-says that when the function is applied to two arguments, it-unleashes demand <S,1*U> on the free var x, <L,A> on the first arg,-and <L,U(U,U)> on the second, then returning a constructor.--If this same function is applied to one arg, all we can say is that it-uses x with <L,U>, and its arg with demand <L,U>.--Note [Understanding DmdType and StrictSig]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Demand types are sound approximations of an expression's semantics relative to-the incoming demand we put the expression under. Consider the following-expression:--    \x y -> x `seq` (y, 2*x)--Here is a table with demand types resulting from different incoming demands we-put that expression under. Note the monotonicity; a stronger incoming demand-yields a more precise demand type:--    incoming demand                  |  demand type-    -----------------------------------------------------    <S           ,HU              >  |  <L,U><L,U>{}-    <C(C(S     )),C1(C1(U       ))>  |  <S,U><L,U>{}-    <C(C(S(S,L))),C1(C1(U(1*U,A)))>  |  <S,1*HU><L,A>{}--Note that in the first example, the depth of the demand type was *higher* than-the arity of the incoming call demand due to the anonymous lambda.-The converse is also possible and happens when we unleash demand signatures.-In @f x y@, the incoming call demand on f has arity 2. But if all we have is a-demand signature with depth 1 for @f@ (which we can safely unleash, see below),-the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1.--So: Demand types are elicited by putting an expression under an incoming (call)-demand, the arity of which can be lower or higher than the depth of the-resulting demand type.-In contrast, a demand signature summarises a function's semantics *without*-immediately specifying the incoming demand it was produced under. Despite StrSig-being a newtype wrapper around DmdType, it actually encodes two things:--  * The threshold (i.e., minimum arity) to unleash the signature-  * A demand type that is sound to unleash when the minimum arity requirement is-    met.--Here comes the subtle part: The threshold is encoded in the wrapped demand-type's depth! So in mkStrictSigForArity we make sure to trim the list of-argument demands to the given threshold arity. Call sites will make sure that-this corresponds to the arity of the call demand that elicited the wrapped-demand type. See also Note [What are demand signatures?] in DmdAnal.--Besides trimming argument demands, mkStrictSigForArity will also trim CPR-information if necessary.--}---- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe--- to unleash. Better construct this through 'mkStrictSigForArity'.--- See Note [Understanding DmdType and StrictSig]-newtype StrictSig = StrictSig DmdType-                  deriving( Eq )--instance Outputable StrictSig where-   ppr (StrictSig ty) = ppr ty---- Used for printing top-level strictness pragmas in interface files-pprIfaceStrictSig :: StrictSig -> SDoc-pprIfaceStrictSig (StrictSig (DmdType _ dmds res))-  = hcat (map ppr dmds) <> ppr res---- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig'--- unleashable at that arity. See Note [Understanding DmdType and StrictSig]-mkStrictSigForArity :: Arity -> DmdType -> StrictSig-mkStrictSigForArity arity dmd_ty = StrictSig (ensureArgs arity dmd_ty)--mkClosedStrictSig :: [Demand] -> Divergence -> StrictSig-mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res)--splitStrictSig :: StrictSig -> ([Demand], Divergence)-splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)--increaseStrictSigArity :: Int -> StrictSig -> StrictSig--- ^ Add extra arguments to a strictness signature.--- In contrast to 'etaExpandStrictSig', this /prepends/ additional argument--- demands and leaves CPR info intact.-increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res))-  | isTopDmdType dmd_ty = sig-  | arity_increase == 0 = sig-  | arity_increase < 0  = WARN( True, text "increaseStrictSigArity:"-                                  <+> text "negative arity increase"-                                  <+> ppr arity_increase )-                          nopSig-  | otherwise           = StrictSig (DmdType env dmds' res)-  where-    dmds' = replicate arity_increase topDmd ++ dmds--etaExpandStrictSig :: Arity -> StrictSig -> StrictSig--- ^ We are expanding (\x y. e) to (\x y z. e z).--- In contrast to 'increaseStrictSigArity', this /appends/ extra arg demands if--- necessary, potentially destroying the signature's CPR property.-etaExpandStrictSig arity (StrictSig dmd_ty)-  | arity < dmdTypeDepth dmd_ty-  -- an arity decrease must zap the whole signature, because it was possibly-  -- computed for a higher incoming call demand.-  = nopSig-  | otherwise-  = StrictSig $ ensureArgs arity dmd_ty--isTopSig :: StrictSig -> Bool-isTopSig (StrictSig ty) = isTopDmdType ty--hasDemandEnvSig :: StrictSig -> Bool-hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env)--strictSigDmdEnv :: StrictSig -> DmdEnv-strictSigDmdEnv (StrictSig (DmdType env _ _)) = env---- | True if the signature diverges or throws an exception-isBottomingSig :: StrictSig -> Bool-isBottomingSig (StrictSig (DmdType _ _ res)) = isBotDiv res--nopSig, botSig :: StrictSig-nopSig = StrictSig nopDmdType-botSig = StrictSig botDmdType--cprProdSig :: Arity -> StrictSig-cprProdSig _arity = nopSig--seqStrictSig :: StrictSig -> ()-seqStrictSig (StrictSig ty) = seqDmdType ty--dmdTransformSig :: StrictSig -> CleanDemand -> DmdType--- (dmdTransformSig fun_sig dmd) considers a call to a function whose--- signature is fun_sig, with demand dmd.  We return the demand--- that the function places on its context (eg its args)-dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd-  = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty-    -- see Note [Demands from unsaturated function calls]--dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType--- Same as dmdTransformSig but for a data constructor (worker),--- which has a special kind of demand transformer.--- If the constructor is saturated, we feed the demand on--- the result into the constructor arguments.-dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res))-                             (JD { sd = str, ud = abs })-  | Just str_dmds <- go_str arity str-  , Just abs_dmds <- go_abs arity abs-  = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res-                -- Must remember whether it's a product, hence con_res, not TopRes--  | otherwise   -- Not saturated-  = nopDmdType-  where-    go_str 0 dmd        = splitStrProdDmd arity dmd-    go_str n (SCall s') = go_str (n-1) s'-    go_str n HyperStr   = go_str (n-1) HyperStr-    go_str _ _          = Nothing--    go_abs 0 dmd            = splitUseProdDmd arity dmd-    go_abs n (UCall One u') = go_abs (n-1) u'-    go_abs _ _              = Nothing--dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType--- Like dmdTransformDataConSig, we have a special demand transformer--- for dictionary selectors.  If the selector is saturated (ie has one--- argument: the dictionary), we feed the demand on the result into--- the indicated dictionary component.-dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd-   | (cd',defer_use) <- peelCallDmd cd-   , Just jds <- splitProdDmd_maybe dict_dmd-   = postProcessUnsat defer_use $-     DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topDiv-   | otherwise-   = nopDmdType              -- See Note [Demand transformer for a dictionary selector]-  where-    enhance cd old | isAbsDmd old = old-                   | otherwise    = mkOnceUsedDmd cd  -- This is the one!--dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args"--{--Note [Demand transformer for a dictionary selector]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd'-into the appropriate field of the dictionary. What *is* the appropriate field?-We just look at the strictness signature of the class op, which will be-something like: U(AAASAAAAA).  Then replace the 'S' by the demand 'd'.--For single-method classes, which are represented by newtypes the signature-of 'op' won't look like U(...), so the splitProdDmd_maybe will fail.-That's fine: if we are doing strictness analysis we are also doing inlining,-so we'll have inlined 'op' into a cast.  So we can bale out in a conservative-way, returning nopDmdType.--It is (just.. #8329) possible to be running strictness analysis *without*-having inlined class ops from single-method classes.  Suppose you are using-ghc --make; and the first module has a local -O0 flag.  So you may load a class-without interface pragmas, ie (currently) without an unfolding for the class-ops.   Now if a subsequent module in the --make sweep has a local -O flag-you might do strictness analysis, but there is no inlining for the class op.-This is weird, so I'm not worried about whether this optimises brilliantly; but-it should not fall over.--}--argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]]--- See Note [Computing one-shot info]-argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args-  | unsaturated_call = []-  | otherwise = go arg_ds-  where-    unsaturated_call = arg_ds `lengthExceeds` n_val_args--    go []               = []-    go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds--    -- Avoid list tail like [ [], [], [] ]-    cons [] [] = []-    cons a  as = a:as---- saturatedByOneShots n C1(C1(...)) = True,---   <=>--- there are at least n nested C1(..) calls--- See Note [Demand on the worker] in WorkWrap-saturatedByOneShots :: Int -> Demand -> Bool-saturatedByOneShots n (JD { ud = usg })-  = case usg of-      Use _ arg_usg -> go n arg_usg-      _             -> False-  where-    go 0 _             = True-    go n (UCall One u) = go (n-1) u-    go _ _             = False--argOneShots :: Demand          -- depending on saturation-            -> [OneShotInfo]-argOneShots (JD { ud = usg })-  = case usg of-      Use _ arg_usg -> go arg_usg-      _             -> []-  where-    go (UCall One  u) = OneShotLam : go u-    go (UCall Many u) = NoOneShotInfo : go u-    go _              = []--{- Note [Computing one-shot info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a call-    f (\pqr. e1) (\xyz. e2) e3-where f has usage signature-    C1(C(C1(U))) C1(U) U-Then argsOneShots returns a [[OneShotInfo]] of-    [[OneShot,NoOneShotInfo,OneShot],  [OneShot]]-The occurrence analyser propagates this one-shot infor to the-binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal.--}---- | Returns true if an application to n args--- would diverge or throw an exception--- See Note [Unsaturated applications]-appIsBottom :: StrictSig -> Int -> Bool-appIsBottom (StrictSig (DmdType _ ds res)) n-            | isBotDiv res                   = not $ lengthExceeds ds n-appIsBottom _                              _ = False--{--Note [Unsaturated applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a function having bottom as its demand result is applied to a less-number of arguments than its syntactic arity, we cannot say for sure-that it is going to diverge. This is the reason why we use the-function appIsBottom, which, given a strictness signature and a number-of arguments, says conservatively if the function is going to diverge-or not.--Zap absence or one-shot information, under control of flags--Note [Killing usage information]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The flags -fkill-one-shot and -fkill-absence let you switch off the generation-of absence or one-shot information altogether.  This is only used for performance-tests, to see how important they are.--}--zapUsageEnvSig :: StrictSig -> StrictSig--- Remove the usage environment from the demand-zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r--zapUsageDemand :: Demand -> Demand--- Remove the usage info, but not the strictness info, from the demand-zapUsageDemand = kill_usage $ KillFlags-    { kf_abs         = True-    , kf_used_once   = True-    , kf_called_once = True-    }---- | Remove all 1* information (but not C1 information) from the demand-zapUsedOnceDemand :: Demand -> Demand-zapUsedOnceDemand = kill_usage $ KillFlags-    { kf_abs         = False-    , kf_used_once   = True-    , kf_called_once = False-    }---- | Remove all 1* information (but not C1 information) from the strictness---   signature-zapUsedOnceSig :: StrictSig -> StrictSig-zapUsedOnceSig (StrictSig (DmdType env ds r))-    = StrictSig (DmdType env (map zapUsedOnceDemand ds) r)--killUsageDemand :: DynFlags -> Demand -> Demand--- See Note [Killing usage information]-killUsageDemand dflags dmd-  | Just kfs <- killFlags dflags = kill_usage kfs dmd-  | otherwise                    = dmd--killUsageSig :: DynFlags -> StrictSig -> StrictSig--- See Note [Killing usage information]-killUsageSig dflags sig@(StrictSig (DmdType env ds r))-  | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (kill_usage kfs) ds) r)-  | otherwise                    = sig--data KillFlags = KillFlags-    { kf_abs         :: Bool-    , kf_used_once   :: Bool-    , kf_called_once :: Bool-    }--killFlags :: DynFlags -> Maybe KillFlags--- See Note [Killing usage information]-killFlags dflags-  | not kf_abs && not kf_used_once = Nothing-  | otherwise                      = Just (KillFlags {..})-  where-    kf_abs         = gopt Opt_KillAbsence dflags-    kf_used_once   = gopt Opt_KillOneShot dflags-    kf_called_once = kf_used_once--kill_usage :: KillFlags -> Demand -> Demand-kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u}--zap_musg :: KillFlags -> ArgUse -> ArgUse-zap_musg kfs Abs-  | kf_abs kfs = useTop-  | otherwise  = Abs-zap_musg kfs (Use c u)-  | kf_used_once kfs = Use Many (zap_usg kfs u)-  | otherwise        = Use c    (zap_usg kfs u)--zap_usg :: KillFlags -> UseDmd -> UseDmd-zap_usg kfs (UCall c u)-    | kf_called_once kfs = UCall Many (zap_usg kfs u)-    | otherwise          = UCall c    (zap_usg kfs u)-zap_usg kfs (UProd us)   = UProd (map (zap_musg kfs) us)-zap_usg _   u            = u---- If the argument is a used non-newtype dictionary, give it strict--- demand. Also split the product type & demand and recur in order to--- similarly strictify the argument's contained used non-newtype--- superclass dictionaries. We use the demand as our recursive measure--- to guarantee termination.-strictifyDictDmd :: Type -> Demand -> Demand-strictifyDictDmd ty dmd = case getUseDmd dmd of-  Use n _ |-    Just (tycon, _arg_tys, _data_con, inst_con_arg_tys)-      <- splitDataProductType_maybe ty,-    not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary-    -> seqDmd `bothDmd` -- main idea: ensure it's strict-       case splitProdDmd_maybe dmd of-         -- superclass cycles should not be a problem, since the demand we are-         -- consuming would also have to be infinite in order for us to diverge-         Nothing -> dmd -- no components have interesting demand, so stop-                        -- looking for superclass dicts-         Just dmds-           | all (not . isAbsDmd) dmds -> evalDmd-             -- abstract to strict w/ arbitrary component use, since this-             -- smells like reboxing; results in CBV boxed-             ---             -- TODO revisit this if we ever do boxity analysis-           | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of-               JD {sd = s,ud = a} -> JD (Str s) (Use n a)-             -- TODO could optimize with an aborting variant of zipWith since-             -- the superclass dicts are always a prefix-  _ -> dmd -- unused or not a dictionary--strictifyDmd :: Demand -> Demand-strictifyDmd dmd@(JD { sd = str })-  = dmd { sd = str `bothArgStr` Str HeadStr }--{--Note [HyperStr and Use demands]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The information "HyperStr" needs to be in the strictness signature, and not in-the demand signature, because we still want to know about the demand on things. Consider--    f (x,y) True  = error (show x)-    f (x,y) False = x+1--The signature of f should be <S(SL),1*U(1*U(U),A)><S,1*U>m. If we were not-distinguishing the uses on x and y in the True case, we could either not figure-out how deeply we can unpack x, or that we do not have to pass y.---************************************************************************-*                                                                      *-                     Serialisation-*                                                                      *-************************************************************************--}--instance Binary StrDmd where-  put_ bh HyperStr     = do putByte bh 0-  put_ bh HeadStr      = do putByte bh 1-  put_ bh (SCall s)    = do putByte bh 2-                            put_ bh s-  put_ bh (SProd sx)   = do putByte bh 3-                            put_ bh sx-  get bh = do-         h <- getByte bh-         case h of-           0 -> do return HyperStr-           1 -> do return HeadStr-           2 -> do s  <- get bh-                   return (SCall s)-           _ -> do sx <- get bh-                   return (SProd sx)--instance Binary ArgStr where-    put_ bh Lazy         = do-            putByte bh 0-    put_ bh (Str s)    = do-            putByte bh 1-            put_ bh s--    get  bh = do-            h <- getByte bh-            case h of-              0 -> return Lazy-              _ -> do s  <- get bh-                      return $ Str s--instance Binary Count where-    put_ bh One  = do putByte bh 0-    put_ bh Many = do putByte bh 1--    get  bh = do h <- getByte bh-                 case h of-                   0 -> return One-                   _ -> return Many--instance Binary ArgUse where-    put_ bh Abs          = do-            putByte bh 0-    put_ bh (Use c u)    = do-            putByte bh 1-            put_ bh c-            put_ bh u--    get  bh = do-            h <- getByte bh-            case h of-              0 -> return Abs-              _ -> do c  <- get bh-                      u  <- get bh-                      return $ Use c u--instance Binary UseDmd where-    put_ bh Used         = do-            putByte bh 0-    put_ bh UHead        = do-            putByte bh 1-    put_ bh (UCall c u)    = do-            putByte bh 2-            put_ bh c-            put_ bh u-    put_ bh (UProd ux)   = do-            putByte bh 3-            put_ bh ux--    get  bh = do-            h <- getByte bh-            case h of-              0 -> return $ Used-              1 -> return $ UHead-              2 -> do c <- get bh-                      u <- get bh-                      return (UCall c u)-              _ -> do ux <- get bh-                      return (UProd ux)--instance (Binary s, Binary u) => Binary (JointDmd s u) where-    put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y-    get  bh = do-              x <- get bh-              y <- get bh-              return $ JD { sd = x, ud = y }--instance Binary StrictSig where-    put_ bh (StrictSig aa) = do-            put_ bh aa-    get bh = do-          aa <- get bh-          return (StrictSig aa)--instance Binary DmdType where-  -- Ignore DmdEnv when spitting out the DmdType-  put_ bh (DmdType _ ds dr)-       = do put_ bh ds-            put_ bh dr-  get bh-      = do ds <- get bh-           dr <- get bh-           return (DmdType emptyDmdEnv ds dr)--instance Binary Divergence where-  put_ bh Dunno    = putByte bh 0-  put_ bh Diverges = putByte bh 1--  get bh = do { h <- getByte bh-              ; case h of-                  0 -> return Dunno-                  _ -> return Diverges }
− compiler/basicTypes/FieldLabel.hs 
@@ -1,130 +0,0 @@-{--%-% (c) Adam Gundry 2013-2015-%--This module defines the representation of FieldLabels as stored in-TyCons.  As well as a selector name, these have some extra structure-to support the DuplicateRecordFields extension.--In the normal case (with NoDuplicateRecordFields), a datatype like--    data T = MkT { foo :: Int }--has--    FieldLabel { flLabel        = "foo"-               , flIsOverloaded = False-               , flSelector     = foo }.--In particular, the Name of the selector has the same string-representation as the label.  If DuplicateRecordFields-is enabled, however, the same declaration instead gives--    FieldLabel { flLabel        = "foo"-               , flIsOverloaded = True-               , flSelector     = $sel:foo:MkT }.--Now the name of the selector ($sel:foo:MkT) does not match the label of-the field (foo).  We must be careful not to show the selector name to-the user!  The point of mangling the selector name is to allow a-module to define the same field label in different datatypes:--    data T = MkT { foo :: Int }-    data U = MkU { foo :: Bool }--Now there will be two FieldLabel values for 'foo', one in T and one in-U.  They share the same label (FieldLabelString), but the selector-functions differ.--See also Note [Representing fields in AvailInfo] in Avail.--Note [Why selector names include data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--As explained above, a selector name includes the name of the first-data constructor in the type, so that the same label can appear-multiple times in the same module.  (This is irrespective of whether-the first constructor has that field, for simplicity.)--We use a data constructor name, rather than the type constructor name,-because data family instances do not have a representation type-constructor name generated until relatively late in the typechecking-process.--Of course, datatypes with no constructors cannot have any fields.---}--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE StandaloneDeriving #-}--module FieldLabel ( FieldLabelString-                  , FieldLabelEnv-                  , FieldLbl(..)-                  , FieldLabel-                  , mkFieldLabelOccs-                  ) where--import GhcPrelude--import OccName-import Name--import FastString-import FastStringEnv-import Outputable-import Binary--import Data.Data---- | Field labels are just represented as strings;--- they are not necessarily unique (even within a module)-type FieldLabelString = FastString---- | A map from labels to all the auxiliary information-type FieldLabelEnv = DFastStringEnv FieldLabel---type FieldLabel = FieldLbl Name---- | Fields in an algebraic record type-data FieldLbl a = FieldLabel {-      flLabel        :: FieldLabelString, -- ^ User-visible label of the field-      flIsOverloaded :: Bool,             -- ^ Was DuplicateRecordFields on-                                          --   in the defining module for this datatype?-      flSelector     :: a                 -- ^ Record selector function-    }-  deriving (Eq, Functor, Foldable, Traversable)-deriving instance Data a => Data (FieldLbl a)--instance Outputable a => Outputable (FieldLbl a) where-    ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl))--instance Binary a => Binary (FieldLbl a) where-    put_ bh (FieldLabel aa ab ac) = do-        put_ bh aa-        put_ bh ab-        put_ bh ac-    get bh = do-        ab <- get bh-        ac <- get bh-        ad <- get bh-        return (FieldLabel ab ac ad)----- | Record selector OccNames are built from the underlying field name--- and the name of the first data constructor of the type, to support--- duplicate record field names.--- See Note [Why selector names include data constructors].-mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName-mkFieldLabelOccs lbl dc is_overloaded-  = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded-               , flSelector = sel_occ }-  where-    str     = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc-    sel_occ | is_overloaded = mkRecFldSelOcc str-            | otherwise     = mkVarOccFS lbl
− compiler/basicTypes/Id.hs 
@@ -1,970 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[Id]{@Ids@: Value and constructor identifiers}--}--{-# LANGUAGE CPP #-}---- |--- #name_types#--- GHC uses several kinds of name internally:------ * 'OccName.OccName': see "OccName#name_types"------ * 'RdrName.RdrName': see "RdrName#name_types"------ * 'Name.Name': see "Name#name_types"------ * 'Id.Id' represents names that not only have a 'Name.Name' but also a 'TyCoRep.Type' and some additional---   details (a 'IdInfo.IdInfo' and one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that---   are added, modified and inspected by various compiler passes. These 'Var.Var' names may either---   be global or local, see "Var#globalvslocal"------ * 'Var.Var': see "Var#name_types"--module Id (-        -- * The main types-        Var, Id, isId,--        -- * In and Out variants-        InVar,  InId,-        OutVar, OutId,--        -- ** Simple construction-        mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,-        mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar,-        mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId,-        mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM,-        mkUserLocal, mkUserLocalOrCoVar,-        mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,-        mkWorkerId,--        -- ** Taking an Id apart-        idName, idType, idUnique, idInfo, idDetails,-        recordSelectorTyCon,--        -- ** Modifying an Id-        setIdName, setIdUnique, Id.setIdType,-        setIdExported, setIdNotExported,-        globaliseId, localiseId,-        setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,-        zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,-        zapIdUsedOnceInfo, zapIdTailCallInfo,-        zapFragileIdInfo, zapIdStrictness, zapStableUnfolding,-        transferPolyIdInfo,--        -- ** Predicates on Ids-        isImplicitId, isDeadBinder,-        isStrictId,-        isExportedId, isLocalId, isGlobalId,-        isRecordSelector, isNaughtyRecordSelector,-        isPatSynRecordSelector,-        isDataConRecordSelector,-        isClassOpId_maybe, isDFunId,-        isPrimOpId, isPrimOpId_maybe,-        isFCallId, isFCallId_maybe,-        isDataConWorkId, isDataConWorkId_maybe,-        isDataConWrapId, isDataConWrapId_maybe,-        isDataConId_maybe,-        idDataCon,-        isConLikeId, isBottomingId, idIsFrom,-        hasNoBinding,--        -- ** Join variables-        JoinId, isJoinId, isJoinId_maybe, idJoinArity,-        asJoinId, asJoinId_maybe, zapJoinId,--        -- ** Inline pragma stuff-        idInlinePragma, setInlinePragma, modifyInlinePragma,-        idInlineActivation, setInlineActivation, idRuleMatchInfo,--        -- ** One-shot lambdas-        isOneShotBndr, isProbablyOneShotLambda,-        setOneShotLambda, clearOneShotLambda,-        updOneShotInfo, setIdOneShotInfo,-        isStateHackType, stateHackOneShot, typeOneShot,--        -- ** Reading 'IdInfo' fields-        idArity,-        idCallArity, idFunRepArity,-        idUnfolding, realIdUnfolding,-        idSpecialisation, idCoreRules, idHasRules,-        idCafInfo,-        idOneShotInfo, idStateHackOneShotInfo,-        idOccInfo,-        isNeverLevPolyId,--        -- ** Writing 'IdInfo' fields-        setIdUnfolding, setCaseBndrEvald,-        setIdArity,-        setIdCallArity,--        setIdSpecialisation,-        setIdCafInfo,-        setIdOccInfo, zapIdOccInfo,--        setIdDemandInfo,-        setIdStrictness,-        setIdCprInfo,--        idDemandInfo,-        idStrictness,-        idCprInfo,--    ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Driver.Session-import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding,-                 isCompulsoryUnfolding, Unfolding( NoUnfolding ) )--import IdInfo-import BasicTypes---- Imported and re-exported-import Var( Id, CoVar, JoinId,-            InId,  InVar,-            OutId, OutVar,-            idInfo, idDetails, setIdDetails, globaliseId, varType,-            isId, isLocalId, isGlobalId, isExportedId )-import qualified Var--import Type-import GHC.Types.RepType-import TysPrim-import DataCon-import Demand-import Cpr-import Name-import Module-import Class-import {-# SOURCE #-} PrimOp (PrimOp)-import ForeignCall-import Maybes-import SrcLoc-import Outputable-import Unique-import UniqSupply-import FastString-import Util---- infixl so you can say (id `set` a `set` b)-infixl  1 `setIdUnfolding`,-          `setIdArity`,-          `setIdCallArity`,-          `setIdOccInfo`,-          `setIdOneShotInfo`,--          `setIdSpecialisation`,-          `setInlinePragma`,-          `setInlineActivation`,-          `idCafInfo`,--          `setIdDemandInfo`,-          `setIdStrictness`,-          `setIdCprInfo`,--          `asJoinId`,-          `asJoinId_maybe`--{--************************************************************************-*                                                                      *-\subsection{Basic Id manipulation}-*                                                                      *-************************************************************************--}--idName   :: Id -> Name-idName    = Var.varName--idUnique :: Id -> Unique-idUnique  = Var.varUnique--idType   :: Id -> Kind-idType    = Var.varType--setIdName :: Id -> Name -> Id-setIdName = Var.setVarName--setIdUnique :: Id -> Unique -> Id-setIdUnique = Var.setVarUnique---- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and--- reduce space usage-setIdType :: Id -> Type -> Id-setIdType id ty = seqType ty `seq` Var.setVarType id ty--setIdExported :: Id -> Id-setIdExported = Var.setIdExported--setIdNotExported :: Id -> Id-setIdNotExported = Var.setIdNotExported--localiseId :: Id -> Id--- Make an Id with the same unique and type as the--- incoming Id, but with an *Internal* Name and *LocalId* flavour-localiseId id-  | ASSERT( isId id ) isLocalId id && isInternalName name-  = id-  | otherwise-  = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id)-  where-    name = idName id--lazySetIdInfo :: Id -> IdInfo -> Id-lazySetIdInfo = Var.lazySetIdInfo--setIdInfo :: Id -> IdInfo -> Id-setIdInfo id info = info `seq` (lazySetIdInfo id info)-        -- Try to avoid space leaks by seq'ing--modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id-modifyIdInfo fn id = setIdInfo id (fn (idInfo id))---- maybeModifyIdInfo tries to avoid unnecessary thrashing-maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id-maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info-maybeModifyIdInfo Nothing         id = id--{--************************************************************************-*                                                                      *-\subsection{Simple Id construction}-*                                                                      *-************************************************************************--Absolutely all Ids are made by mkId.  It is just like Var.mkId,-but in addition it pins free-tyvar-info onto the Id's type,-where it can easily be found.--Note [Free type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~-At one time we cached the free type variables of the type of an Id-at the root of the type in a TyNote.  The idea was to avoid repeating-the free-type-variable calculation.  But it turned out to slow down-the compiler overall. I don't quite know why; perhaps finding free-type variables of an Id isn't all that common whereas applying a-substitution (which changes the free type variables) is more common.-Anyway, we removed it in March 2008.--}---- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal"-mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id-mkGlobalId = Var.mkGlobalVar---- | Make a global 'Id' without any extra information at all-mkVanillaGlobal :: Name -> Type -> Id-mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo---- | Make a global 'Id' with no global information but some generic 'IdInfo'-mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id-mkVanillaGlobalWithInfo = mkGlobalId VanillaId----- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal"-mkLocalId :: HasDebugCallStack => Name -> Type -> Id-mkLocalId name ty = ASSERT( not (isCoVarType ty) )-                    mkLocalIdWithInfo name ty vanillaIdInfo---- | Make a local CoVar-mkLocalCoVar :: Name -> Type -> CoVar-mkLocalCoVar name ty-  = ASSERT( isCoVarType ty )-    Var.mkLocalVar CoVarId name ty vanillaIdInfo---- | Like 'mkLocalId', but checks the type to see if it should make a covar-mkLocalIdOrCoVar :: Name -> Type -> Id-mkLocalIdOrCoVar name ty-  | isCoVarType ty = mkLocalCoVar name ty-  | otherwise      = mkLocalId    name ty--    -- proper ids only; no covars!-mkLocalIdWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id-mkLocalIdWithInfo name ty info = ASSERT( not (isCoVarType ty) )-                                 Var.mkLocalVar VanillaId name ty info-        -- Note [Free type variables]---- | Create a local 'Id' that is marked as exported.--- This prevents things attached to it from being removed as dead code.--- See Note [Exported LocalIds]-mkExportedLocalId :: IdDetails -> Name -> Type -> Id-mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo-        -- Note [Free type variables]--mkExportedVanillaId :: Name -> Type -> Id-mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo-        -- Note [Free type variables]----- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal")--- that are created by the compiler out of thin air-mkSysLocal :: FastString -> Unique -> Type -> Id-mkSysLocal fs uniq ty = ASSERT( not (isCoVarType ty) )-                        mkLocalId (mkSystemVarName uniq fs) ty---- | Like 'mkSysLocal', but checks to see if we have a covar type-mkSysLocalOrCoVar :: FastString -> Unique -> Type -> Id-mkSysLocalOrCoVar fs uniq ty-  = mkLocalIdOrCoVar (mkSystemVarName uniq fs) ty--mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id-mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty))--mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id-mkSysLocalOrCoVarM fs ty-  = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty))---- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize-mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id-mkUserLocal occ uniq ty loc = ASSERT( not (isCoVarType ty) )-                              mkLocalId (mkInternalName uniq occ loc) ty---- | Like 'mkUserLocal', but checks if we have a coercion type-mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id-mkUserLocalOrCoVar occ uniq ty loc-  = mkLocalIdOrCoVar (mkInternalName uniq occ loc) ty--{--Make some local @Ids@ for a template @CoreExpr@.  These have bogus-@Uniques@, but that's OK because the templates are supposed to be-instantiated before use.--}---- | Workers get local names. "CoreTidy" will externalise these if necessary-mkWorkerId :: Unique -> Id -> Type -> Id-mkWorkerId uniq unwrkr ty-  = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty---- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings-mkTemplateLocal :: Int -> Type -> Id-mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty-   -- "OrCoVar" since this is used in a superclass selector,-   -- and "~" and "~~" have coercion "superclasses".---- | Create a template local for a series of types-mkTemplateLocals :: [Type] -> [Id]-mkTemplateLocals = mkTemplateLocalsNum 1---- | Create a template local for a series of type, but start from a specified template local-mkTemplateLocalsNum :: Int -> [Type] -> [Id]-mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys--{- Note [Exported LocalIds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-We use mkExportedLocalId for things like- - Dictionary functions (DFunId)- - Wrapper and matcher Ids for pattern synonyms- - Default methods for classes- - Pattern-synonym matcher and builder Ids- - etc--They marked as "exported" in the sense that they should be kept alive-even if apparently unused in other bindings, and not dropped as dead-code by the occurrence analyser.  (But "exported" here does not mean-"brought into lexical scope by an import declaration". Indeed these-things are always internal Ids that the user never sees.)--It's very important that they are *LocalIds*, not GlobalIds, for lots-of reasons:-- * We want to treat them as free variables for the purpose of-   dependency analysis (e.g. GHC.Core.FVs.exprFreeVars).-- * Look them up in the current substitution when we come across-   occurrences of them (in Subst.lookupIdSubst). Lacking this we-   can get an out-of-date unfolding, which can in turn make the-   simplifier go into an infinite loop (#9857)-- * Ensure that for dfuns that the specialiser does not float dict uses-   above their defns, which would prevent good simplifications happening.-- * The strictness analyser treats a occurrence of a GlobalId as-   imported and assumes it contains strictness in its IdInfo, which-   isn't true if the thing is bound in the same module as the-   occurrence.--In CoreTidy we must make all these LocalIds into GlobalIds, so that in-importing modules (in --make mode) we treat them as properly global.-That is what is happening in, say tidy_insts in GHC.Iface.Tidy.--************************************************************************-*                                                                      *-\subsection{Special Ids}-*                                                                      *-************************************************************************--}---- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise.-recordSelectorTyCon :: Id -> RecSelParent-recordSelectorTyCon id-  = case Var.idDetails id of-        RecSelId { sel_tycon = parent } -> parent-        _ -> panic "recordSelectorTyCon"---isRecordSelector        :: Id -> Bool-isNaughtyRecordSelector :: Id -> Bool-isPatSynRecordSelector  :: Id -> Bool-isDataConRecordSelector  :: Id -> Bool-isPrimOpId              :: Id -> Bool-isFCallId               :: Id -> Bool-isDataConWorkId         :: Id -> Bool-isDataConWrapId         :: Id -> Bool-isDFunId                :: Id -> Bool--isClassOpId_maybe       :: Id -> Maybe Class-isPrimOpId_maybe        :: Id -> Maybe PrimOp-isFCallId_maybe         :: Id -> Maybe ForeignCall-isDataConWorkId_maybe   :: Id -> Maybe DataCon-isDataConWrapId_maybe   :: Id -> Maybe DataCon--isRecordSelector id = case Var.idDetails id of-                        RecSelId {}     -> True-                        _               -> False--isDataConRecordSelector id = case Var.idDetails id of-                        RecSelId {sel_tycon = RecSelData _} -> True-                        _               -> False--isPatSynRecordSelector id = case Var.idDetails id of-                        RecSelId {sel_tycon = RecSelPatSyn _} -> True-                        _               -> False--isNaughtyRecordSelector id = case Var.idDetails id of-                        RecSelId { sel_naughty = n } -> n-                        _                               -> False--isClassOpId_maybe id = case Var.idDetails id of-                        ClassOpId cls -> Just cls-                        _other        -> Nothing--isPrimOpId id = case Var.idDetails id of-                        PrimOpId _ -> True-                        _          -> False--isDFunId id = case Var.idDetails id of-                        DFunId {} -> True-                        _         -> False--isPrimOpId_maybe id = case Var.idDetails id of-                        PrimOpId op -> Just op-                        _           -> Nothing--isFCallId id = case Var.idDetails id of-                        FCallId _ -> True-                        _         -> False--isFCallId_maybe id = case Var.idDetails id of-                        FCallId call -> Just call-                        _            -> Nothing--isDataConWorkId id = case Var.idDetails id of-                        DataConWorkId _ -> True-                        _               -> False--isDataConWorkId_maybe id = case Var.idDetails id of-                        DataConWorkId con -> Just con-                        _                 -> Nothing--isDataConWrapId id = case Var.idDetails id of-                       DataConWrapId _ -> True-                       _               -> False--isDataConWrapId_maybe id = case Var.idDetails id of-                        DataConWrapId con -> Just con-                        _                 -> Nothing--isDataConId_maybe :: Id -> Maybe DataCon-isDataConId_maybe id = case Var.idDetails id of-                         DataConWorkId con -> Just con-                         DataConWrapId con -> Just con-                         _                 -> Nothing--isJoinId :: Var -> Bool--- It is convenient in SetLevels.lvlMFE to apply isJoinId--- to the free vars of an expression, so it's convenient--- if it returns False for type variables-isJoinId id-  | isId id = case Var.idDetails id of-                JoinId {} -> True-                _         -> False-  | otherwise = False--isJoinId_maybe :: Var -> Maybe JoinArity-isJoinId_maybe id- | isId id  = ASSERT2( isId id, ppr id )-              case Var.idDetails id of-                JoinId arity -> Just arity-                _            -> Nothing- | otherwise = Nothing--idDataCon :: Id -> DataCon--- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer.------ INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker-idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id)--hasNoBinding :: Id -> Bool--- ^ Returns @True@ of an 'Id' which may not have a--- binding, even though it is defined in this module.---- Data constructor workers used to be things of this kind, but--- they aren't any more.  Instead, we inject a binding for--- them at the CorePrep stage.------ 'PrimOpId's also used to be of this kind. See Note [Primop wrappers] in PrimOp.hs.--- for the history of this.------ Note that CorePrep currently eta expands things no-binding things and this--- can cause quite subtle bugs. See Note [Eta expansion of hasNoBinding things--- in CorePrep] in CorePrep for details.------ EXCEPT: unboxed tuples, which definitely have no binding-hasNoBinding id = case Var.idDetails id of-                        PrimOpId _       -> False   -- See Note [Primop wrappers] in PrimOp.hs-                        FCallId _        -> True-                        DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc-                        _                -> isCompulsoryUnfolding (idUnfolding id)-                                            -- See Note [Levity-polymorphic Ids]--isImplicitId :: Id -> Bool--- ^ 'isImplicitId' tells whether an 'Id's info is implied by other--- declarations, so we don't need to put its signature in an interface--- file, even if it's mentioned in some other interface unfolding.-isImplicitId id-  = case Var.idDetails id of-        FCallId {}       -> True-        ClassOpId {}     -> True-        PrimOpId {}      -> True-        DataConWorkId {} -> True-        DataConWrapId {} -> True-                -- These are implied by their type or class decl;-                -- remember that all type and class decls appear in the interface file.-                -- The dfun id is not an implicit Id; it must *not* be omitted, because-                -- it carries version info for the instance decl-        _               -> False--idIsFrom :: Module -> Id -> Bool-idIsFrom mod id = nameIsLocalOrFrom mod (idName id)--{- Note [Levity-polymorphic Ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Some levity-polymorphic Ids must be applied and inlined, not left-un-saturated.  Example:-  unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b--This has a compulsory unfolding because we can't lambda-bind those-arguments.  But the compulsory unfolding may leave levity-polymorphic-lambdas if it is not applied to enough arguments; e.g. (#14561)-  bad :: forall (a :: TYPE r). a -> a-  bad = unsafeCoerce#--The desugar has special magic to detect such cases: GHC.HsToCore.Expr.badUseOfLevPolyPrimop.-And we want that magic to apply to levity-polymorphic compulsory-inline things.-The easiest way to do this is for hasNoBinding to return True of all things-that have compulsory unfolding.  Some Ids with a compulsory unfolding also-have a binding, but it does not harm to say they don't here, and its a very-simple way to fix #14561.--}--isDeadBinder :: Id -> Bool-isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)-                  | otherwise = False   -- TyVars count as not dead--{--************************************************************************-*                                                                      *-              Join variables-*                                                                      *-************************************************************************--}--idJoinArity :: JoinId -> JoinArity-idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id)--asJoinId :: Id -> JoinArity -> JoinId-asJoinId id arity = WARN(not (isLocalId id),-                         text "global id being marked as join var:" <+> ppr id)-                    WARN(not (is_vanilla_or_join id),-                         ppr id <+> pprIdDetails (idDetails id))-                    id `setIdDetails` JoinId arity-  where-    is_vanilla_or_join id = case Var.idDetails id of-                              VanillaId -> True-                              JoinId {} -> True-                              _         -> False--zapJoinId :: Id -> Id--- May be a regular id already-zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId)-                                 -- Core Lint may complain if still marked-                                 -- as AlwaysTailCalled-              | otherwise    = jid--asJoinId_maybe :: Id -> Maybe JoinArity -> Id-asJoinId_maybe id (Just arity) = asJoinId id arity-asJoinId_maybe id Nothing      = zapJoinId id--{--************************************************************************-*                                                                      *-\subsection{IdInfo stuff}-*                                                                      *-************************************************************************--}--        ----------------------------------        -- ARITY-idArity :: Id -> Arity-idArity id = arityInfo (idInfo id)--setIdArity :: Id -> Arity -> Id-setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id--idCallArity :: Id -> Arity-idCallArity id = callArityInfo (idInfo id)--setIdCallArity :: Id -> Arity -> Id-setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id--idFunRepArity :: Id -> RepArity-idFunRepArity x = countFunRepArgs (idArity x) (idType x)---- | Returns true if an application to n args would diverge-isBottomingId :: Var -> Bool-isBottomingId v-  | isId v    = isBottomingSig (idStrictness v)-  | otherwise = False---- | Accesses the 'Id''s 'strictnessInfo'.-idStrictness :: Id -> StrictSig-idStrictness id = strictnessInfo (idInfo id)--setIdStrictness :: Id -> StrictSig -> Id-setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id--idCprInfo :: Id -> CprSig-idCprInfo id = cprInfo (idInfo id)--setIdCprInfo :: Id -> CprSig -> Id-setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id--zapIdStrictness :: Id -> Id-zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id---- | This predicate says whether the 'Id' has a strict demand placed on it or--- has a type such that it can always be evaluated strictly (i.e an--- unlifted type, as of GHC 7.6).  We need to--- check separately whether the 'Id' has a so-called \"strict type\" because if--- the demand for the given @id@ hasn't been computed yet but @id@ has a strict--- type, we still want @isStrictId id@ to be @True@.-isStrictId :: Id -> Bool-isStrictId id-  = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )-         not (isJoinId id) && (-           (isStrictType (idType id)) ||-           -- Take the best of both strictnesses - old and new-           (isStrictDmd (idDemandInfo id))-         )--        ----------------------------------        -- UNFOLDING-idUnfolding :: Id -> Unfolding--- Do not expose the unfolding of a loop breaker!-idUnfolding id-  | isStrongLoopBreaker (occInfo info) = NoUnfolding-  | otherwise                          = unfoldingInfo info-  where-    info = idInfo id--realIdUnfolding :: Id -> Unfolding--- Expose the unfolding if there is one, including for loop breakers-realIdUnfolding id = unfoldingInfo (idInfo id)--setIdUnfolding :: Id -> Unfolding -> Id-setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id--idDemandInfo       :: Id -> Demand-idDemandInfo       id = demandInfo (idInfo id)--setIdDemandInfo :: Id -> Demand -> Id-setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id--setCaseBndrEvald :: StrictnessMark -> Id -> Id--- Used for variables bound by a case expressions, both the case-binder--- itself, and any pattern-bound variables that are argument of a--- strict constructor.  It just marks the variable as already-evaluated,--- so that (for example) a subsequent 'seq' can be dropped-setCaseBndrEvald str id-  | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding-  | otherwise          = id--        ----------------------------------        -- SPECIALISATION---- See Note [Specialisations and RULES in IdInfo] in IdInfo.hs--idSpecialisation :: Id -> RuleInfo-idSpecialisation id = ruleInfo (idInfo id)--idCoreRules :: Id -> [CoreRule]-idCoreRules id = ruleInfoRules (idSpecialisation id)--idHasRules :: Id -> Bool-idHasRules id = not (isEmptyRuleInfo (idSpecialisation id))--setIdSpecialisation :: Id -> RuleInfo -> Id-setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id--        ----------------------------------        -- CAF INFO-idCafInfo :: Id -> CafInfo-idCafInfo id = cafInfo (idInfo id)--setIdCafInfo :: Id -> CafInfo -> Id-setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id--        ----------------------------------        -- Occurrence INFO-idOccInfo :: Id -> OccInfo-idOccInfo id = occInfo (idInfo id)--setIdOccInfo :: Id -> OccInfo -> Id-setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id--zapIdOccInfo :: Id -> Id-zapIdOccInfo b = b `setIdOccInfo` noOccInfo--{--        ----------------------------------        -- INLINING-The inline pragma tells us to be very keen to inline this Id, but it's still-OK not to if optimisation is switched off.--}--idInlinePragma :: Id -> InlinePragma-idInlinePragma id = inlinePragInfo (idInfo id)--setInlinePragma :: Id -> InlinePragma -> Id-setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id--modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id-modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id--idInlineActivation :: Id -> Activation-idInlineActivation id = inlinePragmaActivation (idInlinePragma id)--setInlineActivation :: Id -> Activation -> Id-setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act)--idRuleMatchInfo :: Id -> RuleMatchInfo-idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id)--isConLikeId :: Id -> Bool-isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id)--{--        ----------------------------------        -- ONE-SHOT LAMBDAS--}--idOneShotInfo :: Id -> OneShotInfo-idOneShotInfo id = oneShotInfo (idInfo id)---- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account--- See Note [The state-transformer hack] in GHC.Core.Arity-idStateHackOneShotInfo :: Id -> OneShotInfo-idStateHackOneShotInfo id-    | isStateHackType (idType id) = stateHackOneShot-    | otherwise                   = idOneShotInfo id---- | Returns whether the lambda associated with the 'Id' is certainly applied at most once--- This one is the "business end", called externally.--- It works on type variables as well as Ids, returning True--- Its main purpose is to encapsulate the Horrible State Hack--- See Note [The state-transformer hack] in GHC.Core.Arity-isOneShotBndr :: Var -> Bool-isOneShotBndr var-  | isTyVar var                              = True-  | OneShotLam <- idStateHackOneShotInfo var = True-  | otherwise                                = False---- | Should we apply the state hack to values of this 'Type'?-stateHackOneShot :: OneShotInfo-stateHackOneShot = OneShotLam--typeOneShot :: Type -> OneShotInfo-typeOneShot ty-   | isStateHackType ty = stateHackOneShot-   | otherwise          = NoOneShotInfo--isStateHackType :: Type -> Bool-isStateHackType ty-  | hasNoStateHack unsafeGlobalDynFlags-  = False-  | otherwise-  = case tyConAppTyCon_maybe ty of-        Just tycon -> tycon == statePrimTyCon-        _          -> False-        -- This is a gross hack.  It claims that-        -- every function over realWorldStatePrimTy is a one-shot-        -- function.  This is pretty true in practice, and makes a big-        -- difference.  For example, consider-        --      a `thenST` \ r -> ...E...-        -- The early full laziness pass, if it doesn't know that r is one-shot-        -- will pull out E (let's say it doesn't mention r) to give-        --      let lvl = E in a `thenST` \ r -> ...lvl...-        -- When `thenST` gets inlined, we end up with-        --      let lvl = E in \s -> case a s of (r, s') -> ...lvl...-        -- and we don't re-inline E.-        ---        -- It would be better to spot that r was one-shot to start with, but-        -- I don't want to rely on that.-        ---        -- Another good example is in fill_in in PrelPack.hs.  We should be able to-        -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.--isProbablyOneShotLambda :: Id -> Bool-isProbablyOneShotLambda id = case idStateHackOneShotInfo id of-                               OneShotLam    -> True-                               NoOneShotInfo -> False--setOneShotLambda :: Id -> Id-setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id--clearOneShotLambda :: Id -> Id-clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id--setIdOneShotInfo :: Id -> OneShotInfo -> Id-setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id--updOneShotInfo :: Id -> OneShotInfo -> Id--- Combine the info in the Id with new info-updOneShotInfo id one_shot-  | do_upd    = setIdOneShotInfo id one_shot-  | otherwise = id-  where-    do_upd = case (idOneShotInfo id, one_shot) of-                (NoOneShotInfo, _) -> True-                (OneShotLam,    _) -> False---- The OneShotLambda functions simply fiddle with the IdInfo flag--- But watch out: this may change the type of something else---      f = \x -> e--- If we change the one-shot-ness of x, f's type changes--zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id-zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id--zapLamIdInfo :: Id -> Id-zapLamIdInfo = zapInfo zapLamInfo--zapFragileIdInfo :: Id -> Id-zapFragileIdInfo = zapInfo zapFragileInfo--zapIdDemandInfo :: Id -> Id-zapIdDemandInfo = zapInfo zapDemandInfo--zapIdUsageInfo :: Id -> Id-zapIdUsageInfo = zapInfo zapUsageInfo--zapIdUsageEnvInfo :: Id -> Id-zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo--zapIdUsedOnceInfo :: Id -> Id-zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo--zapIdTailCallInfo :: Id -> Id-zapIdTailCallInfo = zapInfo zapTailCallInfo--zapStableUnfolding :: Id -> Id-zapStableUnfolding id- | isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding- | otherwise                              = id--{--Note [transferPolyIdInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~-This transfer is used in three places:-        FloatOut (long-distance let-floating)-        SimplUtils.abstractFloats (short-distance let-floating)-        StgLiftLams (selectively lambda-lift local functions to top-level)--Consider the short-distance let-floating:--   f = /\a. let g = rhs in ...--Then if we float thus--   g' = /\a. rhs-   f = /\a. ...[g' a/g]....--we *do not* want to lose g's-  * strictness information-  * arity-  * inline pragma (though that is bit more debatable)-  * occurrence info--Mostly this is just an optimisation, but it's *vital* to-transfer the occurrence info.  Consider--   NonRec { f = /\a. let Rec { g* = ..g.. } in ... }--where the '*' means 'LoopBreaker'.  Then if we float we must get--   Rec { g'* = /\a. ...(g' a)... }-   NonRec { f = /\a. ...[g' a/g]....}--where g' is also marked as LoopBreaker.  If not, terrible things-can happen if we re-simplify the binding (and the Simplifier does-sometimes simplify a term twice); see #4345.--It's not so simple to retain-  * worker info-  * rules-so we simply discard those.  Sooner or later this may bite us.--If we abstract wrt one or more *value* binders, we must modify the-arity and strictness info before transferring it.  E.g.-      f = \x. e--->-      g' = \y. \x. e-      + substitute (g' y) for g-Notice that g' has an arity one more than the original g--}--transferPolyIdInfo :: Id        -- Original Id-                   -> [Var]     -- Abstract wrt these variables-                   -> Id        -- New Id-                   -> Id-transferPolyIdInfo old_id abstract_wrt new_id-  = modifyIdInfo transfer new_id-  where-    arity_increase = count isId abstract_wrt    -- Arity increases by the-                                                -- number of value binders--    old_info        = idInfo old_id-    old_arity       = arityInfo old_info-    old_inline_prag = inlinePragInfo old_info-    old_occ_info    = occInfo old_info-    new_arity       = old_arity + arity_increase-    new_occ_info    = zapOccTailCallInfo old_occ_info--    old_strictness  = strictnessInfo old_info-    new_strictness  = increaseStrictSigArity arity_increase old_strictness-    old_cpr         = cprInfo old_info--    transfer new_info = new_info `setArityInfo` new_arity-                                 `setInlinePragInfo` old_inline_prag-                                 `setOccInfo` new_occ_info-                                 `setStrictnessInfo` new_strictness-                                 `setCprInfo` old_cpr--isNeverLevPolyId :: Id -> Bool-isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo
− compiler/basicTypes/IdInfo.hs 
@@ -1,652 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1993-1998--\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@}--(And a pretty good illustration of quite a few things wrong with-Haskell. [WDP 94/11])--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--module IdInfo (-        -- * The IdDetails type-        IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails,-        JoinArity, isJoinIdDetails_maybe,-        RecSelParent(..),--        -- * The IdInfo type-        IdInfo,         -- Abstract-        vanillaIdInfo, noCafIdInfo,--        -- ** The OneShotInfo type-        OneShotInfo(..),-        oneShotInfo, noOneShotInfo, hasNoOneShotInfo,-        setOneShotInfo,--        -- ** Zapping various forms of Info-        zapLamInfo, zapFragileInfo,-        zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,-        zapTailCallInfo, zapCallArityInfo, zapUnfolding,--        -- ** The ArityInfo type-        ArityInfo,-        unknownArity,-        arityInfo, setArityInfo, ppArityInfo,--        callArityInfo, setCallArityInfo,--        -- ** Demand and strictness Info-        strictnessInfo, setStrictnessInfo,-        cprInfo, setCprInfo,-        demandInfo, setDemandInfo, pprStrictness,--        -- ** Unfolding Info-        unfoldingInfo, setUnfoldingInfo,--        -- ** The InlinePragInfo type-        InlinePragInfo,-        inlinePragInfo, setInlinePragInfo,--        -- ** The OccInfo type-        OccInfo(..),-        isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker,-        occInfo, setOccInfo,--        InsideLam(..), OneBranch(..),--        TailCallInfo(..),-        tailCallInfo, isAlwaysTailCalled,--        -- ** The RuleInfo type-        RuleInfo(..),-        emptyRuleInfo,-        isEmptyRuleInfo, ruleInfoFreeVars,-        ruleInfoRules, setRuleInfoHead,-        ruleInfo, setRuleInfo,--        -- ** The CAFInfo type-        CafInfo(..),-        ppCafInfo, mayHaveCafRefs,-        cafInfo, setCafInfo,--        -- ** Tick-box Info-        TickBoxOp(..), TickBoxId,--        -- ** Levity info-        LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType,-        isNeverLevPolyIdInfo-    ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Core--import Class-import {-# SOURCE #-} PrimOp (PrimOp)-import Name-import VarSet-import BasicTypes-import DataCon-import TyCon-import PatSyn-import Type-import ForeignCall-import Outputable-import Module-import Demand-import Cpr-import Util---- infixl so you can say (id `set` a `set` b)-infixl  1 `setRuleInfo`,-          `setArityInfo`,-          `setInlinePragInfo`,-          `setUnfoldingInfo`,-          `setOneShotInfo`,-          `setOccInfo`,-          `setCafInfo`,-          `setStrictnessInfo`,-          `setCprInfo`,-          `setDemandInfo`,-          `setNeverLevPoly`,-          `setLevityInfoWithType`--{--************************************************************************-*                                                                      *-                     IdDetails-*                                                                      *-************************************************************************--}---- | Identifier Details------ The 'IdDetails' of an 'Id' give stable, and necessary,--- information about the Id.-data IdDetails-  = VanillaId--  -- | The 'Id' for a record selector-  | RecSelId-    { sel_tycon   :: RecSelParent-    , sel_naughty :: Bool       -- True <=> a "naughty" selector which can't actually exist, for example @x@ in:-                                --    data T = forall a. MkT { x :: a }-    }                           -- See Note [Naughty record selectors] in TcTyClsDecls--  | DataConWorkId DataCon       -- ^ The 'Id' is for a data constructor /worker/-  | DataConWrapId DataCon       -- ^ The 'Id' is for a data constructor /wrapper/--                                -- [the only reasons we need to know is so that-                                --  a) to support isImplicitId-                                --  b) when desugaring a RecordCon we can get-                                --     from the Id back to the data con]-  | ClassOpId Class             -- ^ The 'Id' is a superclass selector,-                                -- or class operation of a class--  | PrimOpId PrimOp             -- ^ The 'Id' is for a primitive operator-  | FCallId ForeignCall         -- ^ The 'Id' is for a foreign call.-                                -- Type will be simple: no type families, newtypes, etc--  | TickBoxOpId TickBoxOp       -- ^ The 'Id' is for a HPC tick box (both traditional and binary)--  | DFunId Bool                 -- ^ A dictionary function.-       -- Bool = True <=> the class has only one method, so may be-       --                  implemented with a newtype, so it might be bad-       --                  to be strict on this dictionary--  | CoVarId    -- ^ A coercion variable-               -- This only covers /un-lifted/ coercions, of type-               -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants-  | JoinId JoinArity           -- ^ An 'Id' for a join point taking n arguments-       -- Note [Join points] in GHC.Core---- | Recursive Selector Parent-data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq-  -- Either `TyCon` or `PatSyn` depending-  -- on the origin of the record selector.-  -- For a data type family, this is the-  -- /instance/ 'TyCon' not the family 'TyCon'--instance Outputable RecSelParent where-  ppr p = case p of-            RecSelData ty_con -> ppr ty_con-            RecSelPatSyn ps   -> ppr ps---- | Just a synonym for 'CoVarId'. Written separately so it can be--- exported in the hs-boot file.-coVarDetails :: IdDetails-coVarDetails = CoVarId---- | Check if an 'IdDetails' says 'CoVarId'.-isCoVarDetails :: IdDetails -> Bool-isCoVarDetails CoVarId = True-isCoVarDetails _       = False--isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity-isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity-isJoinIdDetails_maybe _                   = Nothing--instance Outputable IdDetails where-    ppr = pprIdDetails--pprIdDetails :: IdDetails -> SDoc-pprIdDetails VanillaId = empty-pprIdDetails other     = brackets (pp other)- where-   pp VanillaId               = panic "pprIdDetails"-   pp (DataConWorkId _)       = text "DataCon"-   pp (DataConWrapId _)       = text "DataConWrapper"-   pp (ClassOpId {})          = text "ClassOp"-   pp (PrimOpId _)            = text "PrimOp"-   pp (FCallId _)             = text "ForeignCall"-   pp (TickBoxOpId _)         = text "TickBoxOp"-   pp (DFunId nt)             = text "DFunId" <> ppWhen nt (text "(nt)")-   pp (RecSelId { sel_naughty = is_naughty })-                              = brackets $ text "RecSel" <>-                                           ppWhen is_naughty (text "(naughty)")-   pp CoVarId                 = text "CoVarId"-   pp (JoinId arity)          = text "JoinId" <> parens (int arity)--{--************************************************************************-*                                                                      *-\subsection{The main IdInfo type}-*                                                                      *-************************************************************************--}---- | Identifier Information------ An 'IdInfo' gives /optional/ information about an 'Id'.  If--- present it never lies, but it may not be present, in which case there--- is always a conservative assumption which can be made.------ Two 'Id's may have different info even though they have the same--- 'Unique' (and are hence the same 'Id'); for example, one might lack--- the properties attached to the other.------ Most of the 'IdInfo' gives information about the value, or definition, of--- the 'Id', independent of its usage. Exceptions to this--- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'.------ Performance note: when we update 'IdInfo', we have to reallocate this--- entire record, so it is a good idea not to let this data structure get--- too big.-data IdInfo-  = IdInfo {-        arityInfo       :: !ArityInfo,-        -- ^ 'Id' arity, as computed by 'GHC.Core.Arity'. Specifies how many-        -- arguments this 'Id' has to be applied to before it doesn any-        -- meaningful work.-        ruleInfo        :: RuleInfo,-        -- ^ Specialisations of the 'Id's function which exist.-        -- See Note [Specialisations and RULES in IdInfo]-        unfoldingInfo   :: Unfolding,-        -- ^ The 'Id's unfolding-        cafInfo         :: CafInfo,-        -- ^ 'Id' CAF info-        oneShotInfo     :: OneShotInfo,-        -- ^ Info about a lambda-bound variable, if the 'Id' is one-        inlinePragInfo  :: InlinePragma,-        -- ^ Any inline pragma attached to the 'Id'-        occInfo         :: OccInfo,-        -- ^ How the 'Id' occurs in the program-        strictnessInfo  :: StrictSig,-        -- ^ A strictness signature. Digests how a function uses its arguments-        -- if applied to at least 'arityInfo' arguments.-        cprInfo         :: CprSig,-        -- ^ Information on whether the function will ultimately return a-        -- freshly allocated constructor.-        demandInfo      :: Demand,-        -- ^ ID demand information-        callArityInfo   :: !ArityInfo,-        -- ^ How this is called. This is the number of arguments to which a-        -- binding can be eta-expanded without losing any sharing.-        -- n <=> all calls have at least n arguments-        levityInfo      :: LevityInfo-        -- ^ when applied, will this Id ever have a levity-polymorphic type?-    }---- Setters--setRuleInfo :: IdInfo -> RuleInfo -> IdInfo-setRuleInfo       info sp = sp `seq` info { ruleInfo = sp }-setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo-setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }-setOccInfo :: IdInfo -> OccInfo -> IdInfo-setOccInfo        info oc = oc `seq` info { occInfo = oc }-        -- Try to avoid space leaks by seq'ing--setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo-setUnfoldingInfo info uf-  = -- We don't seq the unfolding, as we generate intermediate-    -- unfoldings which are just thrown away, so evaluating them is a-    -- waste of time.-    -- seqUnfolding uf `seq`-    info { unfoldingInfo = uf }--setArityInfo :: IdInfo -> ArityInfo -> IdInfo-setArityInfo      info ar  = info { arityInfo = ar  }-setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo-setCallArityInfo info ar  = info { callArityInfo = ar  }-setCafInfo :: IdInfo -> CafInfo -> IdInfo-setCafInfo        info caf = info { cafInfo = caf }--setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo-setOneShotInfo      info lb = {-lb `seq`-} info { oneShotInfo = lb }--setDemandInfo :: IdInfo -> Demand -> IdInfo-setDemandInfo info dd = dd `seq` info { demandInfo = dd }--setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo-setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd }--setCprInfo :: IdInfo -> CprSig -> IdInfo-setCprInfo info cpr = cpr `seq` info { cprInfo = cpr }---- | Basic 'IdInfo' that carries no useful information whatsoever-vanillaIdInfo :: IdInfo-vanillaIdInfo-  = IdInfo {-            cafInfo             = vanillaCafInfo,-            arityInfo           = unknownArity,-            ruleInfo            = emptyRuleInfo,-            unfoldingInfo       = noUnfolding,-            oneShotInfo         = NoOneShotInfo,-            inlinePragInfo      = defaultInlinePragma,-            occInfo             = noOccInfo,-            demandInfo          = topDmd,-            strictnessInfo      = nopSig,-            cprInfo             = topCprSig,-            callArityInfo       = unknownArity,-            levityInfo          = NoLevityInfo-           }---- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references-noCafIdInfo :: IdInfo-noCafIdInfo  = vanillaIdInfo `setCafInfo`    NoCafRefs-        -- Used for built-in type Ids in MkId.--{--************************************************************************-*                                                                      *-\subsection[arity-IdInfo]{Arity info about an @Id@}-*                                                                      *-************************************************************************--For locally-defined Ids, the code generator maintains its own notion-of their arities; so it should not be asking...  (but other things-besides the code-generator need arity info!)--}---- | Arity Information------ An 'ArityInfo' of @n@ tells us that partial application of this--- 'Id' to up to @n-1@ value arguments does essentially no work.------ That is not necessarily the same as saying that it has @n@ leading--- lambdas, because coerces may get in the way.------ The arity might increase later in the compilation process, if--- an extra lambda floats up to the binding site.-type ArityInfo = Arity---- | It is always safe to assume that an 'Id' has an arity of 0-unknownArity :: Arity-unknownArity = 0--ppArityInfo :: Int -> SDoc-ppArityInfo 0 = empty-ppArityInfo n = hsep [text "Arity", int n]--{--************************************************************************-*                                                                      *-\subsection{Inline-pragma information}-*                                                                      *-************************************************************************--}---- | Inline Pragma Information------ Tells when the inlining is active.--- When it is active the thing may be inlined, depending on how--- big it is.------ If there was an @INLINE@ pragma, then as a separate matter, the--- RHS will have been made to look small with a Core inline 'Note'------ The default 'InlinePragInfo' is 'AlwaysActive', so the info serves--- entirely as a way to inhibit inlining until we want it-type InlinePragInfo = InlinePragma--{--************************************************************************-*                                                                      *-               Strictness-*                                                                      *-************************************************************************--}--pprStrictness :: StrictSig -> SDoc-pprStrictness sig = ppr sig--{--************************************************************************-*                                                                      *-        RuleInfo-*                                                                      *-************************************************************************--Note [Specialisations and RULES in IdInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Generally speaking, a GlobalId has an *empty* RuleInfo.  All their-RULES are contained in the globally-built rule-base.  In principle,-one could attach the to M.f the RULES for M.f that are defined in M.-But we don't do that for instance declarations and so we just treat-them all uniformly.--The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is-just for convenience really.--However, LocalIds may have non-empty RuleInfo.  We treat them-differently because:-  a) they might be nested, in which case a global table won't work-  b) the RULE might mention free variables, which we use to keep things alive--In GHC.Iface.Tidy, when the LocalId becomes a GlobalId, its RULES are stripped off-and put in the global list.--}---- | Rule Information------ Records the specializations of this 'Id' that we know about--- in the form of rewrite 'CoreRule's that target them-data RuleInfo-  = RuleInfo-        [CoreRule]-        DVarSet         -- Locally-defined free vars of *both* LHS and RHS-                        -- of rules.  I don't think it needs to include the-                        -- ru_fn though.-                        -- Note [Rule dependency info] in OccurAnal---- | Assume that no specializations exist: always safe-emptyRuleInfo :: RuleInfo-emptyRuleInfo = RuleInfo [] emptyDVarSet--isEmptyRuleInfo :: RuleInfo -> Bool-isEmptyRuleInfo (RuleInfo rs _) = null rs---- | Retrieve the locally-defined free variables of both the left and--- right hand sides of the specialization rules-ruleInfoFreeVars :: RuleInfo -> DVarSet-ruleInfoFreeVars (RuleInfo _ fvs) = fvs--ruleInfoRules :: RuleInfo -> [CoreRule]-ruleInfoRules (RuleInfo rules _) = rules---- | Change the name of the function the rule is keyed on on all of the 'CoreRule's-setRuleInfoHead :: Name -> RuleInfo -> RuleInfo-setRuleInfoHead fn (RuleInfo rules fvs)-  = RuleInfo (map (setRuleIdName fn) rules) fvs--{--************************************************************************-*                                                                      *-\subsection[CG-IdInfo]{Code generator-related information}-*                                                                      *-************************************************************************--}---- CafInfo is used to build Static Reference Tables (see simplStg/SRT.hs).---- | Constant applicative form Information------ Records whether an 'Id' makes Constant Applicative Form references-data CafInfo-        = MayHaveCafRefs                -- ^ Indicates that the 'Id' is for either:-                                        ---                                        -- 1. A function or static constructor-                                        --    that refers to one or more CAFs, or-                                        ---                                        -- 2. A real live CAF--        | NoCafRefs                     -- ^ A function or static constructor-                                        -- that refers to no CAFs.-        deriving (Eq, Ord)---- | Assumes that the 'Id' has CAF references: definitely safe-vanillaCafInfo :: CafInfo-vanillaCafInfo = MayHaveCafRefs--mayHaveCafRefs :: CafInfo -> Bool-mayHaveCafRefs  MayHaveCafRefs = True-mayHaveCafRefs _               = False--instance Outputable CafInfo where-   ppr = ppCafInfo--ppCafInfo :: CafInfo -> SDoc-ppCafInfo NoCafRefs = text "NoCafRefs"-ppCafInfo MayHaveCafRefs = empty--{--************************************************************************-*                                                                      *-\subsection{Bulk operations on IdInfo}-*                                                                      *-************************************************************************--}---- | This is used to remove information on lambda binders that we have--- setup as part of a lambda group, assuming they will be applied all at once,--- but turn out to be part of an unsaturated lambda as in e.g:------ > (\x1. \x2. e) arg1-zapLamInfo :: IdInfo -> Maybe IdInfo-zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})-  | is_safe_occ occ && is_safe_dmd demand-  = Nothing-  | otherwise-  = Just (info {occInfo = safe_occ, demandInfo = topDmd})-  where-        -- The "unsafe" occ info is the ones that say I'm not in a lambda-        -- because that might not be true for an unsaturated lambda-    is_safe_occ occ | isAlwaysTailCalled occ           = False-    is_safe_occ (OneOcc { occ_in_lam = NotInsideLam }) = False-    is_safe_occ _other                                 = True--    safe_occ = case occ of-                 OneOcc{} -> occ { occ_in_lam = IsInsideLam-                                 , occ_tail   = NoTailCallInfo }-                 IAmALoopBreaker{}-                          -> occ { occ_tail   = NoTailCallInfo }-                 _other   -> occ--    is_safe_dmd dmd = not (isStrictDmd dmd)---- | Remove all demand info on the 'IdInfo'-zapDemandInfo :: IdInfo -> Maybe IdInfo-zapDemandInfo info = Just (info {demandInfo = topDmd})---- | Remove usage (but not strictness) info on the 'IdInfo'-zapUsageInfo :: IdInfo -> Maybe IdInfo-zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)})---- | Remove usage environment info from the strictness signature on the 'IdInfo'-zapUsageEnvInfo :: IdInfo -> Maybe IdInfo-zapUsageEnvInfo info-    | hasDemandEnvSig (strictnessInfo info)-    = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)})-    | otherwise-    = Nothing--zapUsedOnceInfo :: IdInfo -> Maybe IdInfo-zapUsedOnceInfo info-    = Just $ info { strictnessInfo = zapUsedOnceSig    (strictnessInfo info)-                  , demandInfo     = zapUsedOnceDemand (demandInfo     info) }--zapFragileInfo :: IdInfo -> Maybe IdInfo--- ^ Zap info that depends on free variables-zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf })-  = new_unf `seq`  -- The unfolding field is not (currently) strict, so we-                   -- force it here to avoid a (zapFragileUnfolding unf) thunk-                   -- which might leak space-    Just (info `setRuleInfo` emptyRuleInfo-               `setUnfoldingInfo` new_unf-               `setOccInfo`       zapFragileOcc occ)-  where-    new_unf = zapFragileUnfolding unf--zapFragileUnfolding :: Unfolding -> Unfolding-zapFragileUnfolding unf- | isFragileUnfolding unf = noUnfolding- | otherwise              = unf--zapUnfolding :: Unfolding -> Unfolding--- Squash all unfolding info, preserving only evaluated-ness-zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding-                 | otherwise            = noUnfolding--zapTailCallInfo :: IdInfo -> Maybe IdInfo-zapTailCallInfo info-  = case occInfo info of-      occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ)-          | otherwise              -> Nothing-        where-          safe_occ = occ { occ_tail = NoTailCallInfo }--zapCallArityInfo :: IdInfo -> IdInfo-zapCallArityInfo info = setCallArityInfo info 0--{--************************************************************************-*                                                                      *-\subsection{TickBoxOp}-*                                                                      *-************************************************************************--}--type TickBoxId = Int---- | Tick box for Hpc-style coverage-data TickBoxOp-   = TickBox Module {-# UNPACK #-} !TickBoxId--instance Outputable TickBoxOp where-    ppr (TickBox mod n)         = text "tick" <+> ppr (mod,n)--{--************************************************************************-*                                                                      *-   Levity-*                                                                      *-************************************************************************--Note [Levity info]-~~~~~~~~~~~~~~~~~~--Ids store whether or not they can be levity-polymorphic at any amount-of saturation. This is helpful in optimizing the levity-polymorphism check-done in the desugarer, where we can usually learn that something is not-levity-polymorphic without actually figuring out its type. See-isExprLevPoly in GHC.Core.Utils for where this info is used. Storing-this is required to prevent perf/compiler/T5631 from blowing up.---}---- See Note [Levity info]-data LevityInfo = NoLevityInfo  -- always safe-                | NeverLevityPolymorphic-  deriving Eq--instance Outputable LevityInfo where-  ppr NoLevityInfo           = text "NoLevityInfo"-  ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic"---- | Marks an IdInfo describing an Id that is never levity polymorphic (even when--- applied). The Type is only there for checking that it's really never levity--- polymorphic-setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo-setNeverLevPoly info ty-  = ASSERT2( not (resultIsLevPoly ty), ppr ty )-    info { levityInfo = NeverLevityPolymorphic }--setLevityInfoWithType :: IdInfo -> Type -> IdInfo-setLevityInfoWithType info ty-  | not (resultIsLevPoly ty)-  = info { levityInfo = NeverLevityPolymorphic }-  | otherwise-  = info--isNeverLevPolyIdInfo :: IdInfo -> Bool-isNeverLevPolyIdInfo info-  | NeverLevityPolymorphic <- levityInfo info = True-  | otherwise                                 = False
− compiler/basicTypes/IdInfo.hs-boot 
@@ -1,11 +0,0 @@-module IdInfo where-import GhcPrelude-import Outputable-data IdInfo-data IdDetails--vanillaIdInfo :: IdInfo-coVarDetails :: IdDetails-isCoVarDetails :: IdDetails -> Bool-pprIdDetails :: IdDetails -> SDoc-
− compiler/basicTypes/Lexeme.hs 
@@ -1,240 +0,0 @@--- (c) The GHC Team------ Functions to evaluate whether or not a string is a valid identifier.--- There is considerable overlap between the logic here and the logic--- in Lexer.x, but sadly there seems to be no way to merge them.--module Lexeme (-          -- * Lexical characteristics of Haskell names--          -- | Use these functions to figure what kind of name a 'FastString'-          -- represents; these functions do /not/ check that the identifier-          -- is valid.--        isLexCon, isLexVar, isLexId, isLexSym,-        isLexConId, isLexConSym, isLexVarId, isLexVarSym,-        startsVarSym, startsVarId, startsConSym, startsConId,--          -- * Validating identifiers--          -- | These functions (working over plain old 'String's) check-          -- to make sure that the identifier is valid.-        okVarOcc, okConOcc, okTcOcc,-        okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc--        -- Some of the exports above are not used within GHC, but may-        -- be of value to GHC API users.--  ) where--import GhcPrelude--import FastString--import Data.Char-import qualified Data.Set as Set--import GHC.Lexeme--{---************************************************************************-*                                                                      *-    Lexical categories-*                                                                      *-************************************************************************--These functions test strings to see if they fit the lexical categories-defined in the Haskell report.--Note [Classification of generated names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Some names generated for internal use can show up in debugging output,-e.g.  when using -ddump-simpl. These generated names start with a $-but should still be pretty-printed using prefix notation. We make sure-this is the case in isLexVarSym by only classifying a name as a symbol-if all its characters are symbols, not just its first one.--}--isLexCon,   isLexVar,    isLexId,    isLexSym    :: FastString -> Bool-isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool--isLexCon cs = isLexConId  cs || isLexConSym cs-isLexVar cs = isLexVarId  cs || isLexVarSym cs--isLexId  cs = isLexConId  cs || isLexVarId  cs-isLexSym cs = isLexConSym cs || isLexVarSym cs----------------isLexConId cs                           -- Prefix type or data constructors-  | nullFS cs          = False          --      e.g. "Foo", "[]", "(,)"-  | cs == (fsLit "[]") = True-  | otherwise          = startsConId (headFS cs)--isLexVarId cs                           -- Ordinary prefix identifiers-  | nullFS cs         = False           --      e.g. "x", "_x"-  | otherwise         = startsVarId (headFS cs)--isLexConSym cs                          -- Infix type or data constructors-  | nullFS cs          = False          --      e.g. ":-:", ":", "->"-  | cs == (fsLit "->") = True-  | otherwise          = startsConSym (headFS cs)--isLexVarSym fs                          -- Infix identifiers e.g. "+"-  | fs == (fsLit "~R#") = True-  | otherwise-  = case (if nullFS fs then [] else unpackFS fs) of-      [] -> False-      (c:cs) -> startsVarSym c && all isVarSymChar cs-        -- See Note [Classification of generated names]--{---************************************************************************-*                                                                      *-    Detecting valid names for Template Haskell-*                                                                      *-************************************************************************---}--------------------------- External interface--------------------------- | Is this an acceptable variable name?-okVarOcc :: String -> Bool-okVarOcc str@(c:_)-  | startsVarId c-  = okVarIdOcc str-  | startsVarSym c-  = okVarSymOcc str-okVarOcc _ = False---- | Is this an acceptable constructor name?-okConOcc :: String -> Bool-okConOcc str@(c:_)-  | startsConId c-  = okConIdOcc str-  | startsConSym c-  = okConSymOcc str-  | str == "[]"-  = True-okConOcc _ = False---- | Is this an acceptable type name?-okTcOcc :: String -> Bool-okTcOcc "[]" = True-okTcOcc "->" = True-okTcOcc "~"  = True-okTcOcc str@(c:_)-  | startsConId c-  = okConIdOcc str-  | startsConSym c-  = okConSymOcc str-  | startsVarSym c-  = okVarSymOcc str-okTcOcc _ = False---- | Is this an acceptable alphanumeric variable name, assuming it starts--- with an acceptable letter?-okVarIdOcc :: String -> Bool-okVarIdOcc str = okIdOcc str &&-                 -- admit "_" as a valid identifier.  Required to support typed-                 -- holes in Template Haskell.  See #10267-                 (str == "_" || not (str `Set.member` reservedIds))---- | Is this an acceptable symbolic variable name, assuming it starts--- with an acceptable character?-okVarSymOcc :: String -> Bool-okVarSymOcc str = all okSymChar str &&-                  not (str `Set.member` reservedOps) &&-                  not (isDashes str)---- | Is this an acceptable alphanumeric constructor name, assuming it--- starts with an acceptable letter?-okConIdOcc :: String -> Bool-okConIdOcc str = okIdOcc str ||-                 is_tuple_name1 True  str ||-                   -- Is it a boxed tuple...-                 is_tuple_name1 False str ||-                   -- ...or an unboxed tuple (#12407)...-                 is_sum_name1 str-                   -- ...or an unboxed sum (#12514)?-  where-    -- check for tuple name, starting at the beginning-    is_tuple_name1 True  ('(' : rest)       = is_tuple_name2 True  rest-    is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest-    is_tuple_name1 _     _                  = False--    -- check for tuple tail-    is_tuple_name2 True  ")"          = True-    is_tuple_name2 False "#)"         = True-    is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest-    is_tuple_name2 boxed (ws  : rest)-      | isSpace ws                    = is_tuple_name2 boxed rest-    is_tuple_name2 _     _            = False--    -- check for sum name, starting at the beginning-    is_sum_name1 ('(' : '#' : rest) = is_sum_name2 False rest-    is_sum_name1 _                  = False--    -- check for sum tail, only allowing at most one underscore-    is_sum_name2 _          "#)"         = True-    is_sum_name2 underscore ('|' : rest) = is_sum_name2 underscore rest-    is_sum_name2 False      ('_' : rest) = is_sum_name2 True rest-    is_sum_name2 underscore (ws  : rest)-      | isSpace ws                       = is_sum_name2 underscore rest-    is_sum_name2 _          _            = False---- | Is this an acceptable symbolic constructor name, assuming it--- starts with an acceptable character?-okConSymOcc :: String -> Bool-okConSymOcc ":" = True-okConSymOcc str = all okSymChar str &&-                  not (str `Set.member` reservedOps)--------------------------- Internal functions--------------------------- | Is this string an acceptable id, possibly with a suffix of hashes,--- but not worrying about case or clashing with reserved words?-okIdOcc :: String -> Bool-okIdOcc str-  = let hashes = dropWhile okIdChar str in-    all (== '#') hashes   -- -XMagicHash allows a suffix of hashes-                          -- of course, `all` says "True" to an empty list---- | Is this character acceptable in an identifier (after the first letter)?--- See alexGetByte in Lexer.x-okIdChar :: Char -> Bool-okIdChar c = case generalCategory c of-  UppercaseLetter -> True-  LowercaseLetter -> True-  TitlecaseLetter -> True-  ModifierLetter  -> True -- See #10196-  OtherLetter     -> True -- See #1103-  NonSpacingMark  -> True -- See #7650-  DecimalNumber   -> True-  OtherNumber     -> True -- See #4373-  _               -> c == '\'' || c == '_'---- | All reserved identifiers. Taken from section 2.4 of the 2010 Report.-reservedIds :: Set.Set String-reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving"-                           , "do", "else", "foreign", "if", "import", "in"-                           , "infix", "infixl", "infixr", "instance", "let"-                           , "module", "newtype", "of", "then", "type", "where"-                           , "_" ]---- | All reserved operators. Taken from section 2.4 of the 2010 Report.-reservedOps :: Set.Set String-reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->"-                           , "@", "~", "=>" ]---- | Does this string contain only dashes and has at least 2 of them?-isDashes :: String -> Bool-isDashes ('-' : '-' : rest) = all (== '-') rest-isDashes _                  = False
− compiler/basicTypes/Literal.hs 
@@ -1,851 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1998--\section[Literal]{@Literal@: literals}--}--{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module Literal-        (-        -- * Main data type-          Literal(..)           -- Exported to ParseIface-        , LitNumType(..)--        -- ** Creating Literals-        , mkLitInt, mkLitIntWrap, mkLitIntWrapC-        , mkLitWord, mkLitWordWrap, mkLitWordWrapC-        , mkLitInt64, mkLitInt64Wrap-        , mkLitWord64, mkLitWord64Wrap-        , mkLitFloat, mkLitDouble-        , mkLitChar, mkLitString-        , mkLitInteger, mkLitNatural-        , mkLitNumber, mkLitNumberWrap--        -- ** Operations on Literals-        , literalType-        , absentLiteralOf-        , pprLiteral-        , litNumIsSigned-        , litNumCheckRange--        -- ** Predicates on Literals and their contents-        , litIsDupable, litIsTrivial, litIsLifted-        , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange-        , isZeroLit-        , litFitsInChar-        , litValue, isLitValue, isLitValue_maybe, mapLitValue--        -- ** Coercions-        , word2IntLit, int2WordLit-        , narrowLit-        , narrow8IntLit, narrow16IntLit, narrow32IntLit-        , narrow8WordLit, narrow16WordLit, narrow32WordLit-        , char2IntLit, int2CharLit-        , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit-        , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit-        ) where--#include "HsVersions.h"--import GhcPrelude--import TysPrim-import PrelNames-import Type-import TyCon-import Outputable-import FastString-import BasicTypes-import Binary-import Constants-import GHC.Driver.Session-import GHC.Platform-import UniqFM-import Util--import Data.ByteString (ByteString)-import Data.Int-import Data.Word-import Data.Char-import Data.Maybe ( isJust )-import Data.Data ( Data )-import Data.Proxy-import Numeric ( fromRat )--{--************************************************************************-*                                                                      *-\subsection{Literals}-*                                                                      *-************************************************************************--}---- | So-called 'Literal's are one of:------ * An unboxed numeric literal or floating-point literal which is presumed---   to be surrounded by appropriate constructors (@Int#@, etc.), so that---   the overall thing makes sense.------   We maintain the invariant that the 'Integer' in the 'LitNumber'---   constructor is actually in the (possibly target-dependent) range.---   The mkLit{Int,Word}*Wrap smart constructors ensure this by applying---   the target machine's wrapping semantics. Use these in situations---   where you know the wrapping semantics are correct.------ * The literal derived from the label mentioned in a \"foreign label\"---   declaration ('LitLabel')------ * A 'LitRubbish' to be used in place of values of 'UnliftedRep'---   (i.e. 'MutVar#') when the the value is never used.------ * A character--- * A string--- * The NULL pointer----data Literal-  = LitChar    Char             -- ^ @Char#@ - at least 31 bits. Create with-                                -- 'mkLitChar'--  | LitNumber !LitNumType !Integer Type-                                -- ^ Any numeric literal that can be-                                -- internally represented with an Integer.-                                -- See Note [Types of LitNumbers] below for the-                                -- Type field.--  | LitString  ByteString       -- ^ A string-literal: stored and emitted-                                -- UTF-8 encoded, we'll arrange to decode it-                                -- at runtime.  Also emitted with a @\'\\0\'@-                                -- terminator. Create with 'mkLitString'--  | LitNullAddr                 -- ^ The @NULL@ pointer, the only pointer value-                                -- that can be represented as a Literal. Create-                                -- with 'nullAddrLit'--  | LitRubbish                  -- ^ A nonsense value, used when an unlifted-                                -- binding is absent and has type-                                -- @forall (a :: 'TYPE' 'UnliftedRep'). a@.-                                -- May be lowered by code-gen to any possible-                                -- value. Also see Note [Rubbish literals]--  | LitFloat   Rational         -- ^ @Float#@. Create with 'mkLitFloat'-  | LitDouble  Rational         -- ^ @Double#@. Create with 'mkLitDouble'--  | LitLabel   FastString (Maybe Int) FunctionOrData-                                -- ^ A label literal. Parameters:-                                ---                                -- 1) The name of the symbol mentioned in the-                                --    declaration-                                ---                                -- 2) The size (in bytes) of the arguments-                                --    the label expects. Only applicable with-                                --    @stdcall@ labels. @Just x@ => @\<x\>@ will-                                --    be appended to label name when emitting-                                --    assembly.-                                ---                                -- 3) Flag indicating whether the symbol-                                --    references a function or a data-  deriving Data---- | Numeric literal type-data LitNumType-  = LitNumInteger -- ^ @Integer@ (see Note [Integer literals])-  | LitNumNatural -- ^ @Natural@ (see Note [Natural literals])-  | LitNumInt     -- ^ @Int#@ - according to target machine-  | LitNumInt64   -- ^ @Int64#@ - exactly 64 bits-  | LitNumWord    -- ^ @Word#@ - according to target machine-  | LitNumWord64  -- ^ @Word64#@ - exactly 64 bits-  deriving (Data,Enum,Eq,Ord)---- | Indicate if a numeric literal type supports negative numbers-litNumIsSigned :: LitNumType -> Bool-litNumIsSigned nt = case nt of-  LitNumInteger -> True-  LitNumNatural -> False-  LitNumInt     -> True-  LitNumInt64   -> True-  LitNumWord    -> False-  LitNumWord64  -> False--{--Note [Integer literals]-~~~~~~~~~~~~~~~~~~~~~~~-An Integer literal is represented using, well, an Integer, to make it-easier to write RULEs for them. They also contain the Integer type, so-that e.g. literalType can return the right Type for them.--They only get converted into real Core,-    mkInteger [c1, c2, .., cn]-during the CorePrep phase, although GHC.Iface.Tidy looks ahead at what the-core will be, so that it can see whether it involves CAFs.--When we initially build an Integer literal, notably when-deserialising it from an interface file (see the Binary instance-below), we don't have convenient access to the mkInteger Id.  So we-just use an error thunk, and fill in the real Id when we do tcIfaceLit-in GHC.IfaceToCore.--Note [Natural literals]-~~~~~~~~~~~~~~~~~~~~~~~-Similar to Integer literals.--Note [String literals]-~~~~~~~~~~~~~~~~~~~~~~--String literals are UTF-8 encoded and stored into ByteStrings in the following-ASTs: Haskell, Core, Stg, Cmm. TH can also emit ByteString based string literals-with the BytesPrimL constructor (see #14741).--It wasn't true before as [Word8] was used in Cmm AST and in TH which was quite-bad for performance with large strings (see #16198 and #14741).--To include string literals into output objects, the assembler code generator has-to embed the UTF-8 encoded binary blob. See Note [Embedding large binary blobs]-for more details.---}--instance Binary LitNumType where-   put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp))-   get bh = do-      h <- getByte bh-      return (toEnum (fromIntegral h))--instance Binary Literal where-    put_ bh (LitChar aa)     = do putByte bh 0; put_ bh aa-    put_ bh (LitString ab)   = do putByte bh 1; put_ bh ab-    put_ bh (LitNullAddr)    = do putByte bh 2-    put_ bh (LitFloat ah)    = do putByte bh 3; put_ bh ah-    put_ bh (LitDouble ai)   = do putByte bh 4; put_ bh ai-    put_ bh (LitLabel aj mb fod)-        = do putByte bh 5-             put_ bh aj-             put_ bh mb-             put_ bh fod-    put_ bh (LitNumber nt i _)-        = do putByte bh 6-             put_ bh nt-             put_ bh i-    put_ bh (LitRubbish)     = do putByte bh 7-    get bh = do-            h <- getByte bh-            case h of-              0 -> do-                    aa <- get bh-                    return (LitChar aa)-              1 -> do-                    ab <- get bh-                    return (LitString ab)-              2 -> do-                    return (LitNullAddr)-              3 -> do-                    ah <- get bh-                    return (LitFloat ah)-              4 -> do-                    ai <- get bh-                    return (LitDouble ai)-              5 -> do-                    aj <- get bh-                    mb <- get bh-                    fod <- get bh-                    return (LitLabel aj mb fod)-              6 -> do-                    nt <- get bh-                    i  <- get bh-                    -- Note [Types of LitNumbers]-                    let t = case nt of-                            LitNumInt     -> intPrimTy-                            LitNumInt64   -> int64PrimTy-                            LitNumWord    -> wordPrimTy-                            LitNumWord64  -> word64PrimTy-                            -- See Note [Integer literals]-                            LitNumInteger ->-                              panic "Evaluated the place holder for mkInteger"-                            -- and Note [Natural literals]-                            LitNumNatural ->-                              panic "Evaluated the place holder for mkNatural"-                    return (LitNumber nt i t)-              _ -> do-                    return (LitRubbish)--instance Outputable Literal where-    ppr = pprLiteral id--instance Eq Literal where-    a == b = compare a b == EQ---- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in--- 'TrieMap.CoreMap'.-instance Ord Literal where-    compare = cmpLit--{--        Construction-        ~~~~~~~~~~~~--}--{- Note [Word/Int underflow/overflow]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and-unsigned integral types): "All arithmetic is performed modulo 2^n, where n is-the number of bits in the type."--GHC stores Word# and Int# constant values as Integer. Core optimizations such-as constant folding must ensure that the Integer value remains in the valid-target Word/Int range (see #13172). The following functions are used to-ensure this.--Note that we *don't* warn the user about overflow. It's not done at runtime-either, and compilation of completely harmless things like-   ((124076834 :: Word32) + (2147483647 :: Word32))-doesn't yield a warning. Instead we simply squash the value into the *target*-Int/Word range.--}---- | Wrap a literal number according to its type-wrapLitNumber :: DynFlags -> Literal -> Literal-wrapLitNumber dflags v@(LitNumber nt i t) = case nt of-  LitNumInt -> case platformWordSize (targetPlatform dflags) of-    PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t-    PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t-  LitNumWord -> case platformWordSize (targetPlatform dflags) of-    PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t-    PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t-  LitNumInt64   -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t-  LitNumWord64  -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t-  LitNumInteger -> v-  LitNumNatural -> v-wrapLitNumber _ x = x---- | Create a numeric 'Literal' of the given type-mkLitNumberWrap :: DynFlags -> LitNumType -> Integer -> Type -> Literal-mkLitNumberWrap dflags nt i t = wrapLitNumber dflags (LitNumber nt i t)---- | Check that a given number is in the range of a numeric literal-litNumCheckRange :: DynFlags -> LitNumType -> Integer -> Bool-litNumCheckRange dflags nt i = case nt of-     LitNumInt     -> inIntRange dflags i-     LitNumWord    -> inWordRange dflags i-     LitNumInt64   -> inInt64Range i-     LitNumWord64  -> inWord64Range i-     LitNumNatural -> i >= 0-     LitNumInteger -> True---- | Create a numeric 'Literal' of the given type-mkLitNumber :: DynFlags -> LitNumType -> Integer -> Type -> Literal-mkLitNumber dflags nt i t =-  ASSERT2(litNumCheckRange dflags nt i, integer i)-  (LitNumber nt i t)---- | Creates a 'Literal' of type @Int#@-mkLitInt :: DynFlags -> Integer -> Literal-mkLitInt dflags x   = ASSERT2( inIntRange dflags x,  integer x )-                       (mkLitIntUnchecked x)---- | Creates a 'Literal' of type @Int#@.---   If the argument is out of the (target-dependent) range, it is wrapped.---   See Note [Word/Int underflow/overflow]-mkLitIntWrap :: DynFlags -> Integer -> Literal-mkLitIntWrap dflags i = wrapLitNumber dflags $ mkLitIntUnchecked i---- | Creates a 'Literal' of type @Int#@ without checking its range.-mkLitIntUnchecked :: Integer -> Literal-mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy---- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating---   overflow. That is, if the argument is out of the (target-dependent) range---   the argument is wrapped and the overflow flag will be set.---   See Note [Word/Int underflow/overflow]-mkLitIntWrapC :: DynFlags -> Integer -> (Literal, Bool)-mkLitIntWrapC dflags i = (n, i /= i')-  where-    n@(LitNumber _ i' _) = mkLitIntWrap dflags i---- | Creates a 'Literal' of type @Word#@-mkLitWord :: DynFlags -> Integer -> Literal-mkLitWord dflags x   = ASSERT2( inWordRange dflags x, integer x )-                        (mkLitWordUnchecked x)---- | Creates a 'Literal' of type @Word#@.---   If the argument is out of the (target-dependent) range, it is wrapped.---   See Note [Word/Int underflow/overflow]-mkLitWordWrap :: DynFlags -> Integer -> Literal-mkLitWordWrap dflags i = wrapLitNumber dflags $ mkLitWordUnchecked i---- | Creates a 'Literal' of type @Word#@ without checking its range.-mkLitWordUnchecked :: Integer -> Literal-mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy---- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating---   carry. That is, if the argument is out of the (target-dependent) range---   the argument is wrapped and the carry flag will be set.---   See Note [Word/Int underflow/overflow]-mkLitWordWrapC :: DynFlags -> Integer -> (Literal, Bool)-mkLitWordWrapC dflags i = (n, i /= i')-  where-    n@(LitNumber _ i' _) = mkLitWordWrap dflags i---- | Creates a 'Literal' of type @Int64#@-mkLitInt64 :: Integer -> Literal-mkLitInt64  x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x)---- | Creates a 'Literal' of type @Int64#@.---   If the argument is out of the range, it is wrapped.-mkLitInt64Wrap :: DynFlags -> Integer -> Literal-mkLitInt64Wrap dflags i = wrapLitNumber dflags $ mkLitInt64Unchecked i---- | Creates a 'Literal' of type @Int64#@ without checking its range.-mkLitInt64Unchecked :: Integer -> Literal-mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy---- | Creates a 'Literal' of type @Word64#@-mkLitWord64 :: Integer -> Literal-mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x)---- | Creates a 'Literal' of type @Word64#@.---   If the argument is out of the range, it is wrapped.-mkLitWord64Wrap :: DynFlags -> Integer -> Literal-mkLitWord64Wrap dflags i = wrapLitNumber dflags $ mkLitWord64Unchecked i---- | Creates a 'Literal' of type @Word64#@ without checking its range.-mkLitWord64Unchecked :: Integer -> Literal-mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy---- | Creates a 'Literal' of type @Float#@-mkLitFloat :: Rational -> Literal-mkLitFloat = LitFloat---- | Creates a 'Literal' of type @Double#@-mkLitDouble :: Rational -> Literal-mkLitDouble = LitDouble---- | Creates a 'Literal' of type @Char#@-mkLitChar :: Char -> Literal-mkLitChar = LitChar---- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to--- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@-mkLitString :: String -> Literal--- stored UTF-8 encoded-mkLitString s = LitString (bytesFS $ mkFastString s)--mkLitInteger :: Integer -> Type -> Literal-mkLitInteger x ty = LitNumber LitNumInteger x ty--mkLitNatural :: Integer -> Type -> Literal-mkLitNatural x ty = ASSERT2( inNaturalRange x,  integer x )-                    (LitNumber LitNumNatural x ty)--inIntRange, inWordRange :: DynFlags -> Integer -> Bool-inIntRange  dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags-inWordRange dflags x = x >= 0                     && x <= tARGET_MAX_WORD dflags--inNaturalRange :: Integer -> Bool-inNaturalRange x = x >= 0--inInt64Range, inWord64Range :: Integer -> Bool-inInt64Range x  = x >= toInteger (minBound :: Int64) &&-                  x <= toInteger (maxBound :: Int64)-inWord64Range x = x >= toInteger (minBound :: Word64) &&-                  x <= toInteger (maxBound :: Word64)--inCharRange :: Char -> Bool-inCharRange c =  c >= '\0' && c <= chr tARGET_MAX_CHAR---- | Tests whether the literal represents a zero of whatever type it is-isZeroLit :: Literal -> Bool-isZeroLit (LitNumber _ 0 _) = True-isZeroLit (LitFloat  0)     = True-isZeroLit (LitDouble 0)     = True-isZeroLit _                 = False---- | Returns the 'Integer' contained in the 'Literal', for when that makes--- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'.-litValue  :: Literal -> Integer-litValue l = case isLitValue_maybe l of-   Just x  -> x-   Nothing -> pprPanic "litValue" (ppr l)---- | Returns the 'Integer' contained in the 'Literal', for when that makes--- sense, i.e. for 'Char' and numbers.-isLitValue_maybe  :: Literal -> Maybe Integer-isLitValue_maybe (LitChar   c)     = Just $ toInteger $ ord c-isLitValue_maybe (LitNumber _ i _) = Just i-isLitValue_maybe _                 = Nothing---- | Apply a function to the 'Integer' contained in the 'Literal', for when that--- makes sense, e.g. for 'Char' and numbers.--- For fixed-size integral literals, the result will be wrapped in accordance--- with the semantics of the target type.--- See Note [Word/Int underflow/overflow]-mapLitValue  :: DynFlags -> (Integer -> Integer) -> Literal -> Literal-mapLitValue _      f (LitChar   c)      = mkLitChar (fchar c)-   where fchar = chr . fromInteger . f . toInteger . ord-mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags-                                                        (LitNumber nt (f i) t)-mapLitValue _      _ l                  = pprPanic "mapLitValue" (ppr l)---- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',--- 'Int', 'Word', 'LitInteger' and 'LitNatural'.-isLitValue  :: Literal -> Bool-isLitValue = isJust . isLitValue_maybe--{--        Coercions-        ~~~~~~~~~--}--narrow8IntLit, narrow16IntLit, narrow32IntLit,-  narrow8WordLit, narrow16WordLit, narrow32WordLit,-  char2IntLit, int2CharLit,-  float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,-  float2DoubleLit, double2FloatLit-  :: Literal -> Literal--word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal-word2IntLit dflags (LitNumber LitNumWord w _)-  -- Map Word range [max_int+1, max_word]-  -- to Int range   [min_int  , -1]-  -- Range [0,max_int] has the same representation with both Int and Word-  | w > tARGET_MAX_INT dflags = mkLitInt dflags (w - tARGET_MAX_WORD dflags - 1)-  | otherwise                 = mkLitInt dflags w-word2IntLit _ l = pprPanic "word2IntLit" (ppr l)--int2WordLit dflags (LitNumber LitNumInt i _)-  -- Map Int range [min_int  , -1]-  -- to Word range [max_int+1, max_word]-  -- Range [0,max_int] has the same representation with both Int and Word-  | i < 0     = mkLitWord dflags (1 + tARGET_MAX_WORD dflags + i)-  | otherwise = mkLitWord dflags i-int2WordLit _ l = pprPanic "int2WordLit" (ppr l)---- | Narrow a literal number (unchecked result range)-narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal-narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t-narrowLit _ l                  = pprPanic "narrowLit" (ppr l)--narrow8IntLit   = narrowLit (Proxy :: Proxy Int8)-narrow16IntLit  = narrowLit (Proxy :: Proxy Int16)-narrow32IntLit  = narrowLit (Proxy :: Proxy Int32)-narrow8WordLit  = narrowLit (Proxy :: Proxy Word8)-narrow16WordLit = narrowLit (Proxy :: Proxy Word16)-narrow32WordLit = narrowLit (Proxy :: Proxy Word32)--char2IntLit (LitChar c)       = mkLitIntUnchecked (toInteger (ord c))-char2IntLit l                 = pprPanic "char2IntLit" (ppr l)-int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i))-int2CharLit l                 = pprPanic "int2CharLit" (ppr l)--float2IntLit (LitFloat f)      = mkLitIntUnchecked (truncate f)-float2IntLit l                 = pprPanic "float2IntLit" (ppr l)-int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i)-int2FloatLit l                 = pprPanic "int2FloatLit" (ppr l)--double2IntLit (LitDouble f)     = mkLitIntUnchecked (truncate f)-double2IntLit l                 = pprPanic "double2IntLit" (ppr l)-int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i)-int2DoubleLit l                 = pprPanic "int2DoubleLit" (ppr l)--float2DoubleLit (LitFloat  f) = LitDouble f-float2DoubleLit l             = pprPanic "float2DoubleLit" (ppr l)-double2FloatLit (LitDouble d) = LitFloat  d-double2FloatLit l             = pprPanic "double2FloatLit" (ppr l)--nullAddrLit :: Literal-nullAddrLit = LitNullAddr---- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@.-rubbishLit :: Literal-rubbishLit = LitRubbish--{--        Predicates-        ~~~~~~~~~~--}---- | True if there is absolutely no penalty to duplicating the literal.--- False principally of strings.------ "Why?", you say? I'm glad you asked. Well, for one duplicating strings would--- blow up code sizes. Not only this, it's also unsafe.------ Consider a program that wants to traverse a string. One way it might do this--- is to first compute the Addr# pointing to the end of the string, and then,--- starting from the beginning, bump a pointer using eqAddr# to determine the--- end. For instance,------ @--- -- Given pointers to the start and end of a string, count how many zeros--- -- the string contains.--- countZeros :: Addr# -> Addr# -> -> Int--- countZeros start end = go start 0---   where---     go off n---       | off `addrEq#` end = n---       | otherwise         = go (off `plusAddr#` 1) n'---       where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1---                | otherwise                                 = n--- @------ Consider what happens if we considered strings to be trivial (and therefore--- duplicable) and emitted a call like @countZeros "hello"# ("hello"#--- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same--- string, meaning that an iteration like the above would blow up terribly.--- This is what happened in #12757.------ Ultimately the solution here is to make primitive strings a bit more--- structured, ensuring that the compiler can't inline in ways that will break--- user code. One approach to this is described in #8472.-litIsTrivial :: Literal -> Bool---      c.f. GHC.Core.Utils.exprIsTrivial-litIsTrivial (LitString _)      = False-litIsTrivial (LitNumber nt _ _) = case nt of-  LitNumInteger -> False-  LitNumNatural -> False-  LitNumInt     -> True-  LitNumInt64   -> True-  LitNumWord    -> True-  LitNumWord64  -> True-litIsTrivial _                  = True---- | True if code space does not go bad if we duplicate this literal-litIsDupable :: DynFlags -> Literal -> Bool---      c.f. GHC.Core.Utils.exprIsDupable-litIsDupable _      (LitString _)      = False-litIsDupable dflags (LitNumber nt i _) = case nt of-  LitNumInteger -> inIntRange dflags i-  LitNumNatural -> inIntRange dflags i-  LitNumInt     -> True-  LitNumInt64   -> True-  LitNumWord    -> True-  LitNumWord64  -> True-litIsDupable _      _                  = True--litFitsInChar :: Literal -> Bool-litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound)-                               && i <= toInteger (ord maxBound)-litFitsInChar _                 = False--litIsLifted :: Literal -> Bool-litIsLifted (LitNumber nt _ _) = case nt of-  LitNumInteger -> True-  LitNumNatural -> True-  LitNumInt     -> False-  LitNumInt64   -> False-  LitNumWord    -> False-  LitNumWord64  -> False-litIsLifted _                  = False--{--        Types-        ~~~~~--Note [Types of LitNumbers]-~~~~~~~~~~~~~~~~~~~~~~~~~~--A LitNumber's type is always known from its LitNumType:--  LitNumInteger -> Integer-  LitNumNatural -> Natural-  LitNumInt     -> Int# (intPrimTy)-  LitNumInt64   -> Int64# (int64PrimTy)-  LitNumWord    -> Word# (wordPrimTy)-  LitNumWord64  -> Word64# (word64PrimTy)--The reason why we have a Type field is because Integer and Natural types live-outside of GHC (in the libraries), so we have to get the actual Type via-lookupTyCon, tcIfaceTyConByName etc. that's too inconvenient in the call sites-of literalType, so we do that when creating these literals, and literalType-simply reads the field.--(But see also Note [Integer literals] and Note [Natural literals])--}---- | Find the Haskell 'Type' the literal occupies-literalType :: Literal -> Type-literalType LitNullAddr       = addrPrimTy-literalType (LitChar _)       = charPrimTy-literalType (LitString  _)    = addrPrimTy-literalType (LitFloat _)      = floatPrimTy-literalType (LitDouble _)     = doublePrimTy-literalType (LitLabel _ _ _)  = addrPrimTy-literalType (LitNumber _ _ t) = t -- Note [Types of LitNumbers]-literalType (LitRubbish)      = mkForAllTy a Inferred (mkTyVarTy a)-  where-    a = alphaTyVarUnliftedRep--absentLiteralOf :: TyCon -> Maybe Literal--- Return a literal of the appropriate primitive--- TyCon, to use as a placeholder when it doesn't matter--- Rubbish literals are handled in WwLib, because---  1. Looking at the TyCon is not enough, we need the actual type---  2. This would need to return a type application to a literal-absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)--absent_lits :: UniqFM Literal-absent_lits = listToUFM [ (addrPrimTyConKey,    LitNullAddr)-                        , (charPrimTyConKey,    LitChar 'x')-                        , (intPrimTyConKey,     mkLitIntUnchecked 0)-                        , (int64PrimTyConKey,   mkLitInt64Unchecked 0)-                        , (wordPrimTyConKey,    mkLitWordUnchecked 0)-                        , (word64PrimTyConKey,  mkLitWord64Unchecked 0)-                        , (floatPrimTyConKey,   LitFloat 0)-                        , (doublePrimTyConKey,  LitDouble 0)-                        ]--{--        Comparison-        ~~~~~~~~~~--}--cmpLit :: Literal -> Literal -> Ordering-cmpLit (LitChar      a)     (LitChar       b)     = a `compare` b-cmpLit (LitString    a)     (LitString     b)     = a `compare` b-cmpLit (LitNullAddr)        (LitNullAddr)         = EQ-cmpLit (LitFloat     a)     (LitFloat      b)     = a `compare` b-cmpLit (LitDouble    a)     (LitDouble     b)     = a `compare` b-cmpLit (LitLabel     a _ _) (LitLabel      b _ _) = a `compare` b-cmpLit (LitNumber nt1 a _)  (LitNumber nt2  b _)-  | nt1 == nt2 = a   `compare` b-  | otherwise  = nt1 `compare` nt2-cmpLit (LitRubbish)         (LitRubbish)          = EQ-cmpLit lit1 lit2-  | litTag lit1 < litTag lit2 = LT-  | otherwise                 = GT--litTag :: Literal -> Int-litTag (LitChar      _)   = 1-litTag (LitString    _)   = 2-litTag (LitNullAddr)      = 3-litTag (LitFloat     _)   = 4-litTag (LitDouble    _)   = 5-litTag (LitLabel _ _ _)   = 6-litTag (LitNumber  {})    = 7-litTag (LitRubbish)       = 8--{--        Printing-        ~~~~~~~~-* See Note [Printing of literals in Core]--}--pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc-pprLiteral _       (LitChar c)     = pprPrimChar c-pprLiteral _       (LitString s)   = pprHsBytes s-pprLiteral _       (LitNullAddr)   = text "__NULL"-pprLiteral _       (LitFloat f)    = float (fromRat f) <> primFloatSuffix-pprLiteral _       (LitDouble d)   = double (fromRat d) <> primDoubleSuffix-pprLiteral add_par (LitNumber nt i _)-   = case nt of-       LitNumInteger -> pprIntegerVal add_par i-       LitNumNatural -> pprIntegerVal add_par i-       LitNumInt     -> pprPrimInt i-       LitNumInt64   -> pprPrimInt64 i-       LitNumWord    -> pprPrimWord i-       LitNumWord64  -> pprPrimWord64 i-pprLiteral add_par (LitLabel l mb fod) =-    add_par (text "__label" <+> b <+> ppr fod)-    where b = case mb of-              Nothing -> pprHsString l-              Just x  -> doubleQuotes (text (unpackFS l ++ '@':show x))-pprLiteral _       (LitRubbish)     = text "__RUBBISH"--pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc--- See Note [Printing of literals in Core].-pprIntegerVal add_par i | i < 0     = add_par (integer i)-                        | otherwise = integer i--{--Note [Printing of literals in Core]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The function `add_par` is used to wrap parenthesis around negative integers-(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring-an atomic thing (for example function application).--Although not all Core literals would be valid Haskell, we are trying to stay-as close as possible to Haskell syntax in the printing of Core, to make it-easier for a Haskell user to read Core.--To that end:-  * We do print parenthesis around negative `LitInteger`, because we print-  `LitInteger` using plain number literals (no prefix or suffix), and plain-  number literals in Haskell require parenthesis in contexts like function-  application (i.e. `1 - -1` is not valid Haskell).--  * We don't print parenthesis around other (negative) literals, because they-  aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's-  parser).--Literal         Output             Output if context requires-                                   an atom (if different)--------         -------            -----------------------LitChar         'a'#-LitString       "aaa"#-LitNullAddr     "__NULL"-LitInt          -1#-LitInt64        -1L#-LitWord          1##-LitWord64        1L##-LitFloat        -1.0#-LitDouble       -1.0##-LitInteger      -1                 (-1)-LitLabel        "__label" ...      ("__label" ...)-LitRubbish      "__RUBBISH"--Note [Rubbish literals]-~~~~~~~~~~~~~~~~~~~~~~~-During worker/wrapper after demand analysis, where an argument-is unused (absent) we do the following w/w split (supposing that-y is absent):--  f x y z = e-===>-  f x y z = $wf x z-  $wf x z = let y = <absent value>-            in e--Usually the binding for y is ultimately optimised away, and-even if not it should never be evaluated -- but that's the-way the w/w split starts off.--What is <absent value>?-* For lifted values <absent value> can be a call to 'error'.-* For primitive types like Int# or Word# we can use any random-  value of that type.-* But what about /unlifted/ but /boxed/ types like MutVar# or-  Array#?   We need a literal value of that type.--That is 'LitRubbish'.  Since we need a rubbish literal for-many boxed, unlifted types, we say that LitRubbish has type-  LitRubbish :: forall (a :: TYPE UnliftedRep). a--So we might see a w/w split like-  $wf x z = let y :: Array# Int = LitRubbish @(Array# Int)-            in e--Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted-heap pointers.--Here are the moving parts:--* We define LitRubbish as a constructor in Literal.Literal--* It is given its polymorphic type by Literal.literalType--* WwLib.mk_absent_let introduces a LitRubbish for absent-  arguments of boxed, unlifted type.--* In CoreToSTG we convert (RubishLit @t) to just ().  STG is-  untyped, so it doesn't matter that it points to a lifted-  value. The important thing is that it is a heap pointer,-  which the garbage collector can follow if it encounters it.--  We considered maintaining LitRubbish in STG, and lowering-  it in the code generators, but it seems simpler to do it-  once and for all in CoreToSTG.--  In GHC.ByteCode.Asm we just lower it as a 0 literal, because-  it's all boxed and lifted to the host GC anyway.--}
− compiler/basicTypes/MkId.hs 
@@ -1,1708 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The AQUA Project, Glasgow University, 1998---This module contains definitions for the IdInfo for things that-have a standard form, namely:--- data constructors-- record selectors-- method and superclass selectors-- primitive operations--}--{-# LANGUAGE CPP #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module MkId (-        mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs,--        mkPrimOpId, mkFCallId,--        unwrapNewTypeBody, wrapFamInstBody,-        DataConBoxer(..), vanillaDataConBoxer,-        mkDataConRep, mkDataConWorkId,--        -- And some particular Ids; see below for why they are wired in-        wiredInIds, ghcPrimIds,-        realWorldPrimId,-        voidPrimId, voidArgId,-        nullAddrId, seqId, lazyId, lazyIdKey,-        coercionTokenId, magicDictId, coerceId,-        proxyHashId, noinlineId, noinlineIdName,-        coerceName,--        -- Re-export error Ids-        module PrelRules-    ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Core.Rules-import TysPrim-import TysWiredIn-import PrelRules-import Type-import TyCoRep-import FamInstEnv-import Coercion-import TcType-import GHC.Core.Make-import GHC.Core.Utils  ( mkCast, mkDefaultCase )-import GHC.Core.Unfold-import Literal-import TyCon-import Class-import NameSet-import Name-import PrimOp-import ForeignCall-import DataCon-import Id-import IdInfo-import Demand-import Cpr-import GHC.Core-import Unique-import UniqSupply-import PrelNames-import BasicTypes       hiding ( SuccessFlag(..) )-import Util-import GHC.Driver.Session-import Outputable-import FastString-import ListSetOps-import Var (VarBndr(Bndr))-import qualified GHC.LanguageExtensions as LangExt--import Data.Maybe       ( maybeToList )--{--************************************************************************-*                                                                      *-\subsection{Wired in Ids}-*                                                                      *-************************************************************************--Note [Wired-in Ids]-~~~~~~~~~~~~~~~~~~~-A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId')-rather than by looking it up its name in some environment or fetching-it from an interface file.--There are several reasons why an Id might appear in the wiredInIds:--* ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)]--* magicIds: see Note [magicIds]--* errorIds, defined in GHC.Core.Make.-  These error functions (e.g. rUNTIME_ERROR_ID) are wired in-  because the desugarer generates code that mentions them directly--In all cases except ghcPrimIds, there is a definition site in a-library module, which may be called (e.g. in higher order situations);-but the wired-in version means that the details are never read from-that module's interface file; instead, the full definition is right-here.--Note [ghcPrimIds (aka pseudoops)]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The ghcPrimIds--  * Are exported from GHC.Prim--  * Can't be defined in Haskell, and hence no Haskell binding site,-    but have perfectly reasonable unfoldings in Core--  * Either have a CompulsoryUnfolding (hence always inlined), or-        of an EvaldUnfolding and void representation (e.g. void#)--  * Are (or should be) defined in primops.txt.pp as 'pseudoop'-    Reason: that's how we generate documentation for them--Note [magicIds]-~~~~~~~~~~~~~~~-The magicIds--  * Are exported from GHC.Magic--  * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs).-    This definition at least generates Haddock documentation for them.--  * May or may not have a CompulsoryUnfolding.--  * But have some special behaviour that can't be done via an-    unfolding from an interface file--}--wiredInIds :: [Id]-wiredInIds-  =  magicIds-  ++ ghcPrimIds-  ++ errorIds           -- Defined in GHC.Core.Make--magicIds :: [Id]    -- See Note [magicIds]-magicIds = [lazyId, oneShotId, noinlineId]--ghcPrimIds :: [Id]  -- See Note [ghcPrimIds (aka pseudoops)]-ghcPrimIds-  = [ realWorldPrimId-    , voidPrimId-    , nullAddrId-    , seqId-    , magicDictId-    , coerceId-    , proxyHashId-    ]--{--************************************************************************-*                                                                      *-\subsection{Data constructors}-*                                                                      *-************************************************************************--The wrapper for a constructor is an ordinary top-level binding that evaluates-any strict args, unboxes any args that are going to be flattened, and calls-the worker.--We're going to build a constructor that looks like:--        data (Data a, C b) =>  T a b = T1 !a !Int b--        T1 = /\ a b ->-             \d1::Data a, d2::C b ->-             \p q r -> case p of { p ->-                       case q of { q ->-                       Con T1 [a,b] [p,q,r]}}--Notice that--* d2 is thrown away --- a context in a data decl is used to make sure-  one *could* construct dictionaries at the site the constructor-  is used, but the dictionary isn't actually used.--* We have to check that we can construct Data dictionaries for-  the types a and Int.  Once we've done that we can throw d1 away too.--* We use (case p of q -> ...) to evaluate p, rather than "seq" because-  all that matters is that the arguments are evaluated.  "seq" is-  very careful to preserve evaluation order, which we don't need-  to be here.--  You might think that we could simply give constructors some strictness-  info, like PrimOps, and let CoreToStg do the let-to-case transformation.-  But we don't do that because in the case of primops and functions strictness-  is a *property* not a *requirement*.  In the case of constructors we need to-  do something active to evaluate the argument.--  Making an explicit case expression allows the simplifier to eliminate-  it in the (common) case where the constructor arg is already evaluated.--Note [Wrappers for data instance tycons]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the case of data instances, the wrapper also applies the coercion turning-the representation type into the family instance type to cast the result of-the wrapper.  For example, consider the declarations--  data family Map k :: * -> *-  data instance Map (a, b) v = MapPair (Map a (Pair b v))--The tycon to which the datacon MapPair belongs gets a unique internal-name of the form :R123Map, and we call it the representation tycon.-In contrast, Map is the family tycon (accessible via-tyConFamInst_maybe). A coercion allows you to move between-representation and family type.  It is accessible from :R123Map via-tyConFamilyCoercion_maybe and has kind--  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}--The wrapper and worker of MapPair get the types--        -- Wrapper-  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v-  $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v)--        -- Worker-  MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v--This coercion is conditionally applied by wrapFamInstBody.--It's a bit more complicated if the data instance is a GADT as well!--   data instance T [a] where-        T1 :: forall b. b -> T [Maybe b]--Hence we translate to--        -- Wrapper-  $WT1 :: forall b. b -> T [Maybe b]-  $WT1 b v = T1 (Maybe b) b (Maybe b) v-                        `cast` sym (Co7T (Maybe b))--        -- Worker-  T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c--        -- Coercion from family type to representation type-  Co7T a :: T [a] ~ :R7T a--Newtype instances through an additional wrinkle into the mix. Consider the-following example (adapted from #15318, comment:2):--  data family T a-  newtype instance T [a] = MkT [a]--Within the newtype instance, there are three distinct types at play:--1. The newtype's underlying type, [a].-2. The instance's representation type, TList a (where TList is the-   representation tycon).-3. The family type, T [a].--We need two coercions in order to cast from (1) to (3):--(a) A newtype coercion axiom:--      axiom coTList a :: TList a ~ [a]--    (Where TList is the representation tycon of the newtype instance.)--(b) A data family instance coercion axiom:--      axiom coT a :: T [a] ~ TList a--When we translate the newtype instance to Core, we obtain:--    -- Wrapper-  $WMkT :: forall a. [a] -> T [a]-  $WMkT a x = MkT a x |> Sym (coT a)--    -- Worker-  MkT :: forall a. [a] -> TList [a]-  MkT a x = x |> Sym (coTList a)--Unlike for data instances, the worker for a newtype instance is actually an-executable function which expands to a cast, but otherwise, the general-strategy is essentially the same as for data instances. Also note that we have-a wrapper, which is unusual for a newtype, but we make GHC produce one anyway-for symmetry with the way data instances are handled.--Note [Newtype datacons]-~~~~~~~~~~~~~~~~~~~~~~~-The "data constructor" for a newtype should always be vanilla.  At one-point this wasn't true, because the newtype arising from-     class C a => D a-looked like-       newtype T:D a = D:D (C a)-so the data constructor for T:C had a single argument, namely the-predicate (C a).  But now we treat that as an ordinary argument, not-part of the theta-type, so all is well.--Note [Newtype workers]-~~~~~~~~~~~~~~~~~~~~~~-A newtype does not really have a worker. Instead, newtype constructors-just unfold into a cast. But we need *something* for, say, MkAge to refer-to. So, we do this:--* The Id used as the newtype worker will have a compulsory unfolding to-  a cast. See Note [Compulsory newtype unfolding]--* This Id is labeled as a DataConWrapId. We don't want to use a DataConWorkId,-  as those have special treatment in the back end.--* There is no top-level binding, because the compulsory unfolding-  means that it will be inlined (to a cast) at every call site.--We probably should have a NewtypeWorkId, but these Ids disappear as soon as-we desugar anyway, so it seems a step too far.--Note [Compulsory newtype unfolding]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Newtype wrappers, just like workers, have compulsory unfoldings.-This is needed so that two optimizations involving newtypes have the same-effect whether a wrapper is present or not:--(1) Case-of-known constructor.-    See Note [beta-reduction in exprIsConApp_maybe].--(2) Matching against the map/coerce RULE. Suppose we have the RULE--    {-# RULE "map/coerce" map coerce = ... #-}--    As described in Note [Getting the map/coerce RULE to work],-    the occurrence of 'coerce' is transformed into:--    {-# RULE "map/coerce" forall (c :: T1 ~R# T2).-                          map ((\v -> v) `cast` c) = ... #-}--    We'd like 'map Age' to match the LHS. For this to happen, Age-    must be unfolded, otherwise we'll be stuck. This is tested in T16208.--It also allows for the posssibility of levity polymorphic newtypes-with wrappers (with -XUnliftedNewtypes):--  newtype N (a :: TYPE r) = MkN a--With -XUnliftedNewtypes, this is allowed -- even though MkN is levity--polymorphic. It's OK because MkN evaporates in the compiled code, becoming-just a cast. That is, it has a compulsory unfolding. As long as its-argument is not levity-polymorphic (which it can't be, according to-Note [Levity polymorphism invariants] in GHC.Core), and it's saturated,-no levity-polymorphic code ends up in the code generator. The saturation-condition is effectively checked by Note [Detecting forced eta expansion]-in GHC.HsToCore.Expr.--However, if we make a *wrapper* for a newtype, we get into trouble.-The saturation condition is no longer checked (because hasNoBinding-returns False) and indeed we generate a forbidden levity-polymorphic-binding.--The solution is simple, though: just make the newtype wrappers-as ephemeral as the newtype workers. In other words, give the wrappers-compulsory unfoldings and no bindings. The compulsory unfolding is given-in wrap_unf in mkDataConRep, and the lack of a binding happens in-GHC.Iface.Tidy.getTyConImplicitBinds, where we say that a newtype has no-implicit bindings.--************************************************************************-*                                                                      *-\subsection{Dictionary selectors}-*                                                                      *-************************************************************************--Selecting a field for a dictionary.  If there is just one field, then-there's nothing to do.--Dictionary selectors may get nested forall-types.  Thus:--        class Foo a where-          op :: forall b. Ord b => a -> b -> b--Then the top-level type for op is--        op :: forall a. Foo a =>-              forall b. Ord b =>-              a -> b -> b---}--mkDictSelId :: Name          -- Name of one of the *value* selectors-                             -- (dictionary superclass or method)-            -> Class -> Id-mkDictSelId name clas-  = mkGlobalId (ClassOpId clas) name sel_ty info-  where-    tycon          = classTyCon clas-    sel_names      = map idName (classAllSelIds clas)-    new_tycon      = isNewTyCon tycon-    [data_con]     = tyConDataCons tycon-    tyvars         = dataConUserTyVarBinders data_con-    n_ty_args      = length tyvars-    arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses-    val_index      = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name--    sel_ty = mkForAllTys tyvars $-             mkInvisFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $-             getNth arg_tys val_index--    base_info = noCafIdInfo-                `setArityInfo`          1-                `setStrictnessInfo`     strict_sig-                `setCprInfo`            topCprSig-                `setLevityInfoWithType` sel_ty--    info | new_tycon-         = base_info `setInlinePragInfo` alwaysInlinePragma-                     `setUnfoldingInfo`  mkInlineUnfoldingWithArity 1-                                           (mkDictSelRhs clas val_index)-                   -- See Note [Single-method classes] in TcInstDcls-                   -- for why alwaysInlinePragma--         | otherwise-         = base_info `setRuleInfo` mkRuleInfo [rule]-                   -- Add a magic BuiltinRule, but no unfolding-                   -- so that the rule is always available to fire.-                   -- See Note [ClassOp/DFun selection] in TcInstDcls--    -- This is the built-in rule that goes-    --      op (dfT d1 d2) --->  opT d1 d2-    rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS`-                                     occNameFS (getOccName name)-                       , ru_fn    = name-                       , ru_nargs = n_ty_args + 1-                       , ru_try   = dictSelRule val_index n_ty_args }--        -- The strictness signature is of the form U(AAAVAAAA) -> T-        -- where the V depends on which item we are selecting-        -- It's worth giving one, so that absence info etc is generated-        -- even if the selector isn't inlined--    strict_sig = mkClosedStrictSig [arg_dmd] topDiv-    arg_dmd | new_tycon = evalDmd-            | otherwise = mkManyUsedDmd $-                          mkProdDmd [ if name == sel_name then evalDmd else absDmd-                                    | sel_name <- sel_names ]--mkDictSelRhs :: Class-             -> Int         -- 0-indexed selector among (superclasses ++ methods)-             -> CoreExpr-mkDictSelRhs clas val_index-  = mkLams tyvars (Lam dict_id rhs_body)-  where-    tycon          = classTyCon clas-    new_tycon      = isNewTyCon tycon-    [data_con]     = tyConDataCons tycon-    tyvars         = dataConUnivTyVars data_con-    arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses--    the_arg_id     = getNth arg_ids val_index-    pred           = mkClassPred clas (mkTyVarTys tyvars)-    dict_id        = mkTemplateLocal 1 pred-    arg_ids        = mkTemplateLocalsNum 2 arg_tys--    rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars)-                                                   (Var dict_id)-             | otherwise = mkSingleAltCase (Var dict_id) dict_id (DataAlt data_con)-                                           arg_ids (varToCoreExpr the_arg_id)-                                -- varToCoreExpr needed for equality superclass selectors-                                --   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }--dictSelRule :: Int -> Arity -> RuleFun--- Tries to persuade the argument to look like a constructor--- application, using exprIsConApp_maybe, and then selects--- from it---       sel_i t1..tk (D t1..tk op1 ... opm) = opi----dictSelRule val_index n_ty_args _ id_unf _ args-  | (dict_arg : _) <- drop n_ty_args args-  , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg-  = Just (wrapFloats floats $ getNth con_args val_index)-  | otherwise-  = Nothing--{--************************************************************************-*                                                                      *-        Data constructors-*                                                                      *-************************************************************************--}--mkDataConWorkId :: Name -> DataCon -> Id-mkDataConWorkId wkr_name data_con-  | isNewTyCon tycon-  = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info-      -- See Note [Newtype workers]--  | otherwise-  = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info--  where-    tycon  = dataConTyCon data_con  -- The representation TyCon-    wkr_ty = dataConRepType data_con--        ----------- Workers for data types ---------------    alg_wkr_info = noCafIdInfo-                   `setArityInfo`          wkr_arity-                   `setStrictnessInfo`     wkr_sig-                   `setCprInfo`            mkCprSig wkr_arity (dataConCPR data_con)-                   `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,-                                                           -- even if arity = 0-                   `setLevityInfoWithType` wkr_ty-                     -- NB: unboxed tuples have workers, so we can't use-                     -- setNeverLevPoly--    wkr_arity = dataConRepArity data_con-    wkr_sig   = mkClosedStrictSig (replicate wkr_arity topDmd) topDiv-        --      Note [Data-con worker strictness]-        -- Notice that we do *not* say the worker Id is strict-        -- even if the data constructor is declared strict-        --      e.g.    data T = MkT !(Int,Int)-        -- Why?  Because the *wrapper* $WMkT is strict (and its unfolding has-        -- case expressions that do the evals) but the *worker* MkT itself is-        --  not. If we pretend it is strict then when we see-        --      case x of y -> MkT y-        -- the simplifier thinks that y is "sure to be evaluated" (because-        -- the worker MkT is strict) and drops the case.  No, the workerId-        -- MkT is not strict.-        ---        -- However, the worker does have StrictnessMarks.  When the simplifier-        -- sees a pattern-        --      case e of MkT x -> ...-        -- it uses the dataConRepStrictness of MkT to mark x as evaluated;-        -- but that's fine... dataConRepStrictness comes from the data con-        -- not from the worker Id.--        ----------- Workers for newtypes ---------------    univ_tvs = dataConUnivTyVars data_con-    arg_tys  = dataConRepArgTys  data_con  -- Should be same as dataConOrigArgTys-    nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo-                  `setArityInfo` 1      -- Arity 1-                  `setInlinePragInfo`     alwaysInlinePragma-                  `setUnfoldingInfo`      newtype_unf-                  `setLevityInfoWithType` wkr_ty-    id_arg1      = mkTemplateLocal 1 (head arg_tys)-    res_ty_args  = mkTyCoVarTys univ_tvs-    newtype_unf  = ASSERT2( isVanillaDataCon data_con &&-                            isSingleton arg_tys-                          , ppr data_con  )-                              -- Note [Newtype datacons]-                   mkCompulsoryUnfolding $-                   mkLams univ_tvs $ Lam id_arg1 $-                   wrapNewTypeBody tycon res_ty_args (Var id_arg1)--dataConCPR :: DataCon -> CprResult-dataConCPR con-  | isDataTyCon tycon     -- Real data types only; that is,-                          -- not unboxed tuples or newtypes-  , null (dataConExTyCoVars con)  -- No existentials-  , wkr_arity > 0-  , wkr_arity <= mAX_CPR_SIZE-  = conCpr (dataConTag con)-  | otherwise-  = topCpr-  where-    tycon     = dataConTyCon con-    wkr_arity = dataConRepArity con--    mAX_CPR_SIZE :: Arity-    mAX_CPR_SIZE = 10-    -- We do not treat very big tuples as CPR-ish:-    --      a) for a start we get into trouble because there aren't-    --         "enough" unboxed tuple types (a tiresome restriction,-    --         but hard to fix),-    --      b) more importantly, big unboxed tuples get returned mainly-    --         on the stack, and are often then allocated in the heap-    --         by the caller.  So doing CPR for them may in fact make-    --         things worse.--{------------------------------------------------------         Data constructor representation------ This is where we decide how to wrap/unwrap the--- constructor fields--------------------------------------------------------}--type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)-  -- Unbox: bind rep vars by decomposing src var--data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr))-  -- Box:   build src arg using these rep vars---- | Data Constructor Boxer-newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))-                       -- Bind these src-level vars, returning the-                       -- rep-level vars to bind in the pattern--vanillaDataConBoxer :: DataConBoxer--- No transformation on arguments needed-vanillaDataConBoxer = DCB (\_tys args -> return (args, []))--{--Note [Inline partially-applied constructor wrappers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--We allow the wrapper to inline when partially applied to avoid-boxing values unnecessarily. For example, consider--   data Foo a = Foo !Int a--   instance Traversable Foo where-     traverse f (Foo i a) = Foo i <$> f a--This desugars to--   traverse f foo = case foo of-        Foo i# a -> let i = I# i#-                    in map ($WFoo i) (f a)--If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`.-But if we inline the wrapper, we get--   map (\a. case i of I# i# a -> Foo i# a) (f a)--and now case-of-known-constructor eliminates the redundant allocation.---}--mkDataConRep :: DynFlags-             -> FamInstEnvs-             -> Name-             -> Maybe [HsImplBang]-                -- See Note [Bangs on imported data constructors]-             -> DataCon-             -> UniqSM DataConRep-mkDataConRep dflags fam_envs wrap_name mb_bangs data_con-  | not wrapper_reqd-  = return NoDataConRep--  | otherwise-  = do { wrap_args <- mapM newLocal wrap_arg_tys-       ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers)-                                 initial_wrap_app--       ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info-             wrap_info = noCafIdInfo-                         `setArityInfo`         wrap_arity-                             -- It's important to specify the arity, so that partial-                             -- applications are treated as values-                         `setInlinePragInfo`    wrap_prag-                         `setUnfoldingInfo`     wrap_unf-                         `setStrictnessInfo`    wrap_sig-                         `setCprInfo`           mkCprSig wrap_arity (dataConCPR data_con)-                             -- We need to get the CAF info right here because GHC.Iface.Tidy-                             -- does not tidy the IdInfo of implicit bindings (like the wrapper)-                             -- so it not make sure that the CAF info is sane-                         `setLevityInfoWithType` wrap_ty--             wrap_sig = mkClosedStrictSig wrap_arg_dmds topDiv--             wrap_arg_dmds =-               replicate (length theta) topDmd ++ map mk_dmd arg_ibangs-               -- Don't forget the dictionary arguments when building-               -- the strictness signature (#14290).--             mk_dmd str | isBanged str = evalDmd-                        | otherwise    = topDmd--             wrap_prag = alwaysInlinePragma `setInlinePragmaActivation`-                         activeDuringFinal-                         -- See Note [Activation for data constructor wrappers]--             -- The wrapper will usually be inlined (see wrap_unf), so its-             -- strictness and CPR info is usually irrelevant. But this is-             -- not always the case; GHC may choose not to inline it. In-             -- particular, the wrapper constructor is not inlined inside-             -- an INLINE rhs or when it is not applied to any arguments.-             -- See Note [Inline partially-applied constructor wrappers]-             -- Passing Nothing here allows the wrapper to inline when-             -- unsaturated.-             wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs-                        -- See Note [Compulsory newtype unfolding]-                      | otherwise        = mkInlineUnfolding wrap_rhs-             wrap_rhs = mkLams wrap_tvs $-                        mkLams wrap_args $-                        wrapFamInstBody tycon res_ty_args $-                        wrap_body--       ; return (DCR { dcr_wrap_id = wrap_id-                     , dcr_boxer   = mk_boxer boxers-                     , dcr_arg_tys = rep_tys-                     , dcr_stricts = rep_strs-                       -- For newtypes, dcr_bangs is always [HsLazy].-                       -- See Note [HsImplBangs for newtypes].-                     , dcr_bangs   = arg_ibangs }) }--  where-    (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty)-      = dataConFullSig data_con-    wrap_tvs     = dataConUserTyVars data_con-    res_ty_args  = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs--    tycon        = dataConTyCon data_con       -- The representation TyCon (not family)-    wrap_ty      = dataConUserType data_con-    ev_tys       = eqSpecPreds eq_spec ++ theta-    all_arg_tys  = ev_tys ++ orig_arg_tys-    ev_ibangs    = map (const HsLazy) ev_tys-    orig_bangs   = dataConSrcBangs data_con--    wrap_arg_tys = theta ++ orig_arg_tys-    wrap_arity   = count isCoVar ex_tvs + length wrap_arg_tys-             -- The wrap_args are the arguments *other than* the eq_spec-             -- Because we are going to apply the eq_spec args manually in the-             -- wrapper--    new_tycon = isNewTyCon tycon-    arg_ibangs-      | new_tycon-      = ASSERT( isSingleton orig_arg_tys )-        [HsLazy] -- See Note [HsImplBangs for newtypes]-      | otherwise-      = case mb_bangs of-          Nothing    -> zipWith (dataConSrcToImplBang dflags fam_envs)-                                orig_arg_tys orig_bangs-          Just bangs -> bangs--    (rep_tys_w_strs, wrappers)-      = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs))--    (unboxers, boxers) = unzip wrappers-    (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)--    wrapper_reqd =-        (not new_tycon-                     -- (Most) newtypes have only a worker, with the exception-                     -- of some newtypes written with GADT syntax. See below.-         && (any isBanged (ev_ibangs ++ arg_ibangs)-                     -- Some forcing/unboxing (includes eq_spec)-             || (not $ null eq_spec))) -- GADT-      || isFamInstTyCon tycon -- Cast result-      || dataConUserTyVarsArePermuted data_con-                     -- If the data type was written with GADT syntax and-                     -- orders the type variables differently from what the-                     -- worker expects, it needs a data con wrapper to reorder-                     -- the type variables.-                     -- See Note [Data con wrappers and GADT syntax].--    initial_wrap_app = Var (dataConWorkId data_con)-                       `mkTyApps`  res_ty_args-                       `mkVarApps` ex_tvs-                       `mkCoApps`  map (mkReflCo Nominal . eqSpecType) eq_spec--    mk_boxer :: [Boxer] -> DataConBoxer-    mk_boxer boxers = DCB (\ ty_args src_vars ->-                      do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars-                               subst1 = zipTvSubst univ_tvs ty_args-                               subst2 = extendTCvSubstList subst1 ex_tvs-                                                           (mkTyCoVarTys ex_vars)-                         ; (rep_ids, binds) <- go subst2 boxers term_vars-                         ; return (ex_vars ++ rep_ids, binds) } )--    go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])-    go subst (UnitBox : boxers) (src_var : src_vars)-      = do { (rep_ids2, binds) <- go subst boxers src_vars-           ; return (src_var : rep_ids2, binds) }-    go subst (Boxer boxer : boxers) (src_var : src_vars)-      = do { (rep_ids1, arg)  <- boxer subst-           ; (rep_ids2, binds) <- go subst boxers src_vars-           ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) }-    go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con)--    mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr-    mk_rep_app [] con_app-      = return con_app-    mk_rep_app ((wrap_arg, unboxer) : prs) con_app-      = do { (rep_ids, unbox_fn) <- unboxer wrap_arg-           ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)-           ; return (unbox_fn expr) }--{- Note [Activation for data constructor wrappers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The Activation on a data constructor wrapper allows it to inline only in Phase-0. This way rules have a chance to fire if they mention a data constructor on-the left-   RULE "foo"  f (K a b) = ...-Since the LHS of rules are simplified with InitialPhase, we won't-inline the wrapper on the LHS either.--On the other hand, this means that exprIsConApp_maybe must be able to deal-with wrappers so that case-of-constructor is not delayed; see-Note [exprIsConApp_maybe on data constructors with wrappers] for details.--It used to activate in phases 2 (afterInitial) and later, but it makes it-awkward to write a RULE[1] with a constructor on the left: it would work if a-constructor has no wrapper, but whether a constructor has a wrapper depends, for-instance, on the order of type argument of that constructors. Therefore changing-the order of type argument could make previously working RULEs fail.--See also https://gitlab.haskell.org/ghc/ghc/issues/15840 .---Note [Bangs on imported data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs-from imported modules.--- Nothing <=> use HsSrcBangs-- Just bangs <=> use HsImplBangs--For imported types we can't work it all out from the HsSrcBangs,-because we want to be very sure to follow what the original module-(where the data type was declared) decided, and that depends on what-flags were enabled when it was compiled. So we record the decisions in-the interface file.--The HsImplBangs passed are in 1-1 correspondence with the-dataConOrigArgTys of the DataCon.--Note [Data con wrappers and unlifted types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   data T = MkT !Int#--We certainly do not want to make a wrapper-   $WMkT x = case x of y { DEFAULT -> MkT y }--For a start, it's still to generate a no-op.  But worse, since wrappers-are currently injected at TidyCore, we don't even optimise it away!-So the stupid case expression stays there.  This actually happened for-the Integer data type (see #1600 comment:66)!--Note [Data con wrappers and GADT syntax]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider these two very similar data types:--  data T1 a b = MkT1 b--  data T2 a b where-    MkT2 :: forall b a. b -> T2 a b--Despite their similar appearance, T2 will have a data con wrapper but T1 will-not. What sets them apart? The types of their constructors, which are:--  MkT1 :: forall a b. b -> T1 a b-  MkT2 :: forall b a. b -> T2 a b--MkT2's use of GADT syntax allows it to permute the order in which `a` and `b`-would normally appear. See Note [DataCon user type variable binders] in DataCon-for further discussion on this topic.--The worker data cons for T1 and T2, however, both have types such that `a` is-expected to come before `b` as arguments. Because MkT2 permutes this order, it-needs a data con wrapper to swizzle around the type variables to be in the-order the worker expects.--A somewhat surprising consequence of this is that *newtypes* can have data con-wrappers! After all, a newtype can also be written with GADT syntax:--  newtype T3 a b where-    MkT3 :: forall b a. b -> T3 a b--Again, this needs a wrapper data con to reorder the type variables. It does-mean that this newtype constructor requires another level of indirection when-being called, but the inliner should make swift work of that.--Note [HsImplBangs for newtypes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Most of the time, we use the dataConSrctoImplBang function to decide what-strictness/unpackedness to use for the fields of a data type constructor. But-there is an exception to this rule: newtype constructors. You might not think-that newtypes would pose a challenge, since newtypes are seemingly forbidden-from having strictness annotations in the first place. But consider this-(from #16141):--  {-# LANGUAGE StrictData #-}-  {-# OPTIONS_GHC -O #-}-  newtype T a b where-    MkT :: forall b a. Int -> T a b--Because StrictData (plus optimization) is enabled, invoking-dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#!-This would be disastrous, since the wrapper for `MkT` uses a coercion involving-Int, not Int#.--Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the-case of a newtype constructor, we simply hardcode its dcr_bangs field to-[HsLazy].--}----------------------------newLocal :: Type -> UniqSM Var-newLocal ty = do { uniq <- getUniqueM-                 ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) }-                 -- We should not have "OrCoVar" here, this is a bug (#17545)----- | Unpack/Strictness decisions from source module.------ This function should only ever be invoked for data constructor fields, and--- never on the field of a newtype constructor.--- See @Note [HsImplBangs for newtypes]@.-dataConSrcToImplBang-   :: DynFlags-   -> FamInstEnvs-   -> Type-   -> HsSrcBang-   -> HsImplBang--dataConSrcToImplBang dflags fam_envs arg_ty-                     (HsSrcBang ann unpk NoSrcStrict)-  | xopt LangExt.StrictData dflags -- StrictData => strict field-  = dataConSrcToImplBang dflags fam_envs arg_ty-                  (HsSrcBang ann unpk SrcStrict)-  | otherwise -- no StrictData => lazy field-  = HsLazy--dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)-  = HsLazy--dataConSrcToImplBang dflags fam_envs arg_ty-                     (HsSrcBang _ unpk_prag SrcStrict)-  | isUnliftedType arg_ty-  = HsLazy  -- For !Int#, say, use HsLazy-            -- See Note [Data con wrappers and unlifted types]--  | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas-          -- Don't unpack if we aren't optimising; rather arbitrarily,-          -- we use -fomit-iface-pragmas as the indication-  , let mb_co   = topNormaliseType_maybe fam_envs arg_ty-                     -- Unwrap type families and newtypes-        arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }-  , isUnpackableType dflags fam_envs arg_ty'-  , (rep_tys, _) <- dataConArgUnpack arg_ty'-  , case unpk_prag of-      NoSrcUnpack ->-        gopt Opt_UnboxStrictFields dflags-            || (gopt Opt_UnboxSmallStrictFields dflags-                && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields]-      srcUnpack -> isSrcUnpacked srcUnpack-  = case mb_co of-      Nothing     -> HsUnpack Nothing-      Just (co,_) -> HsUnpack (Just co)--  | otherwise -- Record the strict-but-no-unpack decision-  = HsStrict----- | Wrappers/Workers and representation following Unpack/Strictness--- decisions-dataConArgRep-  :: Type-  -> HsImplBang-  -> ([(Type,StrictnessMark)] -- Rep types-     ,(Unboxer,Boxer))--dataConArgRep arg_ty HsLazy-  = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))--dataConArgRep arg_ty HsStrict-  = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))--dataConArgRep arg_ty (HsUnpack Nothing)-  | (rep_tys, wrappers) <- dataConArgUnpack arg_ty-  = (rep_tys, wrappers)--dataConArgRep _ (HsUnpack (Just co))-  | let co_rep_ty = coercionRKind co-  , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty-  = (rep_tys, wrapCo co co_rep_ty wrappers)-----------------------------wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)-wrapCo co rep_ty (unbox_rep, box_rep)  -- co :: arg_ty ~ rep_ty-  = (unboxer, boxer)-  where-    unboxer arg_id = do { rep_id <- newLocal rep_ty-                        ; (rep_ids, rep_fn) <- unbox_rep rep_id-                        ; let co_bind = NonRec rep_id (Var arg_id `Cast` co)-                        ; return (rep_ids, Let co_bind . rep_fn) }-    boxer = Boxer $ \ subst ->-            do { (rep_ids, rep_expr)-                    <- case box_rep of-                         UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty)-                                       ; return ([rep_id], Var rep_id) }-                         Boxer boxer -> boxer subst-               ; let sco = substCoUnchecked subst co-               ; return (rep_ids, rep_expr `Cast` mkSymCo sco) }---------------------------seqUnboxer :: Unboxer-seqUnboxer v = return ([v], mkDefaultCase (Var v) v)--unitUnboxer :: Unboxer-unitUnboxer v = return ([v], \e -> e)--unitBoxer :: Boxer-unitBoxer = UnitBox----------------------------dataConArgUnpack-   :: Type-   ->  ( [(Type, StrictnessMark)]   -- Rep types-       , (Unboxer, Boxer) )--dataConArgUnpack arg_ty-  | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty-  , Just con <- tyConSingleAlgDataCon_maybe tc-      -- NB: check for an *algebraic* data type-      -- A recursive newtype might mean that-      -- 'arg_ty' is a newtype-  , let rep_tys = dataConInstArgTys con tc_args-  = ASSERT( null (dataConExTyCoVars con) )-      -- Note [Unpacking GADTs and existentials]-    ( rep_tys `zip` dataConRepStrictness con-    ,( \ arg_id ->-       do { rep_ids <- mapM newLocal rep_tys-          ; let unbox_fn body-                  = mkSingleAltCase (Var arg_id) arg_id-                             (DataAlt con) rep_ids body-          ; return (rep_ids, unbox_fn) }-     , Boxer $ \ subst ->-       do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys-          ; return (rep_ids, Var (dataConWorkId con)-                             `mkTyApps` (substTysUnchecked subst tc_args)-                             `mkVarApps` rep_ids ) } ) )-  | otherwise-  = pprPanic "dataConArgUnpack" (ppr arg_ty)-    -- An interface file specified Unpacked, but we couldn't unpack it--isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool--- True if we can unpack the UNPACK the argument type--- See Note [Recursive unboxing]--- We look "deeply" inside rather than relying on the DataCons--- we encounter on the way, because otherwise we might well--- end up relying on ourselves!-isUnpackableType dflags fam_envs ty-  | Just data_con <- unpackable_type ty-  = ok_con_args emptyNameSet data_con-  | otherwise-  = False-  where-    ok_con_args dcs con-       | dc_name `elemNameSet` dcs-       = False-       | otherwise-       = all (ok_arg dcs')-             (dataConOrigArgTys con `zip` dataConSrcBangs con)-          -- NB: dataConSrcBangs gives the *user* request;-          -- We'd get a black hole if we used dataConImplBangs-       where-         dc_name = getName con-         dcs' = dcs `extendNameSet` dc_name--    ok_arg dcs (ty, bang)-      = not (attempt_unpack bang) || ok_ty dcs norm_ty-      where-        norm_ty = topNormaliseType fam_envs ty--    ok_ty dcs ty-      | Just data_con <- unpackable_type ty-      = ok_con_args dcs data_con-      | otherwise-      = True        -- NB True here, in contrast to False at top level--    attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)-      = xopt LangExt.StrictData dflags-    attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)-      = True-    attempt_unpack (HsSrcBang _  NoSrcUnpack SrcStrict)-      = True  -- Be conservative-    attempt_unpack (HsSrcBang _  NoSrcUnpack NoSrcStrict)-      = xopt LangExt.StrictData dflags -- Be conservative-    attempt_unpack _ = False--    unpackable_type :: Type -> Maybe DataCon-    -- Works just on a single level-    unpackable_type ty-      | Just (tc, _) <- splitTyConApp_maybe ty-      , Just data_con <- tyConSingleAlgDataCon_maybe tc-      , null (dataConExTyCoVars data_con)-          -- See Note [Unpacking GADTs and existentials]-      = Just data_con-      | otherwise-      = Nothing--{--Note [Unpacking GADTs and existentials]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is nothing stopping us unpacking a data type with equality-components, like-  data Equal a b where-    Equal :: Equal a a--And it'd be fine to unpack a product type with existential components-too, but that would require a bit more plumbing, so currently we don't.--So for now we require: null (dataConExTyCoVars data_con)-See #14978--Note [Unpack one-wide fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The flag UnboxSmallStrictFields ensures that any field that can-(safely) be unboxed to a word-sized unboxed field, should be so unboxed.-For example:--    data A = A Int#-    newtype B = B A-    data C = C !B-    data D = D !C-    data E = E !()-    data F = F !D-    data G = G !F !F--All of these should have an Int# as their representation, except-G which should have two Int#s.--However--    data T = T !(S Int)-    data S = S !a--Here we can represent T with an Int#.--Note [Recursive unboxing]-~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  data R = MkR {-# UNPACK #-} !S Int-  data S = MkS {-# UNPACK #-} !Int-The representation arguments of MkR are the *representation* arguments-of S (plus Int); the rep args of MkS are Int#.  This is all fine.--But be careful not to try to unbox this!-        data T = MkT {-# UNPACK #-} !T Int-Because then we'd get an infinite number of arguments.--Here is a more complicated case:-        data S = MkS {-# UNPACK #-} !T Int-        data T = MkT {-# UNPACK #-} !S Int-Each of S and T must decide independently whether to unpack-and they had better not both say yes. So they must both say no.--Also behave conservatively when there is no UNPACK pragma-        data T = MkS !T Int-with -funbox-strict-fields or -funbox-small-strict-fields-we need to behave as if there was an UNPACK pragma there.--But it's the *argument* type that matters. This is fine:-        data S = MkS S !Int-because Int is non-recursive.--************************************************************************-*                                                                      *-        Wrapping and unwrapping newtypes and type families-*                                                                      *-************************************************************************--}--wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr--- The wrapper for the data constructor for a newtype looks like this:---      newtype T a = MkT (a,Int)---      MkT :: forall a. (a,Int) -> T a---      MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)--- where CoT is the coercion TyCon associated with the newtype------ The call (wrapNewTypeBody T [a] e) returns the--- body of the wrapper, namely---      e `cast` (CoT [a])------ If a coercion constructor is provided in the newtype, then we use--- it, otherwise the wrap/unwrap are both no-ops--wrapNewTypeBody tycon args result_expr-  = ASSERT( isNewTyCon tycon )-    mkCast result_expr (mkSymCo co)-  where-    co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []---- When unwrapping, we do *not* apply any family coercion, because this will--- be done via a CoPat by the type checker.  We have to do it this way as--- computing the right type arguments for the coercion requires more than just--- a splitting operation (cf, TcPat.tcConPat).--unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr-unwrapNewTypeBody tycon args result_expr-  = ASSERT( isNewTyCon tycon )-    mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [])---- If the type constructor is a representation type of a data instance, wrap--- the expression into a cast adjusting the expression type, which is an--- instance of the representation type, to the corresponding instance of the--- family instance type.--- See Note [Wrappers for data instance tycons]-wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr-wrapFamInstBody tycon args body-  | Just co_con <- tyConFamilyCoercion_maybe tycon-  = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args []))-  | otherwise-  = body--{--************************************************************************-*                                                                      *-\subsection{Primitive operations}-*                                                                      *-************************************************************************--}--mkPrimOpId :: PrimOp -> Id-mkPrimOpId prim_op-  = id-  where-    (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op-    ty   = mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty)-    name = mkWiredInName gHC_PRIM (primOpOcc prim_op)-                         (mkPrimOpIdUnique (primOpTag prim_op))-                         (AnId id) UserSyntax-    id   = mkGlobalId (PrimOpId prim_op) name ty info--    -- PrimOps don't ever construct a product, but we want to preserve bottoms-    cpr-      | isBotDiv (snd (splitStrictSig strict_sig)) = botCpr-      | otherwise                                  = topCpr--    info = noCafIdInfo-           `setRuleInfo`           mkRuleInfo (maybeToList $ primOpRules name prim_op)-           `setArityInfo`          arity-           `setStrictnessInfo`     strict_sig-           `setCprInfo`            mkCprSig arity cpr-           `setInlinePragInfo`     neverInlinePragma-           `setLevityInfoWithType` res_ty-               -- We give PrimOps a NOINLINE pragma so that we don't-               -- get silly warnings from Desugar.dsRule (the inline_shadows_rule-               -- test) about a RULE conflicting with a possible inlining-               -- cf #7287---- For each ccall we manufacture a separate CCallOpId, giving it--- a fresh unique, a type that is correct for this particular ccall,--- and a CCall structure that gives the correct details about calling--- convention etc.------ The *name* of this Id is a local name whose OccName gives the full--- details of the ccall, type and all.  This means that the interface--- file reader can reconstruct a suitable Id--mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id-mkFCallId dflags uniq fcall ty-  = ASSERT( noFreeVarsOfType ty )-    -- A CCallOpId should have no free type variables;-    -- when doing substitutions won't substitute over it-    mkGlobalId (FCallId fcall) name ty info-  where-    occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty))-    -- The "occurrence name" of a ccall is the full info about the-    -- ccall; it is encoded, but may have embedded spaces etc!--    name = mkFCallName uniq occ_str--    info = noCafIdInfo-           `setArityInfo`          arity-           `setStrictnessInfo`     strict_sig-           `setCprInfo`            topCprSig-           `setLevityInfoWithType` ty--    (bndrs, _) = tcSplitPiTys ty-    arity      = count isAnonTyCoBinder bndrs-    strict_sig = mkClosedStrictSig (replicate arity topDmd) topDiv-    -- the call does not claim to be strict in its arguments, since they-    -- may be lifted (foreign import prim) and the called code doesn't-    -- necessarily force them. See #11076.-{--************************************************************************-*                                                                      *-\subsection{DictFuns and default methods}-*                                                                      *-************************************************************************--Note [Dict funs and default methods]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Dict funs and default methods are *not* ImplicitIds.  Their definition-involves user-written code, so we can't figure out their strictness etc-based on fixed info, as we can for constructors and record selectors (say).--NB: See also Note [Exported LocalIds] in Id--}--mkDictFunId :: Name      -- Name to use for the dict fun;-            -> [TyVar]-            -> ThetaType-            -> Class-            -> [Type]-            -> Id--- Implements the DFun Superclass Invariant (see TcInstDcls)--- See Note [Dict funs and default methods]--mkDictFunId dfun_name tvs theta clas tys-  = mkExportedLocalId (DFunId is_nt)-                      dfun_name-                      dfun_ty-  where-    is_nt = isNewTyCon (classTyCon clas)-    dfun_ty = mkDictFunTy tvs theta clas tys--mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type-mkDictFunTy tvs theta clas tys- = mkSpecSigmaTy tvs theta (mkClassPred clas tys)--{--************************************************************************-*                                                                      *-\subsection{Un-definable}-*                                                                      *-************************************************************************--These Ids can't be defined in Haskell.  They could be defined in-unfoldings in the wired-in GHC.Prim interface file, but we'd have to-ensure that they were definitely, definitely inlined, because there is-no curried identifier for them.  That's what mkCompulsoryUnfolding-does.  If we had a way to get a compulsory unfolding from an interface-file, we could do that, but we don't right now.--The type variables we use here are "open" type variables: this means-they can unify with both unlifted and lifted types.  Hence we provide-another gun with which to shoot yourself in the foot.--}--nullAddrName, seqName,-   realWorldName, voidPrimIdName, coercionTokenName,-   magicDictName, coerceName, proxyName :: Name-nullAddrName      = mkWiredInIdName gHC_PRIM  (fsLit "nullAddr#")      nullAddrIdKey      nullAddrId-seqName           = mkWiredInIdName gHC_PRIM  (fsLit "seq")            seqIdKey           seqId-realWorldName     = mkWiredInIdName gHC_PRIM  (fsLit "realWorld#")     realWorldPrimIdKey realWorldPrimId-voidPrimIdName    = mkWiredInIdName gHC_PRIM  (fsLit "void#")          voidPrimIdKey      voidPrimId-coercionTokenName = mkWiredInIdName gHC_PRIM  (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId-magicDictName     = mkWiredInIdName gHC_PRIM  (fsLit "magicDict")      magicDictKey       magicDictId-coerceName        = mkWiredInIdName gHC_PRIM  (fsLit "coerce")         coerceKey          coerceId-proxyName         = mkWiredInIdName gHC_PRIM  (fsLit "proxy#")         proxyHashKey       proxyHashId--lazyIdName, oneShotName, noinlineIdName :: Name-lazyIdName        = mkWiredInIdName gHC_MAGIC (fsLit "lazy")           lazyIdKey          lazyId-oneShotName       = mkWiredInIdName gHC_MAGIC (fsLit "oneShot")        oneShotKey         oneShotId-noinlineIdName    = mkWiredInIdName gHC_MAGIC (fsLit "noinline")       noinlineIdKey      noinlineId---------------------------------------------------proxyHashId :: Id-proxyHashId-  = pcMiscPrelId proxyName ty-       (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]-                    `setNeverLevPoly`  ty )-  where-    -- proxy# :: forall {k} (a:k). Proxy# k a-    ---    -- The visibility of the `k` binder is Inferred to match the type of the-    -- Proxy data constructor (#16293).-    [kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id-    kv_ty   = mkTyVarTy kv-    tv_ty   = mkTyVarTy tv-    ty      = mkInvForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty---------------------------------------------------nullAddrId :: Id--- nullAddr# :: Addr#--- The reason it is here is because we don't provide--- a way to write this literal in Haskell.-nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info-  where-    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma-                       `setUnfoldingInfo`  mkCompulsoryUnfolding (Lit nullAddrLit)-                       `setNeverLevPoly`   addrPrimTy---------------------------------------------------seqId :: Id     -- See Note [seqId magic]-seqId = pcMiscPrelId seqName ty info-  where-    info = noCafIdInfo `setInlinePragInfo` inline_prag-                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs--    inline_prag-         = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter-                 NoSourceText 0-                  -- Make 'seq' not inline-always, so that simpleOptExpr-                  -- (see GHC.Core.Subst.simple_app) won't inline 'seq' on the-                  -- LHS of rules.  That way we can have rules for 'seq';-                  -- see Note [seqId magic]--    -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b-    ty  =-      mkInvForAllTy runtimeRep2TyVar-      $ mkSpecForAllTys [alphaTyVar, openBetaTyVar]-      $ mkVisFunTy alphaTy (mkVisFunTy openBetaTy openBetaTy)--    [x,y] = mkTemplateLocals [alphaTy, openBetaTy]-    rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $-          Case (Var x) x openBetaTy [(DEFAULT, [], Var y)]---------------------------------------------------lazyId :: Id    -- See Note [lazyId magic]-lazyId = pcMiscPrelId lazyIdName ty info-  where-    info = noCafIdInfo `setNeverLevPoly` ty-    ty  = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy)--noinlineId :: Id -- See Note [noinlineId magic]-noinlineId = pcMiscPrelId noinlineIdName ty info-  where-    info = noCafIdInfo `setNeverLevPoly` ty-    ty  = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy)--oneShotId :: Id -- See Note [The oneShot function]-oneShotId = pcMiscPrelId oneShotName ty info-  where-    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma-                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs-    ty  = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar-                          , openAlphaTyVar, openBetaTyVar ]-                          (mkVisFunTy fun_ty fun_ty)-    fun_ty = mkVisFunTy openAlphaTy openBetaTy-    [body, x] = mkTemplateLocals [fun_ty, openAlphaTy]-    x' = setOneShotLambda x  -- Here is the magic bit!-    rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar-                 , openAlphaTyVar, openBetaTyVar-                 , body, x'] $-          Var body `App` Var x-----------------------------------------------------------------------------------magicDictId :: Id  -- See Note [magicDictId magic]-magicDictId = pcMiscPrelId magicDictName ty info-  where-  info = noCafIdInfo `setInlinePragInfo` neverInlinePragma-                     `setNeverLevPoly`   ty-  ty   = mkSpecForAllTys [alphaTyVar] alphaTy------------------------------------------------------------------------------------coerceId :: Id-coerceId = pcMiscPrelId coerceName ty info-  where-    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma-                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs-    eqRTy     = mkTyConApp coercibleTyCon [ tYPE r , a, b ]-    eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ]-    ty        = mkForAllTys [ Bndr rv Inferred-                            , Bndr av Specified-                            , Bndr bv Specified-                            ] $-                mkInvisFunTy eqRTy $-                mkVisFunTy a b--    bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy-                        (\r -> [tYPE r, tYPE r])--    [r, a, b] = mkTyVarTys bndrs--    [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy]-    rhs = mkLams (bndrs ++ [eqR, x]) $-          mkWildCase (Var eqR) eqRTy b $-          [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))]--{--Note [seqId magic]-~~~~~~~~~~~~~~~~~~-'GHC.Prim.seq' is special in several ways.--a) Its fixity is set in GHC.Iface.Load.ghcPrimIface--b) It has quite a bit of desugaring magic.-   See GHC.HsToCore.Utils.hs Note [Desugaring seq (1)] and (2) and (3)--c) There is some special rule handing: Note [User-defined RULES for seq]--Historical note:-    In TcExpr we used to need a special typing rule for 'seq', to handle calls-    whose second argument had an unboxed type, e.g.  x `seq` 3#--    However, with levity polymorphism we can now give seq the type seq ::-    forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b which handles this-    case without special treatment in the typechecker.--Note [User-defined RULES for seq]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Roman found situations where he had-      case (f n) of _ -> e-where he knew that f (which was strict in n) would terminate if n did.-Notice that the result of (f n) is discarded. So it makes sense to-transform to-      case n of _ -> e--Rather than attempt some general analysis to support this, I've added-enough support that you can do this using a rewrite rule:--  RULE "f/seq" forall n.  seq (f n) = seq n--You write that rule.  When GHC sees a case expression that discards-its result, it mentally transforms it to a call to 'seq' and looks for-a RULE.  (This is done in Simplify.trySeqRules.)  As usual, the-correctness of the rule is up to you.--VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2.-If we wrote-  RULE "f/seq" forall n e.  seq (f n) e = seq n e-with rule arity 2, then two bad things would happen:--  - The magical desugaring done in Note [seqId magic] item (b)-    for saturated application of 'seq' would turn the LHS into-    a case expression!--  - The code in Simplify.rebuildCase would need to actually supply-    the value argument, which turns out to be awkward.--See also: Note [User-defined RULES for seq] in Simplify.---Note [lazyId magic]-~~~~~~~~~~~~~~~~~~~-lazy :: forall a?. a? -> a?   (i.e. works for unboxed types too)--'lazy' is used to make sure that a sub-expression, and its free variables,-are truly used call-by-need, with no code motion.  Key examples:--* pseq:    pseq a b = a `seq` lazy b-  We want to make sure that the free vars of 'b' are not evaluated-  before 'a', even though the expression is plainly strict in 'b'.--* catch:   catch a b = catch# (lazy a) b-  Again, it's clear that 'a' will be evaluated strictly (and indeed-  applied to a state token) but we want to make sure that any exceptions-  arising from the evaluation of 'a' are caught by the catch (see-  #11555).--Implementing 'lazy' is a bit tricky:--* It must not have a strictness signature: by being a built-in Id,-  all the info about lazyId comes from here, not from GHC.Base.hi.-  This is important, because the strictness analyser will spot it as-  strict!--* It must not have an unfolding: it gets "inlined" by a HACK in-  CorePrep. It's very important to do this inlining *after* unfoldings-  are exposed in the interface file.  Otherwise, the unfolding for-  (say) pseq in the interface file will not mention 'lazy', so if we-  inline 'pseq' we'll totally miss the very thing that 'lazy' was-  there for in the first place. See #3259 for a real world-  example.--* Suppose CorePrep sees (catch# (lazy e) b).  At all costs we must-  avoid using call by value here:-     case e of r -> catch# r b-  Avoiding that is the whole point of 'lazy'.  So in CorePrep (which-  generate the 'case' expression for a call-by-value call) we must-  spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let'-  instead.--* lazyId is defined in GHC.Base, so we don't *have* to inline it.  If it-  appears un-applied, we'll end up just calling it.--Note [noinlineId magic]-~~~~~~~~~~~~~~~~~~~~~~~-noinline :: forall a. a -> a--'noinline' is used to make sure that a function f is never inlined,-e.g., as in 'noinline f x'.  Ordinarily, the identity function with NOINLINE-could be used to achieve this effect; however, this has the unfortunate-result of leaving a (useless) call to noinline at runtime.  So we have-a little bit of magic to optimize away 'noinline' after we are done-running the simplifier.--'noinline' needs to be wired-in because it gets inserted automatically-when we serialize an expression to the interface format. See-Note [Inlining and hs-boot files] in GHC.CoreToIface--Note that noinline as currently implemented can hide some simplifications since-it hides strictness from the demand analyser. Specifically, the demand analyser-will treat 'noinline f x' as lazy in 'x', even if the demand signature of 'f'-specifies that it is strict in its argument. We considered fixing this this by adding a-special case to the demand analyser to address #16588. However, the special-case seemed like a large and expensive hammer to address a rare case and-consequently we rather opted to use a more minimal solution.--Note [The oneShot function]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the context of making left-folds fuse somewhat okish (see ticket #7994-and Note [Left folds via right fold]) it was determined that it would be useful-if library authors could explicitly tell the compiler that a certain lambda is-called at most once. The oneShot function allows that.--'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted-types as well (#10744); e.g.-   oneShot (\x:Int# -> x +# 1#)--Like most magic functions it has a compulsory unfolding, so there is no need-for a real definition somewhere. We have one in GHC.Magic for the convenience-of putting the documentation there.--It uses `setOneShotLambda` on the lambda's binder. That is the whole magic:--A typical call looks like-     oneShot (\y. e)-after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get-     (\f \x[oneshot]. f x) (\y. e)- --> \x[oneshot]. ((\y.e) x)- --> \x[oneshot] e[x/y]-which is what we want.--It is only effective if the one-shot info survives as long as possible; in-particular it must make it into the interface in unfoldings. See Note [Preserve-OneShotInfo] in GHC.Core.Op.Tidy.--Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot.---Note [magicDictId magic]-~~~~~~~~~~~~~~~~~~~~~~~~~-The identifier `magicDict` is just a place-holder, which is used to-implement a primitive that we cannot define in Haskell but we can write-in Core.  It is declared with a place-holder type:--    magicDict :: forall a. a--The intention is that the identifier will be used in a very specific way,-to create dictionaries for classes with a single method.  Consider a class-like this:--   class C a where-     f :: T a--We are going to use `magicDict`, in conjunction with a built-in Prelude-rule, to cast values of type `T a` into dictionaries for `C a`.  To do-this, we define a function like this in the library:--  data WrapC a b = WrapC (C a => Proxy a -> b)--  withT :: (C a => Proxy a -> b)-        ->  T a -> Proxy a -> b-  withT f x y = magicDict (WrapC f) x y--The purpose of `WrapC` is to avoid having `f` instantiated.-Also, it avoids impredicativity, because `magicDict`'s type-cannot be instantiated with a forall.  The field of `WrapC` contains-a `Proxy` parameter which is used to link the type of the constraint,-`C a`, with the type of the `Wrap` value being made.--Next, we add a built-in Prelude rule (see prelude/PrelRules.hs),-which will replace the RHS of this definition with the appropriate-definition in Core.  The rewrite rule works as follows:--  magicDict @t (wrap @a @b f) x y----->-  f (x `cast` co a) y--The `co` coercion is the newtype-coercion extracted from the type-class.-The type class is obtain by looking at the type of wrap.-----------------------------------------------------------------@realWorld#@ used to be a magic literal, \tr{void#}.  If things get-nasty as-is, change it back to a literal (@Literal@).--voidArgId is a Local Id used simply as an argument in functions-where we just want an arg to avoid having a thunk of unlifted type.-E.g.-        x = \ void :: Void# -> (# p, q #)--This comes up in strictness analysis--Note [evaldUnfoldings]-~~~~~~~~~~~~~~~~~~~~~~-The evaldUnfolding makes it look that some primitive value is-evaluated, which in turn makes Simplify.interestingArg return True,-which in turn makes INLINE things applied to said value likely to be-inlined.--}--realWorldPrimId :: Id   -- :: State# RealWorld-realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy-                     (noCafIdInfo `setUnfoldingInfo` evaldUnfolding    -- Note [evaldUnfoldings]-                                  `setOneShotInfo` stateHackOneShot-                                  `setNeverLevPoly` realWorldStatePrimTy)--voidPrimId :: Id     -- Global constant :: Void#-voidPrimId  = pcMiscPrelId voidPrimIdName voidPrimTy-                (noCafIdInfo `setUnfoldingInfo` evaldUnfolding     -- Note [evaldUnfoldings]-                             `setNeverLevPoly`  voidPrimTy)--voidArgId :: Id       -- Local lambda-bound :: Void#-voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy--coercionTokenId :: Id         -- :: () ~ ()-coercionTokenId -- See Note [Coercion tokens] in CoreToStg.hs-  = pcMiscPrelId coercionTokenName-                 (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy])-                 noCafIdInfo--pcMiscPrelId :: Name -> Type -> IdInfo -> Id-pcMiscPrelId name ty info-  = mkVanillaGlobalWithInfo name ty info-    -- We lie and say the thing is imported; otherwise, we get into-    -- a mess with dependency analysis; e.g., core2stg may heave in-    -- random calls to GHCbase.unpackPS__.  If GHCbase is the module-    -- being compiled, then it's just a matter of luck if the definition-    -- will be in "the right place" to be in scope.
− compiler/basicTypes/MkId.hs-boot 
@@ -1,15 +0,0 @@-module MkId where-import Name( Name )-import Var( Id )-import Class( Class )-import {-# SOURCE #-} DataCon( DataCon )-import {-# SOURCE #-} PrimOp( PrimOp )--data DataConBoxer--mkDataConWorkId :: Name -> DataCon -> Id-mkDictSelId     :: Name -> Class   -> Id--mkPrimOpId      :: PrimOp -> Id--magicDictId :: Id
− compiler/basicTypes/Module.hs 
@@ -1,1303 +0,0 @@-{--(c) The University of Glasgow, 2004-2006---Module-~~~~~~~~~~-Simply the name of a module, represented as a FastString.-These are Uniquable, hence we can build Maps with Modules as-the keys.--}--{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Module-    (-        -- * The ModuleName type-        ModuleName,-        pprModuleName,-        moduleNameFS,-        moduleNameString,-        moduleNameSlashes, moduleNameColons,-        moduleStableString,-        moduleFreeHoles,-        moduleIsDefinite,-        mkModuleName,-        mkModuleNameFS,-        stableModuleNameCmp,--        -- * The UnitId type-        ComponentId(..),-        UnitId(..),-        unitIdFS,-        unitIdKey,-        IndefUnitId(..),-        IndefModule(..),-        indefUnitIdToUnitId,-        indefModuleToModule,-        InstalledUnitId(..),-        toInstalledUnitId,-        ShHoleSubst,--        unitIdIsDefinite,-        unitIdString,-        unitIdFreeHoles,--        newUnitId,-        newIndefUnitId,-        newSimpleUnitId,-        hashUnitId,-        fsToUnitId,-        stringToUnitId,-        stableUnitIdCmp,--        -- * HOLE renaming-        renameHoleUnitId,-        renameHoleModule,-        renameHoleUnitId',-        renameHoleModule',--        -- * Generalization-        splitModuleInsts,-        splitUnitIdInsts,-        generalizeIndefUnitId,-        generalizeIndefModule,--        -- * Parsers-        parseModuleName,-        parseUnitId,-        parseComponentId,-        parseModuleId,-        parseModSubst,--        -- * Wired-in UnitIds-        -- $wired_in_packages-        primUnitId,-        integerUnitId,-        baseUnitId,-        rtsUnitId,-        thUnitId,-        mainUnitId,-        thisGhcUnitId,-        isHoleModule,-        interactiveUnitId, isInteractiveModule,-        wiredInUnitIds,--        -- * The Module type-        Module(Module),-        moduleUnitId, moduleName,-        pprModule,-        mkModule,-        mkHoleModule,-        stableModuleCmp,-        HasModule(..),-        ContainsModule(..),--        -- * Installed unit ids and modules-        InstalledModule(..),-        InstalledModuleEnv,-        installedModuleEq,-        installedUnitIdEq,-        installedUnitIdString,-        fsToInstalledUnitId,-        componentIdToInstalledUnitId,-        stringToInstalledUnitId,-        emptyInstalledModuleEnv,-        lookupInstalledModuleEnv,-        extendInstalledModuleEnv,-        filterInstalledModuleEnv,-        delInstalledModuleEnv,-        DefUnitId(..),--        -- * The ModuleLocation type-        ModLocation(..),-        addBootSuffix, addBootSuffix_maybe,-        addBootSuffixLocn, addBootSuffixLocnOut,--        -- * Module mappings-        ModuleEnv,-        elemModuleEnv, extendModuleEnv, extendModuleEnvList,-        extendModuleEnvList_C, plusModuleEnv_C,-        delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv,-        lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,-        moduleEnvKeys, moduleEnvElts, moduleEnvToList,-        unitModuleEnv, isEmptyModuleEnv,-        extendModuleEnvWith, filterModuleEnv,--        -- * ModuleName mappings-        ModuleNameEnv, DModuleNameEnv,--        -- * Sets of Modules-        ModuleSet,-        emptyModuleSet, mkModuleSet, moduleSetElts,-        extendModuleSet, extendModuleSetList, delModuleSet,-        elemModuleSet, intersectModuleSet, minusModuleSet, unionModuleSet,-        unitModuleSet-    ) where--import GhcPrelude--import Outputable-import Unique-import UniqFM-import UniqDFM-import UniqDSet-import FastString-import Binary-import Util-import Data.List (sortBy, sort)-import Data.Ord-import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..))-import Fingerprint--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS.Char8-import Encoding--import qualified Text.ParserCombinators.ReadP as Parse-import Text.ParserCombinators.ReadP (ReadP, (<++))-import Data.Char (isAlphaNum)-import Control.DeepSeq-import Data.Coerce-import Data.Data-import Data.Function-import Data.Map (Map)-import Data.Set (Set)-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified FiniteMap as Map-import System.FilePath--import {-# SOURCE #-} GHC.Driver.Session (DynFlags)-import {-# SOURCE #-} GHC.Driver.Packages (componentIdString, improveUnitId, UnitInfoMap, getUnitInfoMap, displayInstalledUnitId)---- Note [The identifier lexicon]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Unit IDs, installed package IDs, ABI hashes, package names,--- versions, there are a *lot* of different identifiers for closely--- related things.  What do they all mean? Here's what.  (See also--- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/packages/concepts )------ THE IMPORTANT ONES------ ComponentId: An opaque identifier provided by Cabal, which should--- uniquely identify such things as the package name, the package--- version, the name of the component, the hash of the source code--- tarball, the selected Cabal flags, GHC flags, direct dependencies of--- the component.  These are very similar to InstalledPackageId, but--- an 'InstalledPackageId' implies that it identifies a package, while--- a package may install multiple components with different--- 'ComponentId's.---      - Same as Distribution.Package.ComponentId------ UnitId/InstalledUnitId: A ComponentId + a mapping from hole names--- (ModuleName) to Modules.  This is how the compiler identifies instantiated--- components, and also is the main identifier by which GHC identifies things.---      - When Backpack is not being used, UnitId = ComponentId.---        this means a useful fiction for end-users is that there are---        only ever ComponentIds, and some ComponentIds happen to have---        more information (UnitIds).---      - Same as Language.Haskell.TH.Syntax:PkgName, see---          https://gitlab.haskell.org/ghc/ghc/issues/10279---      - The same as PackageKey in GHC 7.10 (we renamed it because---        they don't necessarily identify packages anymore.)---      - Same as -this-package-key/-package-name flags---      - An InstalledUnitId corresponds to an actual package which---        we have installed on disk.  It could be definite or indefinite,---        but if it's indefinite, it has nothing instantiated (we---        never install partially instantiated units.)------ Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how--- the compiler identifies modules (e.g. a Name is a Module + OccName)---      - Same as Language.Haskell.TH.Syntax:Module------ THE LESS IMPORTANT ONES------ PackageName: The "name" field in a Cabal file, something like "lens".---      - Same as Distribution.Package.PackageName---      - DIFFERENT FROM Language.Haskell.TH.Syntax:PkgName, see---          https://gitlab.haskell.org/ghc/ghc/issues/10279---      - DIFFERENT FROM -package-name flag---      - DIFFERENT FROM the 'name' field in an installed package---        information.  This field could more accurately be described---        as a munged package name: when it's for the main library---        it is the same as the package name, but if it's an internal---        library it's a munged combination of the package name and---        the component name.------ LEGACY ONES------ InstalledPackageId: This is what we used to call ComponentId.--- It's a still pretty useful concept for packages that have only--- one library; in that case the logical InstalledPackageId =--- ComponentId.  Also, the Cabal nix-local-build continues to--- compute an InstalledPackageId which is then forcibly used--- for all components in a package.  This means that if a dependency--- from one component in a package changes, the InstalledPackageId--- changes: you don't get as fine-grained dependency tracking,--- but it means your builds are hermetic.  Eventually, Cabal will--- deal completely in components and we can get rid of this.------ PackageKey: This is what we used to call UnitId.  We ditched--- "Package" from the name when we realized that you might want to--- assign different "PackageKeys" to components from the same package.--- (For a brief, non-released period of time, we also called these--- UnitKeys).--{--************************************************************************-*                                                                      *-\subsection{Module locations}-*                                                                      *-************************************************************************--}---- | Module Location------ Where a module lives on the file system: the actual locations--- of the .hs, .hi and .o files, if we have them-data ModLocation-   = ModLocation {-        ml_hs_file   :: Maybe FilePath,-                -- The source file, if we have one.  Package modules-                -- probably don't have source files.--        ml_hi_file   :: FilePath,-                -- Where the .hi file is, whether or not it exists-                -- yet.  Always of form foo.hi, even if there is an-                -- hi-boot file (we add the -boot suffix later)--        ml_obj_file  :: FilePath,-                -- Where the .o file is, whether or not it exists yet.-                -- (might not exist either because the module hasn't-                -- been compiled yet, or because it is part of a-                -- package with a .a file)-        ml_hie_file  :: FilePath-  } deriving Show--instance Outputable ModLocation where-   ppr = text . show--{--For a module in another package, the hs_file and obj_file-components of ModLocation are undefined.--The locations specified by a ModLocation may or may not-correspond to actual files yet: for example, even if the object-file doesn't exist, the ModLocation still contains the path to-where the object file will reside if/when it is created.--}--addBootSuffix :: FilePath -> FilePath--- ^ Add the @-boot@ suffix to .hs, .hi and .o files-addBootSuffix path = path ++ "-boot"--addBootSuffix_maybe :: Bool -> FilePath -> FilePath--- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@-addBootSuffix_maybe is_boot path- | is_boot   = addBootSuffix path- | otherwise = path--addBootSuffixLocn :: ModLocation -> ModLocation--- ^ Add the @-boot@ suffix to all file paths associated with the module-addBootSuffixLocn locn-  = locn { ml_hs_file  = fmap addBootSuffix (ml_hs_file locn)-         , ml_hi_file  = addBootSuffix (ml_hi_file locn)-         , ml_obj_file = addBootSuffix (ml_obj_file locn)-         , ml_hie_file = addBootSuffix (ml_hie_file locn) }--addBootSuffixLocnOut :: ModLocation -> ModLocation--- ^ Add the @-boot@ suffix to all output file paths associated with the--- module, not including the input file itself-addBootSuffixLocnOut locn-  = locn { ml_hi_file  = addBootSuffix (ml_hi_file locn)-         , ml_obj_file = addBootSuffix (ml_obj_file locn)-         , ml_hie_file = addBootSuffix (ml_hie_file locn) }--{--************************************************************************-*                                                                      *-\subsection{The name of a module}-*                                                                      *-************************************************************************--}---- | A ModuleName is essentially a simple string, e.g. @Data.List@.-newtype ModuleName = ModuleName FastString--instance Uniquable ModuleName where-  getUnique (ModuleName nm) = getUnique nm--instance Eq ModuleName where-  nm1 == nm2 = getUnique nm1 == getUnique nm2--instance Ord ModuleName where-  nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2--instance Outputable ModuleName where-  ppr = pprModuleName--instance Binary ModuleName where-  put_ bh (ModuleName fs) = put_ bh fs-  get bh = do fs <- get bh; return (ModuleName fs)--instance BinaryStringRep ModuleName where-  fromStringRep = mkModuleNameFS . mkFastStringByteString-  toStringRep   = bytesFS . moduleNameFS--instance Data ModuleName where-  -- don't traverse?-  toConstr _   = abstractConstr "ModuleName"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "ModuleName"--instance NFData ModuleName where-  rnf x = x `seq` ()--stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering--- ^ Compares module names lexically, rather than by their 'Unique's-stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2--pprModuleName :: ModuleName -> SDoc-pprModuleName (ModuleName nm) =-    getPprStyle $ \ sty ->-    if codeStyle sty-        then ztext (zEncodeFS nm)-        else ftext nm--moduleNameFS :: ModuleName -> FastString-moduleNameFS (ModuleName mod) = mod--moduleNameString :: ModuleName -> String-moduleNameString (ModuleName mod) = unpackFS mod---- | Get a string representation of a 'Module' that's unique and stable--- across recompilations.--- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal"-moduleStableString :: Module -> String-moduleStableString Module{..} =-  "$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName--mkModuleName :: String -> ModuleName-mkModuleName s = ModuleName (mkFastString s)--mkModuleNameFS :: FastString -> ModuleName-mkModuleNameFS s = ModuleName s---- |Returns the string version of the module name, with dots replaced by slashes.----moduleNameSlashes :: ModuleName -> String-moduleNameSlashes = dots_to_slashes . moduleNameString-  where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)---- |Returns the string version of the module name, with dots replaced by colons.----moduleNameColons :: ModuleName -> String-moduleNameColons = dots_to_colons . moduleNameString-  where dots_to_colons = map (\c -> if c == '.' then ':' else c)--{--************************************************************************-*                                                                      *-\subsection{A fully qualified module}-*                                                                      *-************************************************************************--}---- | A Module is a pair of a 'UnitId' and a 'ModuleName'.------ Module variables (i.e. @<H>@) which can be instantiated to a--- specific module at some later point in time are represented--- with 'moduleUnitId' set to 'holeUnitId' (this allows us to--- avoid having to make 'moduleUnitId' a partial operation.)----data Module = Module {-   moduleUnitId :: !UnitId,  -- pkg-1.0-   moduleName :: !ModuleName  -- A.B.C-  }-  deriving (Eq, Ord)---- | Calculate the free holes of a 'Module'.  If this set is non-empty,--- this module was defined in an indefinite library that had required--- signatures.------ If a module has free holes, that means that substitutions can operate on it;--- if it has no free holes, substituting over a module has no effect.-moduleFreeHoles :: Module -> UniqDSet ModuleName-moduleFreeHoles m-    | isHoleModule m = unitUniqDSet (moduleName m)-    | otherwise = unitIdFreeHoles (moduleUnitId m)---- | A 'Module' is definite if it has no free holes.-moduleIsDefinite :: Module -> Bool-moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles---- | Create a module variable at some 'ModuleName'.--- See Note [Representation of module/name variables]-mkHoleModule :: ModuleName -> Module-mkHoleModule = mkModule holeUnitId--instance Uniquable Module where-  getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n)--instance Outputable Module where-  ppr = pprModule--instance Binary Module where-  put_ bh (Module p n) = put_ bh p >> put_ bh n-  get bh = do p <- get bh; n <- get bh; return (Module p n)--instance Data Module where-  -- don't traverse?-  toConstr _   = abstractConstr "Module"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "Module"--instance NFData Module where-  rnf x = x `seq` ()---- | This gives a stable ordering, as opposed to the Ord instance which--- gives an ordering based on the 'Unique's of the components, which may--- not be stable from run to run of the compiler.-stableModuleCmp :: Module -> Module -> Ordering-stableModuleCmp (Module p1 n1) (Module p2 n2)-   = (p1 `stableUnitIdCmp`  p2) `thenCmp`-     (n1 `stableModuleNameCmp` n2)--mkModule :: UnitId -> ModuleName -> Module-mkModule = Module--pprModule :: Module -> SDoc-pprModule mod@(Module p n)  = getPprStyle doc- where-  doc sty-    | codeStyle sty =-        (if p == mainUnitId-                then empty -- never qualify the main package in code-                else ztext (zEncodeFS (unitIdFS p)) <> char '_')-            <> pprModuleName n-    | qualModule sty mod =-        if isHoleModule mod-            then angleBrackets (pprModuleName n)-            else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n-    | otherwise =-        pprModuleName n--class ContainsModule t where-    extractModule :: t -> Module--class HasModule m where-    getModule :: m Module--instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where-  fromDbModule (DbModule uid mod_name)  = mkModule uid mod_name-  fromDbModule (DbModuleVar mod_name)   = mkHoleModule mod_name-  fromDbUnitId (DbUnitId cid insts)     = newUnitId cid insts-  fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid)-  -- GHC never writes to the database, so it's not needed-  toDbModule = error "toDbModule: not implemented"-  toDbUnitId = error "toDbUnitId: not implemented"--{--************************************************************************-*                                                                      *-\subsection{ComponentId}-*                                                                      *-************************************************************************--}---- | A 'ComponentId' consists of the package name, package version, component--- ID, the transitive dependencies of the component, and other information to--- uniquely identify the source code and build configuration of a component.------ This used to be known as an 'InstalledPackageId', but a package can contain--- multiple components and a 'ComponentId' uniquely identifies a component--- within a package.  When a package only has one component, the 'ComponentId'--- coincides with the 'InstalledPackageId'-newtype ComponentId        = ComponentId        FastString deriving (Eq, Ord)--instance BinaryStringRep ComponentId where-  fromStringRep = ComponentId . mkFastStringByteString-  toStringRep (ComponentId s) = bytesFS s--instance Uniquable ComponentId where-  getUnique (ComponentId n) = getUnique n--instance Outputable ComponentId where-  ppr cid@(ComponentId fs) =-    getPprStyle $ \sty ->-    sdocWithDynFlags $ \dflags ->-      case componentIdString dflags cid of-        Just str | not (debugStyle sty) -> text str-        _ -> ftext fs--{--************************************************************************-*                                                                      *-\subsection{UnitId}-*                                                                      *-************************************************************************--}---- | A unit identifier identifies a (possibly partially) instantiated--- library.  It is primarily used as part of 'Module', which in turn--- is used in 'Name', which is used to give names to entities when--- typechecking.------ There are two possible forms for a 'UnitId'.  It can be a--- 'DefiniteUnitId', in which case we just have a string that uniquely--- identifies some fully compiled, installed library we have on disk.--- However, when we are typechecking a library with missing holes,--- we may need to instantiate a library on the fly (in which case--- we don't have any on-disk representation.)  In that case, you--- have an 'IndefiniteUnitId', which explicitly records the--- instantiation, so that we can substitute over it.-data UnitId-    = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId-    |   DefiniteUnitId {-# UNPACK #-} !DefUnitId--unitIdFS :: UnitId -> FastString-unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x-unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x--unitIdKey :: UnitId -> Unique-unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x-unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x---- | A unit identifier which identifies an indefinite--- library (with holes) that has been *on-the-fly* instantiated--- with a substitution 'indefUnitIdInsts'.  In fact, an indefinite--- unit identifier could have no holes, but we haven't gotten--- around to compiling the actual library yet.------ An indefinite unit identifier pretty-prints to something like--- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the--- brackets enclose the module substitution).-data IndefUnitId-    = IndefUnitId {-        -- | A private, uniquely identifying representation of-        -- a UnitId.  This string is completely private to GHC-        -- and is just used to get a unique; in particular, we don't use it for-        -- symbols (indefinite libraries are not compiled).-        indefUnitIdFS :: FastString,-        -- | Cached unique of 'unitIdFS'.-        indefUnitIdKey :: Unique,-        -- | The component identity of the indefinite library that-        -- is being instantiated.-        indefUnitIdComponentId :: !ComponentId,-        -- | The sorted (by 'ModuleName') instantiations of this library.-        indefUnitIdInsts :: ![(ModuleName, Module)],-        -- | A cache of the free module variables of 'unitIdInsts'.-        -- This lets us efficiently tell if a 'UnitId' has been-        -- fully instantiated (free module variables are empty)-        -- and whether or not a substitution can have any effect.-        indefUnitIdFreeHoles :: UniqDSet ModuleName-    }--instance Eq IndefUnitId where-  u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2--instance Ord IndefUnitId where-  u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2--instance Binary IndefUnitId where-  put_ bh indef = do-    put_ bh (indefUnitIdComponentId indef)-    put_ bh (indefUnitIdInsts indef)-  get bh = do-    cid   <- get bh-    insts <- get bh-    let fs = hashUnitId cid insts-    return IndefUnitId {-            indefUnitIdComponentId = cid,-            indefUnitIdInsts = insts,-            indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),-            indefUnitIdFS = fs,-            indefUnitIdKey = getUnique fs-           }---- | Create a new 'IndefUnitId' given an explicit module substitution.-newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId-newIndefUnitId cid insts =-    IndefUnitId {-        indefUnitIdComponentId = cid,-        indefUnitIdInsts = sorted_insts,-        indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),-        indefUnitIdFS = fs,-        indefUnitIdKey = getUnique fs-    }-  where-     fs = hashUnitId cid sorted_insts-     sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts---- | Injects an 'IndefUnitId' (indefinite library which--- was on-the-fly instantiated) to a 'UnitId' (either--- an indefinite or definite library).-indefUnitIdToUnitId :: DynFlags -> IndefUnitId -> UnitId-indefUnitIdToUnitId dflags iuid =-    -- NB: suppose that we want to compare the indefinite-    -- unit id p[H=impl:H] against p+abcd (where p+abcd-    -- happens to be the existing, installed version of-    -- p[H=impl:H].  If we *only* wrap in p[H=impl:H]-    -- IndefiniteUnitId, they won't compare equal; only-    -- after improvement will the equality hold.-    improveUnitId (getUnitInfoMap dflags) $-        IndefiniteUnitId iuid--data IndefModule = IndefModule {-        indefModuleUnitId :: IndefUnitId,-        indefModuleName   :: ModuleName-    } deriving (Eq, Ord)--instance Outputable IndefModule where-  ppr (IndefModule uid m) =-    ppr uid <> char ':' <> ppr m---- | Injects an 'IndefModule' to 'Module' (see also--- 'indefUnitIdToUnitId'.-indefModuleToModule :: DynFlags -> IndefModule -> Module-indefModuleToModule dflags (IndefModule iuid mod_name) =-    mkModule (indefUnitIdToUnitId dflags iuid) mod_name---- | An installed unit identifier identifies a library which has--- been installed to the package database.  These strings are--- provided to us via the @-this-unit-id@ flag.  The library--- in question may be definite or indefinite; if it is indefinite,--- none of the holes have been filled (we never install partially--- instantiated libraries.)  Put another way, an installed unit id--- is either fully instantiated, or not instantiated at all.------ Installed unit identifiers look something like @p+af23SAj2dZ219@,--- or maybe just @p@ if they don't use Backpack.-newtype InstalledUnitId =-    InstalledUnitId {-      -- | The full hashed unit identifier, including the component id-      -- and the hash.-      installedUnitIdFS :: FastString-    }--instance Binary InstalledUnitId where-  put_ bh (InstalledUnitId fs) = put_ bh fs-  get bh = do fs <- get bh; return (InstalledUnitId fs)--instance BinaryStringRep InstalledUnitId where-  fromStringRep bs = InstalledUnitId (mkFastStringByteString bs)-  -- GHC doesn't write to database-  toStringRep   = error "BinaryStringRep InstalledUnitId: not implemented"--instance Eq InstalledUnitId where-    uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2--instance Ord InstalledUnitId where-    u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2--instance Uniquable InstalledUnitId where-    getUnique = installedUnitIdKey--instance Outputable InstalledUnitId where-    ppr uid@(InstalledUnitId fs) =-        getPprStyle $ \sty ->-        sdocWithDynFlags $ \dflags ->-          case displayInstalledUnitId dflags uid of-            Just str | not (debugStyle sty) -> text str-            _ -> ftext fs--installedUnitIdKey :: InstalledUnitId -> Unique-installedUnitIdKey = getUnique . installedUnitIdFS---- | Lossy conversion to the on-disk 'InstalledUnitId' for a component.-toInstalledUnitId :: UnitId -> InstalledUnitId-toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid-toInstalledUnitId (IndefiniteUnitId indef) =-    componentIdToInstalledUnitId (indefUnitIdComponentId indef)--installedUnitIdString :: InstalledUnitId -> String-installedUnitIdString = unpackFS . installedUnitIdFS--instance Outputable IndefUnitId where-    ppr uid =-      -- getPprStyle $ \sty ->-      ppr cid <>-        (if not (null insts) -- pprIf-          then-            brackets (hcat-                (punctuate comma $-                    [ ppr modname <> text "=" <> ppr m-                    | (modname, m) <- insts]))-          else empty)-     where-      cid   = indefUnitIdComponentId uid-      insts = indefUnitIdInsts uid---- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'.-data InstalledModule = InstalledModule {-   installedModuleUnitId :: !InstalledUnitId,-   installedModuleName :: !ModuleName-  }-  deriving (Eq, Ord)--instance Outputable InstalledModule where-  ppr (InstalledModule p n) =-    ppr p <> char ':' <> pprModuleName n--fsToInstalledUnitId :: FastString -> InstalledUnitId-fsToInstalledUnitId fs = InstalledUnitId fs--componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId-componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs--stringToInstalledUnitId :: String -> InstalledUnitId-stringToInstalledUnitId = fsToInstalledUnitId . mkFastString---- | Test if a 'Module' corresponds to a given 'InstalledModule',--- modulo instantiation.-installedModuleEq :: InstalledModule -> Module -> Bool-installedModuleEq imod mod =-    fst (splitModuleInsts mod) == imod---- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId',--- modulo instantiation.-installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool-installedUnitIdEq iuid uid =-    fst (splitUnitIdInsts uid) == iuid---- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that--- it only refers to a definite library; i.e., one we have generated--- code for.-newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId }-    deriving (Eq, Ord)--instance Outputable DefUnitId where-    ppr (DefUnitId uid) = ppr uid--instance Binary DefUnitId where-    put_ bh (DefUnitId uid) = put_ bh uid-    get bh = do uid <- get bh; return (DefUnitId uid)---- | A map keyed off of 'InstalledModule'-newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt)--emptyInstalledModuleEnv :: InstalledModuleEnv a-emptyInstalledModuleEnv = InstalledModuleEnv Map.empty--lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a-lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e--extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a-extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e)--filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a-filterInstalledModuleEnv f (InstalledModuleEnv e) =-  InstalledModuleEnv (Map.filterWithKey f e)--delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a-delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e)---- Note [UnitId to InstalledUnitId improvement]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Just because a UnitId is definite (has no holes) doesn't--- mean it's necessarily a InstalledUnitId; it could just be--- that over the course of renaming UnitIds on the fly--- while typechecking an indefinite library, we--- ended up with a fully instantiated unit id with no hash,--- since we haven't built it yet.  This is fine.------ However, if there is a hashed unit id for this instantiation--- in the package database, we *better use it*, because--- that hashed unit id may be lurking in another interface,--- and chaos will ensue if we attempt to compare the two--- (the unitIdFS for a UnitId never corresponds to a Cabal-provided--- hash of a compiled instantiated library).------ There is one last niggle: improvement based on the package database means--- that we might end up developing on a package that is not transitively--- depended upon by the packages the user specified directly via command line--- flags.  This could lead to strange and difficult to understand bugs if those--- instantiations are out of date.  The solution is to only improve a--- unit id if the new unit id is part of the 'preloadClosure'; i.e., the--- closure of all the packages which were explicitly specified.---- | Retrieve the set of free holes of a 'UnitId'.-unitIdFreeHoles :: UnitId -> UniqDSet ModuleName-unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x--- Hashed unit ids are always fully instantiated-unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet--instance Show UnitId where-    show = unitIdString---- | A 'UnitId' is definite if it has no free holes.-unitIdIsDefinite :: UnitId -> Bool-unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles---- | Generate a uniquely identifying 'FastString' for a unit--- identifier.  This is a one-way function.  You can rely on one special--- property: if a unit identifier is in most general form, its 'FastString'--- coincides with its 'ComponentId'.  This hash is completely internal--- to GHC and is not used for symbol names or file paths.-hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString-hashUnitId cid sorted_holes =-    mkFastStringByteString-  . fingerprintUnitId (toStringRep cid)-  $ rawHashUnitId sorted_holes---- | Generate a hash for a sorted module substitution.-rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint-rawHashUnitId sorted_holes =-    fingerprintByteString-  . BS.concat $ do-        (m, b) <- sorted_holes-        [ toStringRep m,                BS.Char8.singleton ' ',-          bytesFS (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':',-          toStringRep (moduleName b),   BS.Char8.singleton '\n']--fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString-fingerprintUnitId prefix (Fingerprint a b)-    = BS.concat-    $ [ prefix-      , BS.Char8.singleton '-'-      , BS.Char8.pack (toBase62Padded a)-      , BS.Char8.pack (toBase62Padded b) ]---- | Create a new, un-hashed unit identifier.-newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId-newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug...-newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts--pprUnitId :: UnitId -> SDoc-pprUnitId (DefiniteUnitId uid) = ppr uid-pprUnitId (IndefiniteUnitId uid) = ppr uid--instance Eq UnitId where-  uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2--instance Uniquable UnitId where-  getUnique = unitIdKey--instance Ord UnitId where-  nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2--instance Data UnitId where-  -- don't traverse?-  toConstr _   = abstractConstr "UnitId"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "UnitId"--instance NFData UnitId where-  rnf x = x `seq` ()--stableUnitIdCmp :: UnitId -> UnitId -> Ordering--- ^ Compares package ids lexically, rather than by their 'Unique's-stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2--instance Outputable UnitId where-   ppr pk = pprUnitId pk---- Performance: would prefer to have a NameCache like thing-instance Binary UnitId where-  put_ bh (DefiniteUnitId def_uid) = do-    putByte bh 0-    put_ bh def_uid-  put_ bh (IndefiniteUnitId indef_uid) = do-    putByte bh 1-    put_ bh indef_uid-  get bh = do b <- getByte bh-              case b of-                0 -> fmap DefiniteUnitId   (get bh)-                _ -> fmap IndefiniteUnitId (get bh)--instance Binary ComponentId where-  put_ bh (ComponentId fs) = put_ bh fs-  get bh = do { fs <- get bh; return (ComponentId fs) }---- | Create a new simple unit identifier (no holes) from a 'ComponentId'.-newSimpleUnitId :: ComponentId -> UnitId-newSimpleUnitId (ComponentId fs) = fsToUnitId fs---- | Create a new simple unit identifier from a 'FastString'.  Internally,--- this is primarily used to specify wired-in unit identifiers.-fsToUnitId :: FastString -> UnitId-fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId--stringToUnitId :: String -> UnitId-stringToUnitId = fsToUnitId . mkFastString--unitIdString :: UnitId -> String-unitIdString = unpackFS . unitIdFS--{--************************************************************************-*                                                                      *-                        Hole substitutions-*                                                                      *-************************************************************************--}---- | Substitution on module variables, mapping module names to module--- identifiers.-type ShHoleSubst = ModuleNameEnv Module---- | Substitutes holes in a 'Module'.  NOT suitable for being called--- directly on a 'nameModule', see Note [Representation of module/name variable].--- @p[A=<A>]:B@ maps to @p[A=q():A]:B@ with @A=q():A@;--- similarly, @<A>@ maps to @q():A@.-renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module-renameHoleModule dflags = renameHoleModule' (getUnitInfoMap dflags)---- | Substitutes holes in a 'UnitId', suitable for renaming when--- an include occurs; see Note [Representation of module/name variable].------ @p[A=<A>]@ maps to @p[A=<B>]@ with @A=<B>@.-renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId-renameHoleUnitId dflags = renameHoleUnitId' (getUnitInfoMap dflags)---- | Like 'renameHoleModule', but requires only 'UnitInfoMap'--- so it can be used by "Packages".-renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module-renameHoleModule' pkg_map env m-  | not (isHoleModule m) =-        let uid = renameHoleUnitId' pkg_map env (moduleUnitId m)-        in mkModule uid (moduleName m)-  | Just m' <- lookupUFM env (moduleName m) = m'-  -- NB m = <Blah>, that's what's in scope.-  | otherwise = m---- | Like 'renameHoleUnitId, but requires only 'UnitInfoMap'--- so it can be used by "Packages".-renameHoleUnitId' :: UnitInfoMap -> ShHoleSubst -> UnitId -> UnitId-renameHoleUnitId' pkg_map env uid =-    case uid of-      (IndefiniteUnitId-        IndefUnitId{ indefUnitIdComponentId = cid-                   , indefUnitIdInsts       = insts-                   , indefUnitIdFreeHoles   = fh })-          -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env)-                then uid-                -- Functorially apply the substitution to the instantiation,-                -- then check the 'UnitInfoMap' to see if there is-                -- a compiled version of this 'UnitId' we can improve to.-                -- See Note [UnitId to InstalledUnitId] improvement-                else improveUnitId pkg_map $-                        newUnitId cid-                            (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts)-      _ -> uid---- | Given a possibly on-the-fly instantiated module, split it into--- a 'Module' that we definitely can find on-disk, as well as an--- instantiation if we need to instantiate it on the fly.  If the--- instantiation is @Nothing@ no on-the-fly renaming is needed.-splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule)-splitModuleInsts m =-    let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m)-    in (InstalledModule uid (moduleName m),-        fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid)---- | See 'splitModuleInsts'.-splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId)-splitUnitIdInsts (IndefiniteUnitId iuid) =-    (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid)-splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing)--generalizeIndefUnitId :: IndefUnitId -> IndefUnitId-generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid-                                 , indefUnitIdInsts = insts } =-    newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts)--generalizeIndefModule :: IndefModule -> IndefModule-generalizeIndefModule (IndefModule uid n) = IndefModule (generalizeIndefUnitId uid) n--parseModuleName :: ReadP ModuleName-parseModuleName = fmap mkModuleName-                $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.")--parseUnitId :: ReadP UnitId-parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId-  where-    parseFullUnitId = do-        cid <- parseComponentId-        insts <- parseModSubst-        return (newUnitId cid insts)-    parseDefiniteUnitId = do-        s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+")-        return (stringToUnitId s)-    parseSimpleUnitId = do-        cid <- parseComponentId-        return (newSimpleUnitId cid)--parseComponentId :: ReadP ComponentId-parseComponentId = (ComponentId . mkFastString)  `fmap` Parse.munch1 abi_char-   where abi_char c = isAlphaNum c || c `elem` "-_."--parseModuleId :: ReadP Module-parseModuleId = parseModuleVar <++ parseModule-    where-      parseModuleVar = do-        _ <- Parse.char '<'-        modname <- parseModuleName-        _ <- Parse.char '>'-        return (mkHoleModule modname)-      parseModule = do-        uid <- parseUnitId-        _ <- Parse.char ':'-        modname <- parseModuleName-        return (mkModule uid modname)--parseModSubst :: ReadP [(ModuleName, Module)]-parseModSubst = Parse.between (Parse.char '[') (Parse.char ']')-      . flip Parse.sepBy (Parse.char ',')-      $ do k <- parseModuleName-           _ <- Parse.char '='-           v <- parseModuleId-           return (k, v)---{--Note [Wired-in packages]-~~~~~~~~~~~~~~~~~~~~~~~~--Certain packages are known to the compiler, in that we know about certain-entities that reside in these packages, and the compiler needs to-declare static Modules and Names that refer to these packages.  Hence-the wired-in packages can't include version numbers in their package UnitId,-since we don't want to bake the version numbers of these packages into GHC.--So here's the plan.  Wired-in packages are still versioned as-normal in the packages database, and you can still have multiple-versions of them installed. To the user, everything looks normal.--However, for each invocation of GHC, only a single instance of each wired-in-package will be recognised (the desired one is selected via-@-package@\/@-hide-package@), and GHC will internally pretend that it has the-*unversioned* 'UnitId', including in .hi files and object file symbols.--Unselected versions of wired-in packages will be ignored, as will any other-package that depends directly or indirectly on it (much as if you-had used @-ignore-package@).--The affected packages are compiled with, e.g., @-this-unit-id base@, so that-the symbols in the object files have the unversioned unit id in their name.--Make sure you change 'Packages.findWiredInPackages' if you add an entry here.--For `integer-gmp`/`integer-simple` we also change the base name to-`integer-wired-in`, but this is fundamentally no different.-See Note [The integer library] in PrelNames.--}--integerUnitId, primUnitId,-  baseUnitId, rtsUnitId,-  thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId  :: UnitId-primUnitId        = fsToUnitId (fsLit "ghc-prim")-integerUnitId     = fsToUnitId (fsLit "integer-wired-in")-   -- See Note [The integer library] in PrelNames-baseUnitId        = fsToUnitId (fsLit "base")-rtsUnitId         = fsToUnitId (fsLit "rts")-thUnitId          = fsToUnitId (fsLit "template-haskell")-thisGhcUnitId     = fsToUnitId (fsLit "ghc")-interactiveUnitId = fsToUnitId (fsLit "interactive")---- | This is the package Id for the current program.  It is the default--- package Id if you don't specify a package name.  We don't add this prefix--- to symbol names, since there can be only one main package per program.-mainUnitId      = fsToUnitId (fsLit "main")---- | This is a fake package id used to provide identities to any un-implemented--- signatures.  The set of hole identities is global over an entire compilation.--- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead.--- See Note [Representation of module/name variables]-holeUnitId :: UnitId-holeUnitId      = fsToUnitId (fsLit "hole")--isInteractiveModule :: Module -> Bool-isInteractiveModule mod = moduleUnitId mod == interactiveUnitId---- Note [Representation of module/name variables]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- In our ICFP'16, we use <A> to represent module holes, and {A.T} to represent--- name holes.  This could have been represented by adding some new cases--- to the core data types, but this would have made the existing 'nameModule'--- and 'moduleUnitId' partial, which would have required a lot of modifications--- to existing code.------ Instead, we adopted the following encoding scheme:------      <A>   ===> hole:A---      {A.T} ===> hole:A.T------ This encoding is quite convenient, but it is also a bit dangerous too,--- because if you have a 'hole:A' you need to know if it's actually a--- 'Module' or just a module stored in a 'Name'; these two cases must be--- treated differently when doing substitutions.  'renameHoleModule'--- and 'renameHoleUnitId' assume they are NOT operating on a--- 'Name'; 'NameShape' handles name substitutions exclusively.--isHoleModule :: Module -> Bool-isHoleModule mod = moduleUnitId mod == holeUnitId--wiredInUnitIds :: [UnitId]-wiredInUnitIds = [ primUnitId,-                       integerUnitId,-                       baseUnitId,-                       rtsUnitId,-                       thUnitId,-                       thisGhcUnitId ]--{--************************************************************************-*                                                                      *-\subsection{@ModuleEnv@s}-*                                                                      *-************************************************************************--}---- | A map keyed off of 'Module's-newtype ModuleEnv elt = ModuleEnv (Map NDModule elt)--{--Note [ModuleEnv performance and determinism]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-To prevent accidental reintroduction of nondeterminism the Ord instance-for Module was changed to not depend on Unique ordering and to use the-lexicographic order. This is potentially expensive, but when measured-there was no difference in performance.--To be on the safe side and not pessimize ModuleEnv uses nondeterministic-ordering on Module and normalizes by doing the lexicographic sort when-turning the env to a list.-See Note [Unique Determinism] for more information about the source of-nondeterminismand and Note [Deterministic UniqFM] for explanation of why-it matters for maps.--}--newtype NDModule = NDModule { unNDModule :: Module }-  deriving Eq-  -- A wrapper for Module with faster nondeterministic Ord.-  -- Don't export, See [ModuleEnv performance and determinism]--instance Ord NDModule where-  compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) =-    (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp`-    (getUnique n1 `nonDetCmpUnique` getUnique n2)--filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a-filterModuleEnv f (ModuleEnv e) =-  ModuleEnv (Map.filterWithKey (f . unNDModule) e)--elemModuleEnv :: Module -> ModuleEnv a -> Bool-elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e--extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a-extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e)--extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a-                    -> ModuleEnv a-extendModuleEnvWith f (ModuleEnv e) m x =-  ModuleEnv (Map.insertWith f (NDModule m) x e)--extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a-extendModuleEnvList (ModuleEnv e) xs =-  ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e)--extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)]-                      -> ModuleEnv a-extendModuleEnvList_C f (ModuleEnv e) xs =-  ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e)--plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a-plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) =-  ModuleEnv (Map.unionWith f e1 e2)--delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a-delModuleEnvList (ModuleEnv e) ms =-  ModuleEnv (Map.deleteList (map NDModule ms) e)--delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a-delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e)--plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a-plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2)--lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a-lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e--lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a-lookupWithDefaultModuleEnv (ModuleEnv e) x m =-  Map.findWithDefault x (NDModule m) e--mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b-mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e)--mkModuleEnv :: [(Module, a)] -> ModuleEnv a-mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs])--emptyModuleEnv :: ModuleEnv a-emptyModuleEnv = ModuleEnv Map.empty--moduleEnvKeys :: ModuleEnv a -> [Module]-moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e-  -- See Note [ModuleEnv performance and determinism]--moduleEnvElts :: ModuleEnv a -> [a]-moduleEnvElts e = map snd $ moduleEnvToList e-  -- See Note [ModuleEnv performance and determinism]--moduleEnvToList :: ModuleEnv a -> [(Module, a)]-moduleEnvToList (ModuleEnv e) =-  sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e]-  -- See Note [ModuleEnv performance and determinism]--unitModuleEnv :: Module -> a -> ModuleEnv a-unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x)--isEmptyModuleEnv :: ModuleEnv a -> Bool-isEmptyModuleEnv (ModuleEnv e) = Map.null e---- | A set of 'Module's-type ModuleSet = Set NDModule--mkModuleSet :: [Module] -> ModuleSet-mkModuleSet = Set.fromList . coerce--extendModuleSet :: ModuleSet -> Module -> ModuleSet-extendModuleSet s m = Set.insert (NDModule m) s--extendModuleSetList :: ModuleSet -> [Module] -> ModuleSet-extendModuleSetList s ms = foldl' (coerce . flip Set.insert) s ms--emptyModuleSet :: ModuleSet-emptyModuleSet = Set.empty--moduleSetElts :: ModuleSet -> [Module]-moduleSetElts = sort . coerce . Set.toList--elemModuleSet :: Module -> ModuleSet -> Bool-elemModuleSet = Set.member . coerce--intersectModuleSet :: ModuleSet -> ModuleSet -> ModuleSet-intersectModuleSet = coerce Set.intersection--minusModuleSet :: ModuleSet -> ModuleSet -> ModuleSet-minusModuleSet = coerce Set.difference--delModuleSet :: ModuleSet -> Module -> ModuleSet-delModuleSet = coerce (flip Set.delete)--unionModuleSet :: ModuleSet -> ModuleSet -> ModuleSet-unionModuleSet = coerce Set.union--unitModuleSet :: Module -> ModuleSet-unitModuleSet = coerce Set.singleton--{--A ModuleName has a Unique, so we can build mappings of these using-UniqFM.--}---- | A map keyed off of 'ModuleName's (actually, their 'Unique's)-type ModuleNameEnv elt = UniqFM elt----- | A map keyed off of 'ModuleName's (actually, their 'Unique's)--- Has deterministic folds and can be deterministically converted to a list-type DModuleNameEnv elt = UniqDFM elt
− compiler/basicTypes/Module.hs-boot 
@@ -1,14 +0,0 @@-module Module where--import GhcPrelude-import FastString--data Module-data ModuleName-data UnitId-data InstalledUnitId-newtype ComponentId = ComponentId FastString--moduleName :: Module -> ModuleName-moduleUnitId :: Module -> UnitId-unitIdString :: UnitId -> String
− compiler/basicTypes/Name.hs 
@@ -1,693 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[Name]{@Name@: to transmit name info from renamer to typechecker}--}--{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternSynonyms #-}---- |--- #name_types#--- GHC uses several kinds of name internally:------ * 'OccName.OccName': see "OccName#name_types"------ * 'RdrName.RdrName': see "RdrName#name_types"------ *  'Name.Name' is the type of names that have had their scoping and binding resolved. They---   have an 'OccName.OccName' but also a 'Unique.Unique' that disambiguates Names that have---   the same 'OccName.OccName' and indeed is used for all 'Name.Name' comparison. Names---   also contain information about where they originated from, see "Name#name_sorts"------ * 'Id.Id': see "Id#name_types"------ * 'Var.Var': see "Var#name_types"------ #name_sorts#--- Names are one of:------  * External, if they name things declared in other modules. Some external---    Names are wired in, i.e. they name primitives defined in the compiler itself------  * Internal, if they name things in the module being compiled. Some internal---    Names are system names, if they are names manufactured by the compiler--module Name (-        -- * The main types-        Name,                                   -- Abstract-        BuiltInSyntax(..),--        -- ** Creating 'Name's-        mkSystemName, mkSystemNameAt,-        mkInternalName, mkClonedInternalName, mkDerivedInternalName,-        mkSystemVarName, mkSysTvName,-        mkFCallName,-        mkExternalName, mkWiredInName,--        -- ** Manipulating and deconstructing 'Name's-        nameUnique, setNameUnique,-        nameOccName, nameNameSpace, nameModule, nameModule_maybe,-        setNameLoc,-        tidyNameOcc,-        localiseName,--        nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt,--        -- ** Predicates on 'Name's-        isSystemName, isInternalName, isExternalName,-        isTyVarName, isTyConName, isDataConName,-        isValName, isVarName,-        isWiredInName, isWiredIn, isBuiltInSyntax,-        isHoleName,-        wiredInNameTyThing_maybe,-        nameIsLocalOrFrom, nameIsHomePackage,-        nameIsHomePackageImport, nameIsFromExternalPackage,-        stableNameCmp,--        -- * Class 'NamedThing' and overloaded friends-        NamedThing(..),-        getSrcLoc, getSrcSpan, getOccString, getOccFS,--        pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified,-        nameStableString,--        -- Re-export the OccName stuff-        module OccName-    ) where--import GhcPrelude--import {-# SOURCE #-} TyCoRep( TyThing )--import OccName-import Module-import SrcLoc-import Unique-import Util-import Maybes-import Binary-import FastString-import Outputable--import Control.DeepSeq-import Data.Data--{--************************************************************************-*                                                                      *-\subsection[Name-datatype]{The @Name@ datatype, and name construction}-*                                                                      *-************************************************************************--}---- | A unique, unambiguous name for something, containing information about where--- that thing originated.-data Name = Name {-                n_sort :: NameSort,     -- What sort of name it is-                n_occ  :: !OccName,     -- Its occurrence name-                n_uniq :: {-# UNPACK #-} !Unique,-                n_loc  :: !SrcSpan      -- Definition site-            }---- NOTE: we make the n_loc field strict to eliminate some potential--- (and real!) space leaks, due to the fact that we don't look at--- the SrcLoc in a Name all that often.---- See Note [About the NameSorts]-data NameSort-  = External Module--  | WiredIn Module TyThing BuiltInSyntax-        -- A variant of External, for wired-in things--  | Internal            -- A user-defined Id or TyVar-                        -- defined in the module being compiled--  | System              -- A system-defined Id or TyVar.  Typically the-                        -- OccName is very uninformative (like 's')--instance Outputable NameSort where-  ppr (External _)    = text "external"-  ppr (WiredIn _ _ _) = text "wired-in"-  ppr  Internal       = text "internal"-  ppr  System         = text "system"--instance NFData Name where-  rnf Name{..} = rnf n_sort--instance NFData NameSort where-  rnf (External m) = rnf m-  rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` ()-    -- XXX this is a *lie*, we're not going to rnf the TyThing, but-    -- since the TyThings for WiredIn Names are all static they can't-    -- be hiding space leaks or errors.-  rnf Internal = ()-  rnf System = ()---- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples,--- which have special syntactic forms.  They aren't in scope--- as such.-data BuiltInSyntax = BuiltInSyntax | UserSyntax--{--Note [About the NameSorts]--1.  Initially, top-level Ids (including locally-defined ones) get External names,-    and all other local Ids get Internal names--2.  In any invocation of GHC, an External Name for "M.x" has one and only one-    unique.  This unique association is ensured via the Name Cache;-    see Note [The Name Cache] in GHC.Iface.Env.--3.  Things with a External name are given C static labels, so they finally-    appear in the .o file's symbol table.  They appear in the symbol table-    in the form M.n.  If originally-local things have this property they-    must be made @External@ first.--4.  In the tidy-core phase, a External that is not visible to an importer-    is changed to Internal, and a Internal that is visible is changed to External--5.  A System Name differs in the following ways:-        a) has unique attached when printing dumps-        b) unifier eliminates sys tyvars in favour of user provs where possible--    Before anything gets printed in interface files or output code, it's-    fed through a 'tidy' processor, which zaps the OccNames to have-    unique names; and converts all sys-locals to user locals-    If any desugarer sys-locals have survived that far, they get changed to-    "ds1", "ds2", etc.--Built-in syntax => It's a syntactic form, not "in scope" (e.g. [])--Wired-in thing  => The thing (Id, TyCon) is fully known to the compiler,-                   not read from an interface file.-                   E.g. Bool, True, Int, Float, and many others--All built-in syntax is for wired-in things.--}--instance HasOccName Name where-  occName = nameOccName--nameUnique              :: Name -> Unique-nameOccName             :: Name -> OccName-nameNameSpace           :: Name -> NameSpace-nameModule              :: HasDebugCallStack => Name -> Module-nameSrcLoc              :: Name -> SrcLoc-nameSrcSpan             :: Name -> SrcSpan--nameUnique    name = n_uniq name-nameOccName   name = n_occ  name-nameNameSpace name = occNameSpace (n_occ name)-nameSrcLoc    name = srcSpanStart (n_loc name)-nameSrcSpan   name = n_loc  name--{--************************************************************************-*                                                                      *-\subsection{Predicates on names}-*                                                                      *-************************************************************************--}--isInternalName    :: Name -> Bool-isExternalName    :: Name -> Bool-isSystemName      :: Name -> Bool-isWiredInName     :: Name -> Bool--isWiredInName (Name {n_sort = WiredIn _ _ _}) = True-isWiredInName _                               = False--isWiredIn :: NamedThing thing => thing -> Bool-isWiredIn = isWiredInName . getName--wiredInNameTyThing_maybe :: Name -> Maybe TyThing-wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing-wiredInNameTyThing_maybe _                                   = Nothing--isBuiltInSyntax :: Name -> Bool-isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True-isBuiltInSyntax _                                           = False--isExternalName (Name {n_sort = External _})    = True-isExternalName (Name {n_sort = WiredIn _ _ _}) = True-isExternalName _                               = False--isInternalName name = not (isExternalName name)--isHoleName :: Name -> Bool-isHoleName = isHoleModule . nameModule--nameModule name =-  nameModule_maybe name `orElse`-  pprPanic "nameModule" (ppr (n_sort name) <+> ppr name)--nameModule_maybe :: Name -> Maybe Module-nameModule_maybe (Name { n_sort = External mod})    = Just mod-nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod-nameModule_maybe _                                  = Nothing--nameIsLocalOrFrom :: Module -> Name -> Bool--- ^ Returns True if the name is---   (a) Internal---   (b) External but from the specified module---   (c) External but from the 'interactive' package------ The key idea is that---    False means: the entity is defined in some other module---                 you can find the details (type, fixity, instances)---                     in some interface file---                 those details will be stored in the EPT or HPT------    True means:  the entity is defined in this module or earlier in---                     the GHCi session---                 you can find details (type, fixity, instances) in the---                     TcGblEnv or TcLclEnv------ The isInteractiveModule part is because successive interactions of a GHCi session--- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come--- from the magic 'interactive' package; and all the details are kept in the--- TcLclEnv, TcGblEnv, NOT in the HPT or EPT.--- See Note [The interactive package] in GHC.Driver.Types--nameIsLocalOrFrom from name-  | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod-  | otherwise                         = True--nameIsHomePackage :: Module -> Name -> Bool--- True if the Name is defined in module of this package-nameIsHomePackage this_mod-  = \nm -> case n_sort nm of-              External nm_mod    -> moduleUnitId nm_mod == this_pkg-              WiredIn nm_mod _ _ -> moduleUnitId nm_mod == this_pkg-              Internal -> True-              System   -> False-  where-    this_pkg = moduleUnitId this_mod--nameIsHomePackageImport :: Module -> Name -> Bool--- True if the Name is defined in module of this package--- /other than/ the this_mod-nameIsHomePackageImport this_mod-  = \nm -> case nameModule_maybe nm of-              Nothing -> False-              Just nm_mod -> nm_mod /= this_mod-                          && moduleUnitId nm_mod == this_pkg-  where-    this_pkg = moduleUnitId this_mod---- | Returns True if the Name comes from some other package: neither this--- package nor the interactive package.-nameIsFromExternalPackage :: UnitId -> Name -> Bool-nameIsFromExternalPackage this_pkg name-  | Just mod <- nameModule_maybe name-  , moduleUnitId mod /= this_pkg    -- Not this package-  , not (isInteractiveModule mod)       -- Not the 'interactive' package-  = True-  | otherwise-  = False--isTyVarName :: Name -> Bool-isTyVarName name = isTvOcc (nameOccName name)--isTyConName :: Name -> Bool-isTyConName name = isTcOcc (nameOccName name)--isDataConName :: Name -> Bool-isDataConName name = isDataOcc (nameOccName name)--isValName :: Name -> Bool-isValName name = isValOcc (nameOccName name)--isVarName :: Name -> Bool-isVarName = isVarOcc . nameOccName--isSystemName (Name {n_sort = System}) = True-isSystemName _                        = False--{--************************************************************************-*                                                                      *-\subsection{Making names}-*                                                                      *-************************************************************************--}---- | Create a name which is (for now at least) local to the current module and hence--- does not need a 'Module' to disambiguate it from other 'Name's-mkInternalName :: Unique -> OccName -> SrcSpan -> Name-mkInternalName uniq occ loc = Name { n_uniq = uniq-                                   , n_sort = Internal-                                   , n_occ = occ-                                   , n_loc = loc }-        -- NB: You might worry that after lots of huffing and-        -- puffing we might end up with two local names with distinct-        -- uniques, but the same OccName.  Indeed we can, but that's ok-        --      * the insides of the compiler don't care: they use the Unique-        --      * when printing for -ddump-xxx you can switch on -dppr-debug to get the-        --        uniques if you get confused-        --      * for interface files we tidyCore first, which makes-        --        the OccNames distinct when they need to be--mkClonedInternalName :: Unique -> Name -> Name-mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc })-  = Name { n_uniq = uniq, n_sort = Internal-         , n_occ = occ, n_loc = loc }--mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name-mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc })-  = Name { n_uniq = uniq, n_sort = Internal-         , n_occ = derive_occ occ, n_loc = loc }---- | Create a name which definitely originates in the given module-mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name--- WATCH OUT! External Names should be in the Name Cache--- (see Note [The Name Cache] in GHC.Iface.Env), so don't just call mkExternalName--- with some fresh unique without populating the Name Cache-mkExternalName uniq mod occ loc-  = Name { n_uniq = uniq, n_sort = External mod,-           n_occ = occ, n_loc = loc }---- | Create a name which is actually defined by the compiler itself-mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name-mkWiredInName mod occ uniq thing built_in-  = Name { n_uniq = uniq,-           n_sort = WiredIn mod thing built_in,-           n_occ = occ, n_loc = wiredInSrcSpan }---- | Create a name brought into being by the compiler-mkSystemName :: Unique -> OccName -> Name-mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan--mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name-mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System-                                   , n_occ = occ, n_loc = loc }--mkSystemVarName :: Unique -> FastString -> Name-mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs)--mkSysTvName :: Unique -> FastString -> Name-mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs)---- | Make a name for a foreign call-mkFCallName :: Unique -> String -> Name-mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan-   -- The encoded string completely describes the ccall---- When we renumber/rename things, we need to be--- able to change a Name's Unique to match the cached--- one in the thing it's the name of.  If you know what I mean.-setNameUnique :: Name -> Unique -> Name-setNameUnique name uniq = name {n_uniq = uniq}---- This is used for hsigs: we want to use the name of the originally exported--- entity, but edit the location to refer to the reexport site-setNameLoc :: Name -> SrcSpan -> Name-setNameLoc name loc = name {n_loc = loc}--tidyNameOcc :: Name -> OccName -> Name--- We set the OccName of a Name when tidying--- In doing so, we change System --> Internal, so that when we print--- it we don't get the unique by default.  It's tidy now!-tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal}-tidyNameOcc name                            occ = name { n_occ = occ }---- | Make the 'Name' into an internal name, regardless of what it was to begin with-localiseName :: Name -> Name-localiseName n = n { n_sort = Internal }--{--************************************************************************-*                                                                      *-\subsection{Hashing and comparison}-*                                                                      *-************************************************************************--}--cmpName :: Name -> Name -> Ordering-cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2---- | Compare Names lexicographically--- This only works for Names that originate in the source code or have been--- tidied.-stableNameCmp :: Name -> Name -> Ordering-stableNameCmp (Name { n_sort = s1, n_occ = occ1 })-              (Name { n_sort = s2, n_occ = occ2 })-  = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2)-    -- The ordinary compare on OccNames is lexicographic-  where-    -- Later constructors are bigger-    sort_cmp (External m1) (External m2)       = m1 `stableModuleCmp` m2-    sort_cmp (External {}) _                   = LT-    sort_cmp (WiredIn {}) (External {})        = GT-    sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2-    sort_cmp (WiredIn {})     _                = LT-    sort_cmp Internal         (External {})    = GT-    sort_cmp Internal         (WiredIn {})     = GT-    sort_cmp Internal         Internal         = EQ-    sort_cmp Internal         System           = LT-    sort_cmp System           System           = EQ-    sort_cmp System           _                = GT--{--************************************************************************-*                                                                      *-\subsection[Name-instances]{Instance declarations}-*                                                                      *-************************************************************************--}---- | The same comments as for `Name`'s `Ord` instance apply.-instance Eq Name where-    a == b = case (a `compare` b) of { EQ -> True;  _ -> False }-    a /= b = case (a `compare` b) of { EQ -> False; _ -> True }---- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which--- means that the ordering is not stable across deserialization or rebuilds.------ See `nonDetCmpUnique` for further information, and trac #15240 for a bug--- caused by improper use of this instance.---- For a deterministic lexicographic ordering, use `stableNameCmp`.-instance Ord Name where-    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }-    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }-    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }-    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }-    compare a b = cmpName a b--instance Uniquable Name where-    getUnique = nameUnique--instance NamedThing Name where-    getName n = n--instance Data Name where-  -- don't traverse?-  toConstr _   = abstractConstr "Name"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "Name"--{--************************************************************************-*                                                                      *-\subsection{Binary}-*                                                                      *-************************************************************************--}---- | Assumes that the 'Name' is a non-binding one. See--- 'GHC.Iface.Syntax.putIfaceTopBndr' and 'GHC.Iface.Syntax.getIfaceTopBndr' for--- serializing binding 'Name's. See 'UserData' for the rationale for this--- distinction.-instance Binary Name where-   put_ bh name =-      case getUserData bh of-        UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name--   get bh =-      case getUserData bh of-        UserData { ud_get_name = get_name } -> get_name bh--{--************************************************************************-*                                                                      *-\subsection{Pretty printing}-*                                                                      *-************************************************************************--}--instance Outputable Name where-    ppr name = pprName name--instance OutputableBndr Name where-    pprBndr _ name = pprName name-    pprInfixOcc  = pprInfixName-    pprPrefixOcc = pprPrefixName--pprName :: Name -> SDoc-pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ})-  = getPprStyle $ \ sty ->-    case sort of-      WiredIn mod _ builtin   -> pprExternal sty uniq mod occ True  builtin-      External mod            -> pprExternal sty uniq mod occ False UserSyntax-      System                  -> pprSystem sty uniq occ-      Internal                -> pprInternal sty uniq occ---- | Print the string of Name unqualifiedly directly.-pprNameUnqualified :: Name -> SDoc-pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ--pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc-pprExternal sty uniq mod occ is_wired is_builtin-  | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ-        -- In code style, always qualify-        -- ToDo: maybe we could print all wired-in things unqualified-        --       in code style, to reduce symbol table bloat?-  | debugStyle sty = pp_mod <> ppr_occ_name occ-                     <> braces (hsep [if is_wired then text "(w)" else empty,-                                      pprNameSpaceBrief (occNameSpace occ),-                                      pprUnique uniq])-  | BuiltInSyntax <- is_builtin = ppr_occ_name occ  -- Never qualify builtin syntax-  | otherwise                   =-        if isHoleModule mod-            then case qualName sty mod occ of-                    NameUnqual -> ppr_occ_name occ-                    _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ)-            else pprModulePrefix sty mod occ <> ppr_occ_name occ-  where-    pp_mod = ppUnlessOption sdocSuppressModulePrefixes-               (ppr mod <> dot)--pprInternal :: PprStyle -> Unique -> OccName -> SDoc-pprInternal sty uniq occ-  | codeStyle sty  = pprUniqueAlways uniq-  | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ),-                                                       pprUnique uniq])-  | dumpStyle sty  = ppr_occ_name occ <> ppr_underscore_unique uniq-                        -- For debug dumps, we're not necessarily dumping-                        -- tidied code, so we need to print the uniques.-  | otherwise      = ppr_occ_name occ   -- User style---- Like Internal, except that we only omit the unique in Iface style-pprSystem :: PprStyle -> Unique -> OccName -> SDoc-pprSystem sty uniq occ-  | codeStyle sty  = pprUniqueAlways uniq-  | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq-                     <> braces (pprNameSpaceBrief (occNameSpace occ))-  | otherwise      = ppr_occ_name occ <> ppr_underscore_unique uniq-                                -- If the tidy phase hasn't run, the OccName-                                -- is unlikely to be informative (like 's'),-                                -- so print the unique---pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc--- Print the "M." part of a name, based on whether it's in scope or not--- See Note [Printing original names] in GHC.Driver.Types-pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $-    case qualName sty mod occ of              -- See Outputable.QualifyName:-      NameQual modname -> ppr modname <> dot       -- Name is in scope-      NameNotInScope1  -> ppr mod <> dot           -- Not in scope-      NameNotInScope2  -> ppr (moduleUnitId mod) <> colon     -- Module not in-                          <> ppr (moduleName mod) <> dot          -- scope either-      NameUnqual       -> empty                   -- In scope unqualified--pprUnique :: Unique -> SDoc--- Print a unique unless we are suppressing them-pprUnique uniq-  = ppUnlessOption sdocSuppressUniques $-      pprUniqueAlways uniq--ppr_underscore_unique :: Unique -> SDoc--- Print an underscore separating the name from its unique--- But suppress it if we aren't printing the uniques anyway-ppr_underscore_unique uniq-  = ppUnlessOption sdocSuppressUniques $-      char '_' <> pprUniqueAlways uniq--ppr_occ_name :: OccName -> SDoc-ppr_occ_name occ = ftext (occNameFS occ)-        -- Don't use pprOccName; instead, just print the string of the OccName;-        -- we print the namespace in the debug stuff above---- In code style, we Z-encode the strings.  The results of Z-encoding each FastString are--- cached behind the scenes in the FastString implementation.-ppr_z_occ_name :: OccName -> SDoc-ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ))---- Prints (if mod information is available) "Defined at <loc>" or---  "Defined in <mod>" information for a Name.-pprDefinedAt :: Name -> SDoc-pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name--pprNameDefnLoc :: Name -> SDoc--- Prints "at <loc>" or---     or "in <mod>" depending on what info is available-pprNameDefnLoc name-  = case nameSrcLoc name of-         -- nameSrcLoc rather than nameSrcSpan-         -- It seems less cluttered to show a location-         -- rather than a span for the definition point-       RealSrcLoc s _ -> text "at" <+> ppr s-       UnhelpfulLoc s-         | isInternalName name || isSystemName name-         -> text "at" <+> ftext s-         | otherwise-         -> text "in" <+> quotes (ppr (nameModule name))----- | Get a string representation of a 'Name' that's unique and stable--- across recompilations. Used for deterministic generation of binds for--- derived instances.--- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String"-nameStableString :: Name -> String-nameStableString Name{..} =-  nameSortStableString n_sort ++ "$" ++ occNameString n_occ--nameSortStableString :: NameSort -> String-nameSortStableString System = "$_sys"-nameSortStableString Internal = "$_in"-nameSortStableString (External mod) = moduleStableString mod-nameSortStableString (WiredIn mod _ _) = moduleStableString mod--{--************************************************************************-*                                                                      *-\subsection{Overloaded functions related to Names}-*                                                                      *-************************************************************************--}---- | A class allowing convenient access to the 'Name' of various datatypes-class NamedThing a where-    getOccName :: a -> OccName-    getName    :: a -> Name--    getOccName n = nameOccName (getName n)      -- Default method--instance NamedThing e => NamedThing (Located e) where-    getName = getName . unLoc--getSrcLoc           :: NamedThing a => a -> SrcLoc-getSrcSpan          :: NamedThing a => a -> SrcSpan-getOccString        :: NamedThing a => a -> String-getOccFS            :: NamedThing a => a -> FastString--getSrcLoc           = nameSrcLoc           . getName-getSrcSpan          = nameSrcSpan          . getName-getOccString        = occNameString        . getOccName-getOccFS            = occNameFS            . getOccName--pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc--- See Outputable.pprPrefixVar, pprInfixVar;--- add parens or back-quotes as appropriate-pprInfixName  n = pprInfixVar (isSymOcc (getOccName n)) (ppr n)--pprPrefixName :: NamedThing a => a -> SDoc-pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name)- where-   name = getName thing
− compiler/basicTypes/Name.hs-boot 
@@ -1,5 +0,0 @@-module Name where--import GhcPrelude ()--data Name
− compiler/basicTypes/NameCache.hs 
@@ -1,120 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}---- | The Name Cache-module NameCache-    ( lookupOrigNameCache-    , extendOrigNameCache-    , extendNameCache-    , initNameCache-    , NameCache(..), OrigNameCache-    ) where--import GhcPrelude--import Module-import Name-import UniqSupply-import TysWiredIn-import Util-import Outputable-import PrelNames--#include "HsVersions.h"--{---Note [The Name Cache]-~~~~~~~~~~~~~~~~~~~~~-The Name Cache makes sure that, during any invocation of GHC, each-External Name "M.x" has one, and only one globally-agreed Unique.--* The first time we come across M.x we make up a Unique and record that-  association in the Name Cache.--* When we come across "M.x" again, we look it up in the Name Cache,-  and get a hit.--The functions newGlobalBinder, allocateGlobalBinder do the main work.-When you make an External name, you should probably be calling one-of them.---Note [Built-in syntax and the OrigNameCache]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower-their cost we use two tricks,--  a. We specially encode tuple and sum Names in interface files' symbol tables-     to avoid having to look up their names while loading interface files.-     Namely these names are encoded as by their Uniques. We know how to get from-     a Unique back to the Name which it represents via the mapping defined in-     the SumTupleUniques module. See Note [Symbol table representation of names]-     in GHC.Iface.Binary and for details.--  b. We don't include them in the Orig name cache but instead parse their-     OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with-     them.--Why is the second measure necessary? Good question; afterall, 1) the parser-emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never-needs to looked-up during interface loading due to (a). It turns out that there-are two reasons why we might look up an Orig RdrName for built-in syntax,--  * If you use setRdrNameSpace on an Exact RdrName it may be-    turned into an Orig RdrName.--  * Template Haskell turns a BuiltInSyntax Name into a TH.NameG-    (GHC.HsToCore.Quote.globalVar), and parses a NameG into an Orig RdrName-    (GHC.ThToHs.thRdrName).  So, e.g. $(do { reify '(,); ... }) will-    go this route (#8954).---}---- | Per-module cache of original 'OccName's given 'Name's-type OrigNameCache   = ModuleEnv (OccEnv Name)--lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name-lookupOrigNameCache nc mod occ-  | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE-  , Just name <- isBuiltInOcc_maybe occ-  =     -- See Note [Known-key names], 3(c) in PrelNames-        -- Special case for tuples; there are too many-        -- of them to pre-populate the original-name cache-    Just name--  | otherwise-  = case lookupModuleEnv nc mod of-        Nothing      -> Nothing-        Just occ_env -> lookupOccEnv occ_env occ--extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache-extendOrigNameCache nc name-  = ASSERT2( isExternalName name, ppr name )-    extendNameCache nc (nameModule name) (nameOccName name) name--extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache-extendNameCache nc mod occ name-  = extendModuleEnvWith combine nc mod (unitOccEnv occ name)-  where-    combine _ occ_env = extendOccEnv occ_env occ name---- | The NameCache makes sure that there is just one Unique assigned for--- each original name; i.e. (module-name, occ-name) pair and provides--- something of a lookup mechanism for those names.-data NameCache- = NameCache {  nsUniqs :: !UniqSupply,-                -- ^ Supply of uniques-                nsNames :: !OrigNameCache-                -- ^ Ensures that one original name gets one unique-   }---- | Return a function to atomically update the name cache.-initNameCache :: UniqSupply -> [Name] -> NameCache-initNameCache us names-  = NameCache { nsUniqs = us,-                nsNames = initOrigNames names }--initOrigNames :: [Name] -> OrigNameCache-initOrigNames names = foldl' extendOrigNameCache emptyModuleEnv names
− compiler/basicTypes/NameEnv.hs 
@@ -1,175 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[NameEnv]{@NameEnv@: name environments}--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}--module NameEnv (-        -- * Var, Id and TyVar environments (maps)-        NameEnv,--        -- ** Manipulating these environments-        mkNameEnv, mkNameEnvWith,-        emptyNameEnv, isEmptyNameEnv,-        unitNameEnv, nameEnvElts,-        extendNameEnv_C, extendNameEnv_Acc, extendNameEnv,-        extendNameEnvList, extendNameEnvList_C,-        filterNameEnv, anyNameEnv,-        plusNameEnv, plusNameEnv_C, alterNameEnv,-        lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,-        elemNameEnv, mapNameEnv, disjointNameEnv,--        DNameEnv,--        emptyDNameEnv,-        lookupDNameEnv,-        delFromDNameEnv, filterDNameEnv,-        mapDNameEnv,-        adjustDNameEnv, alterDNameEnv, extendDNameEnv,-        -- ** Dependency analysis-        depAnal-    ) where--#include "HsVersions.h"--import GhcPrelude--import Digraph-import Name-import UniqFM-import UniqDFM-import Maybes--{--************************************************************************-*                                                                      *-\subsection{Name environment}-*                                                                      *-************************************************************************--}--{--Note [depAnal determinism]-~~~~~~~~~~~~~~~~~~~~~~~~~~-depAnal is deterministic provided it gets the nodes in a deterministic order.-The order of lists that get_defs and get_uses return doesn't matter, as these-are only used to construct the edges, and stronglyConnCompFromEdgedVertices is-deterministic even when the edges are not in deterministic order as explained-in Note [Deterministic SCC] in Digraph.--}--depAnal :: forall node.-           (node -> [Name])      -- Defs-        -> (node -> [Name])      -- Uses-        -> [node]-        -> [SCC node]--- Perform dependency analysis on a group of definitions,--- where each definition may define more than one Name------ The get_defs and get_uses functions are called only once per node-depAnal get_defs get_uses nodes-  = stronglyConnCompFromEdgedVerticesUniq graph_nodes-  where-    graph_nodes = (map mk_node keyed_nodes) :: [Node Int node]-    keyed_nodes = nodes `zip` [(1::Int)..]-    mk_node (node, key) =-      let !edges = (mapMaybe (lookupNameEnv key_map) (get_uses node))-      in DigraphNode node key edges--    key_map :: NameEnv Int   -- Maps a Name to the key of the decl that defines it-    key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node]--{--************************************************************************-*                                                                      *-\subsection{Name environment}-*                                                                      *-************************************************************************--}---- | Name Environment-type NameEnv a = UniqFM a       -- Domain is Name--emptyNameEnv       :: NameEnv a-isEmptyNameEnv     :: NameEnv a -> Bool-mkNameEnv          :: [(Name,a)] -> NameEnv a-mkNameEnvWith      :: (a -> Name) -> [a] -> NameEnv a-nameEnvElts        :: NameEnv a -> [a]-alterNameEnv       :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a-extendNameEnv_C    :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a-extendNameEnv_Acc  :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b-extendNameEnv      :: NameEnv a -> Name -> a -> NameEnv a-plusNameEnv        :: NameEnv a -> NameEnv a -> NameEnv a-plusNameEnv_C      :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a-extendNameEnvList  :: NameEnv a -> [(Name,a)] -> NameEnv a-extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a-delFromNameEnv     :: NameEnv a -> Name -> NameEnv a-delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a-elemNameEnv        :: Name -> NameEnv a -> Bool-unitNameEnv        :: Name -> a -> NameEnv a-lookupNameEnv      :: NameEnv a -> Name -> Maybe a-lookupNameEnv_NF   :: NameEnv a -> Name -> a-filterNameEnv      :: (elt -> Bool) -> NameEnv elt -> NameEnv elt-anyNameEnv         :: (elt -> Bool) -> NameEnv elt -> Bool-mapNameEnv         :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2-disjointNameEnv    :: NameEnv a -> NameEnv a -> Bool--nameEnvElts x         = eltsUFM x-emptyNameEnv          = emptyUFM-isEmptyNameEnv        = isNullUFM-unitNameEnv x y       = unitUFM x y-extendNameEnv x y z   = addToUFM x y z-extendNameEnvList x l = addListToUFM x l-lookupNameEnv x y     = lookupUFM x y-alterNameEnv          = alterUFM-mkNameEnv     l       = listToUFM l-mkNameEnvWith f       = mkNameEnv . map (\a -> (f a, a))-elemNameEnv x y          = elemUFM x y-plusNameEnv x y          = plusUFM x y-plusNameEnv_C f x y      = plusUFM_C f x y-extendNameEnv_C f x y z  = addToUFM_C f x y z-mapNameEnv f x           = mapUFM f x-extendNameEnv_Acc x y z a b  = addToUFM_Acc x y z a b-extendNameEnvList_C x y z = addListToUFM_C x y z-delFromNameEnv x y      = delFromUFM x y-delListFromNameEnv x y  = delListFromUFM x y-filterNameEnv x y       = filterUFM x y-anyNameEnv f x          = foldUFM ((||) . f) False x-disjointNameEnv x y     = isNullUFM (intersectUFM x y)--lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n)---- | Deterministic Name Environment------ See Note [Deterministic UniqFM] in UniqDFM for explanation why we need--- DNameEnv.-type DNameEnv a = UniqDFM a--emptyDNameEnv :: DNameEnv a-emptyDNameEnv = emptyUDFM--lookupDNameEnv :: DNameEnv a -> Name -> Maybe a-lookupDNameEnv = lookupUDFM--delFromDNameEnv :: DNameEnv a -> Name -> DNameEnv a-delFromDNameEnv = delFromUDFM--filterDNameEnv :: (a -> Bool) -> DNameEnv a -> DNameEnv a-filterDNameEnv = filterUDFM--mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b-mapDNameEnv = mapUDFM--adjustDNameEnv :: (a -> a) -> DNameEnv a -> Name -> DNameEnv a-adjustDNameEnv = adjustUDFM--alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a-alterDNameEnv = alterUDFM--extendDNameEnv :: DNameEnv a -> Name -> a -> DNameEnv a-extendDNameEnv = addToUDFM
− compiler/basicTypes/NameSet.hs 
@@ -1,215 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1998--}--{-# LANGUAGE CPP #-}-module NameSet (-        -- * Names set type-        NameSet,--        -- ** Manipulating these sets-        emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets,-        minusNameSet, elemNameSet, extendNameSet, extendNameSetList,-        delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet,-        intersectsNameSet, intersectNameSet,-        nameSetAny, nameSetAll, nameSetElemsStable,--        -- * Free variables-        FreeVars,--        -- ** Manipulating sets of free variables-        isEmptyFVs, emptyFVs, plusFVs, plusFV,-        mkFVs, addOneFV, unitFV, delFV, delFVs,-        intersectFVs,--        -- * Defs and uses-        Defs, Uses, DefUse, DefUses,--        -- ** Manipulating defs and uses-        emptyDUs, usesOnly, mkDUs, plusDU,-        findUses, duDefs, duUses, allUses-    ) where--#include "HsVersions.h"--import GhcPrelude--import Name-import OrdList-import UniqSet-import Data.List (sortBy)--{--************************************************************************-*                                                                      *-\subsection[Sets of names}-*                                                                      *-************************************************************************--}--type NameSet = UniqSet Name--emptyNameSet       :: NameSet-unitNameSet        :: Name -> NameSet-extendNameSetList   :: NameSet -> [Name] -> NameSet-extendNameSet    :: NameSet -> Name -> NameSet-mkNameSet          :: [Name] -> NameSet-unionNameSet      :: NameSet -> NameSet -> NameSet-unionNameSets  :: [NameSet] -> NameSet-minusNameSet       :: NameSet -> NameSet -> NameSet-elemNameSet        :: Name -> NameSet -> Bool-isEmptyNameSet     :: NameSet -> Bool-delFromNameSet     :: NameSet -> Name -> NameSet-delListFromNameSet :: NameSet -> [Name] -> NameSet-filterNameSet      :: (Name -> Bool) -> NameSet -> NameSet-intersectNameSet   :: NameSet -> NameSet -> NameSet-intersectsNameSet  :: NameSet -> NameSet -> Bool--- ^ True if there is a non-empty intersection.--- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty--isEmptyNameSet    = isEmptyUniqSet-emptyNameSet      = emptyUniqSet-unitNameSet       = unitUniqSet-mkNameSet         = mkUniqSet-extendNameSetList  = addListToUniqSet-extendNameSet   = addOneToUniqSet-unionNameSet     = unionUniqSets-unionNameSets = unionManyUniqSets-minusNameSet      = minusUniqSet-elemNameSet       = elementOfUniqSet-delFromNameSet    = delOneFromUniqSet-filterNameSet     = filterUniqSet-intersectNameSet  = intersectUniqSets--delListFromNameSet set ns = foldl' delFromNameSet set ns--intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2))--nameSetAny :: (Name -> Bool) -> NameSet -> Bool-nameSetAny = uniqSetAny--nameSetAll :: (Name -> Bool) -> NameSet -> Bool-nameSetAll = uniqSetAll---- | Get the elements of a NameSet with some stable ordering.--- This only works for Names that originate in the source code or have been--- tidied.--- See Note [Deterministic UniqFM] to learn about nondeterminism-nameSetElemsStable :: NameSet -> [Name]-nameSetElemsStable ns =-  sortBy stableNameCmp $ nonDetEltsUniqSet ns-  -- It's OK to use nonDetEltsUniqSet here because we immediately sort-  -- with stableNameCmp--{--************************************************************************-*                                                                      *-\subsection{Free variables}-*                                                                      *-************************************************************************--These synonyms are useful when we are thinking of free variables--}--type FreeVars   = NameSet--plusFV   :: FreeVars -> FreeVars -> FreeVars-addOneFV :: FreeVars -> Name -> FreeVars-unitFV   :: Name -> FreeVars-emptyFVs :: FreeVars-plusFVs  :: [FreeVars] -> FreeVars-mkFVs    :: [Name] -> FreeVars-delFV    :: Name -> FreeVars -> FreeVars-delFVs   :: [Name] -> FreeVars -> FreeVars-intersectFVs :: FreeVars -> FreeVars -> FreeVars--isEmptyFVs :: NameSet -> Bool-isEmptyFVs  = isEmptyNameSet-emptyFVs    = emptyNameSet-plusFVs     = unionNameSets-plusFV      = unionNameSet-mkFVs       = mkNameSet-addOneFV    = extendNameSet-unitFV      = unitNameSet-delFV n s   = delFromNameSet s n-delFVs ns s = delListFromNameSet s ns-intersectFVs = intersectNameSet--{--************************************************************************-*                                                                      *-                Defs and uses-*                                                                      *-************************************************************************--}---- | A set of names that are defined somewhere-type Defs = NameSet---- | A set of names that are used somewhere-type Uses = NameSet---- | @(Just ds, us) =>@ The use of any member of the @ds@---                      implies that all the @us@ are used too.---                      Also, @us@ may mention @ds@.------ @Nothing =>@ Nothing is defined in this group, but---              nevertheless all the uses are essential.---              Used for instance declarations, for example-type DefUse  = (Maybe Defs, Uses)---- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses'---   In a single (def, use) pair, the defs also scope over the uses-type DefUses = OrdList DefUse--emptyDUs :: DefUses-emptyDUs = nilOL--usesOnly :: Uses -> DefUses-usesOnly uses = unitOL (Nothing, uses)--mkDUs :: [(Defs,Uses)] -> DefUses-mkDUs pairs = toOL [(Just defs, uses) | (defs,uses) <- pairs]--plusDU :: DefUses -> DefUses -> DefUses-plusDU = appOL--duDefs :: DefUses -> Defs-duDefs dus = foldr get emptyNameSet dus-  where-    get (Nothing, _u1) d2 = d2-    get (Just d1, _u1) d2 = d1 `unionNameSet` d2--allUses :: DefUses -> Uses--- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned-allUses dus = foldr get emptyNameSet dus-  where-    get (_d1, u1) u2 = u1 `unionNameSet` u2--duUses :: DefUses -> Uses--- ^ Collect all 'Uses', regardless of whether the group is itself used,--- but remove 'Defs' on the way-duUses dus = foldr get emptyNameSet dus-  where-    get (Nothing,   rhs_uses) uses = rhs_uses `unionNameSet` uses-    get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSet` uses)-                                     `minusNameSet` defs--findUses :: DefUses -> Uses -> Uses--- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively.--- The result is a superset of the input 'Uses'; and includes things defined--- in the input 'DefUses' (but only if they are used)-findUses dus uses-  = foldr get uses dus-  where-    get (Nothing, rhs_uses) uses-        = rhs_uses `unionNameSet` uses-    get (Just defs, rhs_uses) uses-        | defs `intersectsNameSet` uses         -- Used-        || nameSetAny (startsWithUnderscore . nameOccName) defs-                -- At least one starts with an "_",-                -- so treat the group as used-        = rhs_uses `unionNameSet` uses-        | otherwise     -- No def is used-        = uses
− compiler/basicTypes/OccName.hs 
@@ -1,927 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}---- |--- #name_types#--- GHC uses several kinds of name internally:------ * 'OccName.OccName' represents names as strings with just a little more information:---   the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or---   data constructors------ * 'RdrName.RdrName': see "RdrName#name_types"------ * 'Name.Name': see "Name#name_types"------ * 'Id.Id': see "Id#name_types"------ * 'Var.Var': see "Var#name_types"--module OccName (-        -- * The 'NameSpace' type-        NameSpace, -- Abstract--        nameSpacesRelated,--        -- ** Construction-        -- $real_vs_source_data_constructors-        tcName, clsName, tcClsName, dataName, varName,-        tvName, srcDataName,--        -- ** Pretty Printing-        pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief,--        -- * The 'OccName' type-        OccName,        -- Abstract, instance of Outputable-        pprOccName,--        -- ** Construction-        mkOccName, mkOccNameFS,-        mkVarOcc, mkVarOccFS,-        mkDataOcc, mkDataOccFS,-        mkTyVarOcc, mkTyVarOccFS,-        mkTcOcc, mkTcOccFS,-        mkClsOcc, mkClsOccFS,-        mkDFunOcc,-        setOccNameSpace,-        demoteOccName,-        HasOccName(..),--        -- ** Derived 'OccName's-        isDerivedOccName,-        mkDataConWrapperOcc, mkWorkerOcc,-        mkMatcherOcc, mkBuilderOcc,-        mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc,-        mkNewTyCoOcc, mkClassOpAuxOcc,-        mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,-        mkClassDataConOcc, mkDictOcc, mkIPOcc,-        mkSpecOcc, mkForeignExportOcc, mkRepEqOcc,-        mkGenR, mkGen1R,-        mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,-        mkSuperDictSelOcc, mkSuperDictAuxOcc,-        mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,-        mkInstTyCoOcc, mkEqPredCoOcc,-        mkRecFldSelOcc,-        mkTyConRepOcc,--        -- ** Deconstruction-        occNameFS, occNameString, occNameSpace,--        isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,-        parenSymOcc, startsWithUnderscore,--        isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace,--        -- * The 'OccEnv' type-        OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv,-        lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,-        occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,-        extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv,-        alterOccEnv, pprOccEnv,--        -- * The 'OccSet' type-        OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet,-        extendOccSetList,-        unionOccSets, unionManyOccSets, minusOccSet, elemOccSet,-        isEmptyOccSet, intersectOccSet, intersectsOccSet,-        filterOccSet,--        -- * Tidying up-        TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv,-        tidyOccName, avoidClashesOccEnv, delTidyOccEnvList,--        -- FsEnv-        FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv-    ) where--import GhcPrelude--import Util-import Unique-import UniqFM-import UniqSet-import FastString-import FastStringEnv-import Outputable-import Lexeme-import Binary-import Control.DeepSeq-import Data.Char-import Data.Data--{--************************************************************************-*                                                                      *-\subsection{Name space}-*                                                                      *-************************************************************************--}--data NameSpace = VarName        -- Variables, including "real" data constructors-               | DataName       -- "Source" data constructors-               | TvName         -- Type variables-               | TcClsName      -- Type constructors and classes; Haskell has them-                                -- in the same name space for now.-               deriving( Eq, Ord )---- Note [Data Constructors]--- see also: Note [Data Constructor Naming] in DataCon.hs------ $real_vs_source_data_constructors--- There are two forms of data constructor:------      [Source data constructors] The data constructors mentioned in Haskell source code------      [Real data constructors] The data constructors of the representation type, which may not be the same as the source type------ For example:------ > data T = T !(Int, Int)------ The source datacon has type @(Int, Int) -> T@--- The real   datacon has type @Int -> Int -> T@------ GHC chooses a representation based on the strictness etc.--tcName, clsName, tcClsName :: NameSpace-dataName, srcDataName      :: NameSpace-tvName, varName            :: NameSpace---- Though type constructors and classes are in the same name space now,--- the NameSpace type is abstract, so we can easily separate them later-tcName    = TcClsName           -- Type constructors-clsName   = TcClsName           -- Classes-tcClsName = TcClsName           -- Not sure which!--dataName    = DataName-srcDataName = DataName  -- Haskell-source data constructors should be-                        -- in the Data name space--tvName      = TvName-varName     = VarName--isDataConNameSpace :: NameSpace -> Bool-isDataConNameSpace DataName = True-isDataConNameSpace _        = False--isTcClsNameSpace :: NameSpace -> Bool-isTcClsNameSpace TcClsName = True-isTcClsNameSpace _         = False--isTvNameSpace :: NameSpace -> Bool-isTvNameSpace TvName = True-isTvNameSpace _      = False--isVarNameSpace :: NameSpace -> Bool     -- Variables or type variables, but not constructors-isVarNameSpace TvName  = True-isVarNameSpace VarName = True-isVarNameSpace _       = False--isValNameSpace :: NameSpace -> Bool-isValNameSpace DataName = True-isValNameSpace VarName  = True-isValNameSpace _        = False--pprNameSpace :: NameSpace -> SDoc-pprNameSpace DataName  = text "data constructor"-pprNameSpace VarName   = text "variable"-pprNameSpace TvName    = text "type variable"-pprNameSpace TcClsName = text "type constructor or class"--pprNonVarNameSpace :: NameSpace -> SDoc-pprNonVarNameSpace VarName = empty-pprNonVarNameSpace ns = pprNameSpace ns--pprNameSpaceBrief :: NameSpace -> SDoc-pprNameSpaceBrief DataName  = char 'd'-pprNameSpaceBrief VarName   = char 'v'-pprNameSpaceBrief TvName    = text "tv"-pprNameSpaceBrief TcClsName = text "tc"---- demoteNameSpace lowers the NameSpace if possible.  We can not know--- in advance, since a TvName can appear in an HsTyVar.--- See Note [Demotion] in GHC.Rename.Env-demoteNameSpace :: NameSpace -> Maybe NameSpace-demoteNameSpace VarName = Nothing-demoteNameSpace DataName = Nothing-demoteNameSpace TvName = Nothing-demoteNameSpace TcClsName = Just DataName--{--************************************************************************-*                                                                      *-\subsection[Name-pieces-datatypes]{The @OccName@ datatypes}-*                                                                      *-************************************************************************--}---- | Occurrence Name------ In this context that means:--- "classified (i.e. as a type name, value name, etc) but not qualified--- and not yet resolved"-data OccName = OccName-    { occNameSpace  :: !NameSpace-    , occNameFS     :: !FastString-    }--instance Eq OccName where-    (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2--instance Ord OccName where-        -- Compares lexicographically, *not* by Unique of the string-    compare (OccName sp1 s1) (OccName sp2 s2)-        = (s1  `compare` s2) `thenCmp` (sp1 `compare` sp2)--instance Data OccName where-  -- don't traverse?-  toConstr _   = abstractConstr "OccName"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "OccName"--instance HasOccName OccName where-  occName = id--instance NFData OccName where-  rnf x = x `seq` ()--{--************************************************************************-*                                                                      *-\subsection{Printing}-*                                                                      *-************************************************************************--}--instance Outputable OccName where-    ppr = pprOccName--instance OutputableBndr OccName where-    pprBndr _ = ppr-    pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n)-    pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n)--pprOccName :: OccName -> SDoc-pprOccName (OccName sp occ)-  = getPprStyle $ \ sty ->-    if codeStyle sty-    then ztext (zEncodeFS occ)-    else pp_occ <> pp_debug sty-  where-    pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp)-                 | otherwise      = empty--    pp_occ = sdocOption sdocSuppressUniques $ \case-               True  -> text (strip_th_unique (unpackFS occ))-               False -> ftext occ--        -- See Note [Suppressing uniques in OccNames]-    strip_th_unique ('[' : c : _) | isAlphaNum c = []-    strip_th_unique (c : cs) = c : strip_th_unique cs-    strip_th_unique []       = []--{--Note [Suppressing uniques in OccNames]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This is a hack to de-wobblify the OccNames that contain uniques from-Template Haskell that have been turned into a string in the OccName.-See Note [Unique OccNames from Template Haskell] in Convert.hs--************************************************************************-*                                                                      *-\subsection{Construction}-*                                                                      *-************************************************************************--}--mkOccName :: NameSpace -> String -> OccName-mkOccName occ_sp str = OccName occ_sp (mkFastString str)--mkOccNameFS :: NameSpace -> FastString -> OccName-mkOccNameFS occ_sp fs = OccName occ_sp fs--mkVarOcc :: String -> OccName-mkVarOcc s = mkOccName varName s--mkVarOccFS :: FastString -> OccName-mkVarOccFS fs = mkOccNameFS varName fs--mkDataOcc :: String -> OccName-mkDataOcc = mkOccName dataName--mkDataOccFS :: FastString -> OccName-mkDataOccFS = mkOccNameFS dataName--mkTyVarOcc :: String -> OccName-mkTyVarOcc = mkOccName tvName--mkTyVarOccFS :: FastString -> OccName-mkTyVarOccFS fs = mkOccNameFS tvName fs--mkTcOcc :: String -> OccName-mkTcOcc = mkOccName tcName--mkTcOccFS :: FastString -> OccName-mkTcOccFS = mkOccNameFS tcName--mkClsOcc :: String -> OccName-mkClsOcc = mkOccName clsName--mkClsOccFS :: FastString -> OccName-mkClsOccFS = mkOccNameFS clsName---- demoteOccName lowers the Namespace of OccName.--- see Note [Demotion]-demoteOccName :: OccName -> Maybe OccName-demoteOccName (OccName space name) = do-  space' <- demoteNameSpace space-  return $ OccName space' name---- Name spaces are related if there is a chance to mean the one when one writes--- the other, i.e. variables <-> data constructors and type variables <-> type constructors-nameSpacesRelated :: NameSpace -> NameSpace -> Bool-nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2--otherNameSpace :: NameSpace -> NameSpace-otherNameSpace VarName = DataName-otherNameSpace DataName = VarName-otherNameSpace TvName = TcClsName-otherNameSpace TcClsName = TvName----{- | Other names in the compiler add additional information to an OccName.-This class provides a consistent way to access the underlying OccName. -}-class HasOccName name where-  occName :: name -> OccName--{--************************************************************************-*                                                                      *-                Environments-*                                                                      *-************************************************************************--OccEnvs are used mainly for the envts in ModIfaces.--Note [The Unique of an OccName]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-They are efficient, because FastStrings have unique Int# keys.  We assume-this key is less than 2^24, and indeed FastStrings are allocated keys-sequentially starting at 0.--So we can make a Unique using-        mkUnique ns key  :: Unique-where 'ns' is a Char representing the name space.  This in turn makes it-easy to build an OccEnv.--}--instance Uniquable OccName where-      -- See Note [The Unique of an OccName]-  getUnique (OccName VarName   fs) = mkVarOccUnique  fs-  getUnique (OccName DataName  fs) = mkDataOccUnique fs-  getUnique (OccName TvName    fs) = mkTvOccUnique   fs-  getUnique (OccName TcClsName fs) = mkTcOccUnique   fs--newtype OccEnv a = A (UniqFM a)-  deriving Data--emptyOccEnv :: OccEnv a-unitOccEnv  :: OccName -> a -> OccEnv a-extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a-extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a-lookupOccEnv :: OccEnv a -> OccName -> Maybe a-mkOccEnv     :: [(OccName,a)] -> OccEnv a-mkOccEnv_C   :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a-elemOccEnv   :: OccName -> OccEnv a -> Bool-foldOccEnv   :: (a -> b -> b) -> b -> OccEnv a -> b-occEnvElts   :: OccEnv a -> [a]-extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a-extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b-plusOccEnv     :: OccEnv a -> OccEnv a -> OccEnv a-plusOccEnv_C   :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a-mapOccEnv      :: (a->b) -> OccEnv a -> OccEnv b-delFromOccEnv      :: OccEnv a -> OccName -> OccEnv a-delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a-filterOccEnv       :: (elt -> Bool) -> OccEnv elt -> OccEnv elt-alterOccEnv        :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt--emptyOccEnv      = A emptyUFM-unitOccEnv x y = A $ unitUFM x y-extendOccEnv (A x) y z = A $ addToUFM x y z-extendOccEnvList (A x) l = A $ addListToUFM x l-lookupOccEnv (A x) y = lookupUFM x y-mkOccEnv     l    = A $ listToUFM l-elemOccEnv x (A y)       = elemUFM x y-foldOccEnv a b (A c)     = foldUFM a b c-occEnvElts (A x)         = eltsUFM x-plusOccEnv (A x) (A y)   = A $ plusUFM x y-plusOccEnv_C f (A x) (A y)       = A $ plusUFM_C f x y-extendOccEnv_C f (A x) y z   = A $ addToUFM_C f x y z-extendOccEnv_Acc f g (A x) y z   = A $ addToUFM_Acc f g x y z-mapOccEnv f (A x)        = A $ mapUFM f x-mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l-delFromOccEnv (A x) y    = A $ delFromUFM x y-delListFromOccEnv (A x) y  = A $ delListFromUFM x y-filterOccEnv x (A y)       = A $ filterUFM x y-alterOccEnv fn (A y) k     = A $ alterUFM fn y k--instance Outputable a => Outputable (OccEnv a) where-    ppr x = pprOccEnv ppr x--pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc-pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env--type OccSet = UniqSet OccName--emptyOccSet       :: OccSet-unitOccSet        :: OccName -> OccSet-mkOccSet          :: [OccName] -> OccSet-extendOccSet      :: OccSet -> OccName -> OccSet-extendOccSetList  :: OccSet -> [OccName] -> OccSet-unionOccSets      :: OccSet -> OccSet -> OccSet-unionManyOccSets  :: [OccSet] -> OccSet-minusOccSet       :: OccSet -> OccSet -> OccSet-elemOccSet        :: OccName -> OccSet -> Bool-isEmptyOccSet     :: OccSet -> Bool-intersectOccSet   :: OccSet -> OccSet -> OccSet-intersectsOccSet  :: OccSet -> OccSet -> Bool-filterOccSet      :: (OccName -> Bool) -> OccSet -> OccSet--emptyOccSet       = emptyUniqSet-unitOccSet        = unitUniqSet-mkOccSet          = mkUniqSet-extendOccSet      = addOneToUniqSet-extendOccSetList  = addListToUniqSet-unionOccSets      = unionUniqSets-unionManyOccSets  = unionManyUniqSets-minusOccSet       = minusUniqSet-elemOccSet        = elementOfUniqSet-isEmptyOccSet     = isEmptyUniqSet-intersectOccSet   = intersectUniqSets-intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2))-filterOccSet      = filterUniqSet--{--************************************************************************-*                                                                      *-\subsection{Predicates and taking them apart}-*                                                                      *-************************************************************************--}--occNameString :: OccName -> String-occNameString (OccName _ s) = unpackFS s--setOccNameSpace :: NameSpace -> OccName -> OccName-setOccNameSpace sp (OccName _ occ) = OccName sp occ--isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool--isVarOcc (OccName VarName _) = True-isVarOcc _                   = False--isTvOcc (OccName TvName _) = True-isTvOcc _                  = False--isTcOcc (OccName TcClsName _) = True-isTcOcc _                     = False---- | /Value/ 'OccNames's are those that are either in--- the variable or data constructor namespaces-isValOcc :: OccName -> Bool-isValOcc (OccName VarName  _) = True-isValOcc (OccName DataName _) = True-isValOcc _                    = False--isDataOcc (OccName DataName _) = True-isDataOcc _                    = False---- | Test if the 'OccName' is a data constructor that starts with--- a symbol (e.g. @:@, or @[]@)-isDataSymOcc :: OccName -> Bool-isDataSymOcc (OccName DataName s) = isLexConSym s-isDataSymOcc _                    = False--- Pretty inefficient!---- | Test if the 'OccName' is that for any operator (whether--- it is a data constructor or variable or whatever)-isSymOcc :: OccName -> Bool-isSymOcc (OccName DataName s)  = isLexConSym s-isSymOcc (OccName TcClsName s) = isLexSym s-isSymOcc (OccName VarName s)   = isLexSym s-isSymOcc (OccName TvName s)    = isLexSym s--- Pretty inefficient!--parenSymOcc :: OccName -> SDoc -> SDoc--- ^ Wrap parens around an operator-parenSymOcc occ doc | isSymOcc occ = parens doc-                    | otherwise    = doc--startsWithUnderscore :: OccName -> Bool--- ^ Haskell 98 encourages compilers to suppress warnings about unused--- names in a pattern if they start with @_@: this implements that test-startsWithUnderscore occ = headFS (occNameFS occ) == '_'--{--************************************************************************-*                                                                      *-\subsection{Making system names}-*                                                                      *-************************************************************************--Here's our convention for splitting up the interface file name space:--   d...         dictionary identifiers-                (local variables, so no name-clash worries)--All of these other OccNames contain a mixture of alphabetic-and symbolic characters, and hence cannot possibly clash with-a user-written type or function name--   $f...        Dict-fun identifiers (from inst decls)-   $dmop        Default method for 'op'-   $pnC         n'th superclass selector for class C-   $wf          Worker for function 'f'-   $sf..        Specialised version of f-   D:C          Data constructor for dictionary for class C-   NTCo:T       Coercion connecting newtype T with its representation type-   TFCo:R       Coercion connecting a data family to its representation type R--In encoded form these appear as Zdfxxx etc--        :...            keywords (export:, letrec: etc.)---- I THINK THIS IS WRONG!--This knowledge is encoded in the following functions.--@mk_deriv@ generates an @OccName@ from the prefix and a string.-NB: The string must already be encoded!--}---- | Build an 'OccName' derived from another 'OccName'.------ Note that the pieces of the name are passed in as a @[FastString]@ so that--- the whole name can be constructed with a single 'concatFS', minimizing--- unnecessary intermediate allocations.-mk_deriv :: NameSpace-         -> FastString      -- ^ A prefix which distinguishes one sort of-                            -- derived name from another-         -> [FastString]    -- ^ The name we are deriving from in pieces which-                            -- will be concatenated.-         -> OccName-mk_deriv occ_sp sys_prefix str =-    mkOccNameFS occ_sp (concatFS $ sys_prefix : str)--isDerivedOccName :: OccName -> Bool--- ^ Test for definitions internally generated by GHC.  This predicate--- is used to suppress printing of internal definitions in some debug prints-isDerivedOccName occ =-   case occNameString occ of-     '$':c:_ | isAlphaNum c -> True   -- E.g.  $wfoo-     c:':':_ | isAlphaNum c -> True   -- E.g.  N:blah   newtype coercions-     _other                 -> False--isDefaultMethodOcc :: OccName -> Bool-isDefaultMethodOcc occ =-   case occNameString occ of-     '$':'d':'m':_ -> True-     _ -> False---- | Is an 'OccName' one of a Typeable @TyCon@ or @Module@ binding?--- This is needed as these bindings are renamed differently.--- See Note [Grand plan for Typeable] in TcTypeable.-isTypeableBindOcc :: OccName -> Bool-isTypeableBindOcc occ =-   case occNameString occ of-     '$':'t':'c':_ -> True  -- mkTyConRepOcc-     '$':'t':'r':_ -> True  -- Module binding-     _ -> False--mkDataConWrapperOcc, mkWorkerOcc,-        mkMatcherOcc, mkBuilderOcc,-        mkDefaultMethodOcc,-        mkClassDataConOcc, mkDictOcc,-        mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc,-        mkGenR, mkGen1R,-        mkDataConWorkerOcc, mkNewTyCoOcc,-        mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,-        mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,-        mkTyConRepOcc-   :: OccName -> OccName---- These derived variables have a prefix that no Haskell value could have-mkDataConWrapperOcc = mk_simple_deriv varName  "$W"-mkWorkerOcc         = mk_simple_deriv varName  "$w"-mkMatcherOcc        = mk_simple_deriv varName  "$m"-mkBuilderOcc        = mk_simple_deriv varName  "$b"-mkDefaultMethodOcc  = mk_simple_deriv varName  "$dm"-mkClassOpAuxOcc     = mk_simple_deriv varName  "$c"-mkDictOcc           = mk_simple_deriv varName  "$d"-mkIPOcc             = mk_simple_deriv varName  "$i"-mkSpecOcc           = mk_simple_deriv varName  "$s"-mkForeignExportOcc  = mk_simple_deriv varName  "$f"-mkRepEqOcc          = mk_simple_deriv tvName   "$r"   -- In RULES involving Coercible-mkClassDataConOcc   = mk_simple_deriv dataName "C:"     -- Data con for a class-mkNewTyCoOcc        = mk_simple_deriv tcName   "N:"   -- Coercion for newtypes-mkInstTyCoOcc       = mk_simple_deriv tcName   "D:"   -- Coercion for type functions-mkEqPredCoOcc       = mk_simple_deriv tcName   "$co"---- Used in derived instances-mkCon2TagOcc        = mk_simple_deriv varName  "$con2tag_"-mkTag2ConOcc        = mk_simple_deriv varName  "$tag2con_"-mkMaxTagOcc         = mk_simple_deriv varName  "$maxtag_"---- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable-mkTyConRepOcc occ = mk_simple_deriv varName prefix occ-  where-    prefix | isDataOcc occ = "$tc'"-           | otherwise     = "$tc"---- Generic deriving mechanism-mkGenR   = mk_simple_deriv tcName "Rep_"-mkGen1R  = mk_simple_deriv tcName "Rep1_"---- Overloaded record field selectors-mkRecFldSelOcc :: String -> OccName-mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s]--mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName-mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ]---- Data constructor workers are made by setting the name space--- of the data constructor OccName (which should be a DataName)--- to VarName-mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ--mkSuperDictAuxOcc :: Int -> OccName -> OccName-mkSuperDictAuxOcc index cls_tc_occ-  = mk_deriv varName "$cp" [fsLit $ show index, occNameFS cls_tc_occ]--mkSuperDictSelOcc :: Int        -- ^ Index of superclass, e.g. 3-                  -> OccName    -- ^ Class, e.g. @Ord@-                  -> OccName    -- ^ Derived 'Occname', e.g. @$p3Ord@-mkSuperDictSelOcc index cls_tc_occ-  = mk_deriv varName "$p" [fsLit $ show index, occNameFS cls_tc_occ]--mkLocalOcc :: Unique            -- ^ Unique to combine with the 'OccName'-           -> OccName           -- ^ Local name, e.g. @sat@-           -> OccName           -- ^ Nice unique version, e.g. @$L23sat@-mkLocalOcc uniq occ-   = mk_deriv varName "$L" [fsLit $ show uniq, occNameFS occ]-        -- The Unique might print with characters-        -- that need encoding (e.g. 'z'!)---- | Derive a name for the representation type constructor of a--- @data@\/@newtype@ instance.-mkInstTyTcOcc :: String                 -- ^ Family name, e.g. @Map@-              -> OccSet                 -- ^ avoid these Occs-              -> OccName                -- ^ @R:Map@-mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str)--mkDFunOcc :: String             -- ^ Typically the class and type glommed together e.g. @OrdMaybe@.-                                -- Only used in debug mode, for extra clarity-          -> Bool               -- ^ Is this a hs-boot instance DFun?-          -> OccSet             -- ^ avoid these Occs-          -> OccName            -- ^ E.g. @$f3OrdMaybe@---- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real--- thing when we compile the mother module. Reason: we don't know exactly--- what the  mother module will call it.--mkDFunOcc info_str is_boot set-  = chooseUniqueOcc VarName (prefix ++ info_str) set-  where-    prefix | is_boot   = "$fx"-           | otherwise = "$f"--mkDataTOcc, mkDataCOcc-  :: OccName            -- ^ TyCon or data con string-  -> OccSet             -- ^ avoid these Occs-  -> OccName            -- ^ E.g. @$f3OrdMaybe@--- data T = MkT ... deriving( Data ) needs definitions for---      $tT   :: Data.Generics.Basics.DataType---      $cMkT :: Data.Generics.Basics.Constr-mkDataTOcc occ = chooseUniqueOcc VarName ("$t" ++ occNameString occ)-mkDataCOcc occ = chooseUniqueOcc VarName ("$c" ++ occNameString occ)--{--Sometimes we need to pick an OccName that has not already been used,-given a set of in-use OccNames.--}--chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName-chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int)-  where-  loop occ n-   | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1)-   | otherwise            = occ--{--We used to add a '$m' to indicate a method, but that gives rise to bad-error messages from the type checker when we print the function name or pattern-of an instance-decl binding.  Why? Because the binding is zapped-to use the method name in place of the selector name.-(See TcClassDcl.tcMethodBind)--The way it is now, -ddump-xx output may look confusing, but-you can always say -dppr-debug to get the uniques.--However, we *do* have to zap the first character to be lower case,-because overloaded constructors (blarg) generate methods too.-And convert to VarName space--e.g. a call to constructor MkFoo where-        data (Ord a) => Foo a = MkFoo a--If this is necessary, we do it by prefixing '$m'.  These-guys never show up in error messages.  What a hack.--}--mkMethodOcc :: OccName -> OccName-mkMethodOcc occ@(OccName VarName _) = occ-mkMethodOcc occ                     = mk_simple_deriv varName "$m" occ--{--************************************************************************-*                                                                      *-\subsection{Tidying them up}-*                                                                      *-************************************************************************--Before we print chunks of code we like to rename it so that-we don't have to print lots of silly uniques in it.  But we mustn't-accidentally introduce name clashes!  So the idea is that we leave the-OccName alone unless it accidentally clashes with one that is already-in scope; if so, we tack on '1' at the end and try again, then '2', and-so on till we find a unique one.--There's a wrinkle for operators.  Consider '>>='.  We can't use '>>=1'-because that isn't a single lexeme.  So we encode it to 'lle' and *then*-tack on the '1', if necessary.--Note [TidyOccEnv]-~~~~~~~~~~~~~~~~~-type TidyOccEnv = UniqFM Int--* Domain = The OccName's FastString. These FastStrings are "taken";-           make sure that we don't re-use--* Int, n = A plausible starting point for new guesses-           There is no guarantee that "FSn" is available;-           you must look that up in the TidyOccEnv.  But-           it's a good place to start looking.--* When looking for a renaming for "foo2" we strip off the "2" and start-  with "foo".  Otherwise if we tidy twice we get silly names like foo23.--  However, if it started with digits at the end, we always make a name-  with digits at the end, rather than shortening "foo2" to just "foo",-  even if "foo" is unused.  Reasons:-     - Plain "foo" might be used later-     - We use trailing digits to subtly indicate a unification variable-       in typechecker error message; see TypeRep.tidyTyVarBndr--We have to take care though! Consider a machine-generated module (#10370)-  module Foo where-     a1 = e1-     a2 = e2-     ...-     a2000 = e2000-Then "a1", "a2" etc are all marked taken.  But now if we come across "a7" again,-we have to do a linear search to find a free one, "a2001".  That might just be-acceptable once.  But if we now come across "a8" again, we don't want to repeat-that search.--So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for-starting the search; and we make sure to update the starting point for "a"-after we allocate a new one.---Note [Tidying multiple names at once]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Consider--    > :t (id,id,id)--Every id contributes a type variable to the type signature, and all of them are-"a". If we tidy them one by one, we get--    (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a)--which is a bit unfortunate, as it unfairly renames only two of them. What we-would like to see is--    (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1)--To achieve this, the function avoidClashesOccEnv can be used to prepare the-TidyEnv, by “blocking” every name that occurs twice in the map. This way, none-of the "a"s will get the privilege of keeping this name, and all of them will-get a suitable number by tidyOccName.--This prepared TidyEnv can then be used with tidyOccName. See tidyTyCoVarBndrs-for an example where this is used.--This is #12382.---}--type TidyOccEnv = UniqFM Int    -- The in-scope OccNames-  -- See Note [TidyOccEnv]--emptyTidyOccEnv :: TidyOccEnv-emptyTidyOccEnv = emptyUFM--initTidyOccEnv :: [OccName] -> TidyOccEnv       -- Initialise with names to avoid!-initTidyOccEnv = foldl' add emptyUFM-  where-    add env (OccName _ fs) = addToUFM env fs 1--delTidyOccEnvList :: TidyOccEnv -> [FastString] -> TidyOccEnv-delTidyOccEnvList = delListFromUFM---- see Note [Tidying multiple names at once]-avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv-avoidClashesOccEnv env occs = go env emptyUFM occs-  where-    go env _        [] = env-    go env seenOnce ((OccName _ fs):occs)-      | fs `elemUFM` env      = go env seenOnce                  occs-      | fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce  occs-      | otherwise             = go env (addToUFM seenOnce fs ()) occs--tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)-tidyOccName env occ@(OccName occ_sp fs)-  | not (fs `elemUFM` env)-  = -- Desired OccName is free, so use it,-    -- and record in 'env' that it's no longer available-    (addToUFM env fs 1, occ)--  | otherwise-  = case lookupUFM env base1 of-       Nothing -> (addToUFM env base1 2, OccName occ_sp base1)-       Just n  -> find 1 n-  where-    base :: String  -- Drop trailing digits (see Note [TidyOccEnv])-    base  = dropWhileEndLE isDigit (unpackFS fs)-    base1 = mkFastString (base ++ "1")--    find !k !n-      = case lookupUFM env new_fs of-          Just {} -> find (k+1 :: Int) (n+k)-                       -- By using n+k, the n argument to find goes-                       --    1, add 1, add 2, add 3, etc which-                       -- moves at quadratic speed through a dense patch--          Nothing -> (new_env, OccName occ_sp new_fs)-       where-         new_fs = mkFastString (base ++ show n)-         new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1)-                     -- Update:  base1,  so that next time we'll start where we left off-                     --          new_fs, so that we know it is taken-                     -- If they are the same (n==1), the former wins-                     -- See Note [TidyOccEnv]---{--************************************************************************-*                                                                      *-                Binary instance-    Here rather than in GHC.Iface.Binary because OccName is abstract-*                                                                      *-************************************************************************--}--instance Binary NameSpace where-    put_ bh VarName = do-            putByte bh 0-    put_ bh DataName = do-            putByte bh 1-    put_ bh TvName = do-            putByte bh 2-    put_ bh TcClsName = do-            putByte bh 3-    get bh = do-            h <- getByte bh-            case h of-              0 -> do return VarName-              1 -> do return DataName-              2 -> do return TvName-              _ -> do return TcClsName--instance Binary OccName where-    put_ bh (OccName aa ab) = do-            put_ bh aa-            put_ bh ab-    get bh = do-          aa <- get bh-          ab <- get bh-          return (OccName aa ab)
− compiler/basicTypes/OccName.hs-boot 
@@ -1,5 +0,0 @@-module OccName where--import GhcPrelude ()--data OccName
− compiler/basicTypes/PatSyn.hs 
@@ -1,484 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1998--\section[PatSyn]{@PatSyn@: Pattern synonyms}--}--{-# LANGUAGE CPP #-}--module PatSyn (-        -- * Main data types-        PatSyn, mkPatSyn,--        -- ** Type deconstruction-        patSynName, patSynArity, patSynIsInfix,-        patSynArgs,-        patSynMatcher, patSynBuilder,-        patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig,-        patSynInstArgTys, patSynInstResTy, patSynFieldLabels,-        patSynFieldType,--        updatePatSynIds, pprPatSynType-    ) where--#include "HsVersions.h"--import GhcPrelude--import Type-import TyCoPpr-import Name-import Outputable-import Unique-import Util-import BasicTypes-import Var-import FieldLabel--import qualified Data.Data as Data-import Data.Function-import Data.List (find)--{--************************************************************************-*                                                                      *-\subsection{Pattern synonyms}-*                                                                      *-************************************************************************--}---- | Pattern Synonym------ See Note [Pattern synonym representation]--- See Note [Pattern synonym signature contexts]-data PatSyn-  = MkPatSyn {-        psName        :: Name,-        psUnique      :: Unique,       -- Cached from Name--        psArgs        :: [Type],-        psArity       :: Arity,        -- == length psArgs-        psInfix       :: Bool,         -- True <=> declared infix-        psFieldLabels :: [FieldLabel], -- List of fields for a-                                       -- record pattern synonym-                                       -- INVARIANT: either empty if no-                                       -- record pat syn or same length as-                                       -- psArgs--        -- Universally-quantified type variables-        psUnivTyVars  :: [TyVarBinder],--        -- Required dictionaries (may mention psUnivTyVars)-        psReqTheta    :: ThetaType,--        -- Existentially-quantified type vars-        psExTyVars    :: [TyVarBinder],--        -- Provided dictionaries (may mention psUnivTyVars or psExTyVars)-        psProvTheta   :: ThetaType,--        -- Result type-        psResultTy   :: Type,  -- Mentions only psUnivTyVars-                               -- See Note [Pattern synonym result type]--        -- See Note [Matchers and builders for pattern synonyms]-        psMatcher     :: (Id, Bool),-             -- Matcher function.-             -- If Bool is True then prov_theta and arg_tys are empty-             -- and type is-             --   forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs.-             --                          req_theta-             --                       => res_ty-             --                       -> (forall ex_tvs. Void# -> r)-             --                       -> (Void# -> r)-             --                       -> r-             ---             -- Otherwise type is-             --   forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs.-             --                          req_theta-             --                       => res_ty-             --                       -> (forall ex_tvs. prov_theta => arg_tys -> r)-             --                       -> (Void# -> r)-             --                       -> r--        psBuilder     :: Maybe (Id, Bool)-             -- Nothing  => uni-directional pattern synonym-             -- Just (builder, is_unlifted) => bi-directional-             -- Builder function, of type-             --  forall univ_tvs, ex_tvs. (req_theta, prov_theta)-             --                       =>  arg_tys -> res_ty-             -- See Note [Builder for pattern synonyms with unboxed type]-  }--{- Note [Pattern synonym signature contexts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In a pattern synonym signature we write-   pattern P :: req => prov => t1 -> ... tn -> res_ty--Note that the "required" context comes first, then the "provided"-context.  Moreover, the "required" context must not mention-existentially-bound type variables; that is, ones not mentioned in-res_ty.  See lots of discussion in #10928.--If there is no "provided" context, you can omit it; but you-can't omit the "required" part (unless you omit both).--Example 1:-      pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b)-      pattern P1 x = Just (3,x)--  We require (Num a, Eq a) to match the 3; there is no provided-  context.--Example 2:-      data T2 where-        MkT2 :: (Num a, Eq a) => a -> a -> T2--      pattern P2 :: () => (Num a, Eq a) => a -> T2-      pattern P2 x = MkT2 3 x--  When we match against P2 we get a Num dictionary provided.-  We can use that to check the match against 3.--Example 3:-      pattern P3 :: Eq a => a -> b -> T3 b--   This signature is illegal because the (Eq a) is a required-   constraint, but it mentions the existentially-bound variable 'a'.-   You can see it's existential because it doesn't appear in the-   result type (T3 b).--Note [Pattern synonym result type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   data T a b = MkT b a--   pattern P :: a -> T [a] Bool-   pattern P x = MkT True [x]--P's psResultTy is (T a Bool), and it really only matches values of-type (T [a] Bool).  For example, this is ill-typed--   f :: T p q -> String-   f (P x) = "urk"--This is different to the situation with GADTs:--   data S a where-     MkS :: Int -> S Bool--Now MkS (and pattern synonyms coming from MkS) can match a-value of type (S a), not just (S Bool); we get type refinement.--That in turn means that if you have a pattern--   P x :: T [ty] Bool--it's not entirely straightforward to work out the instantiation of-P's universal tyvars. You have to /match/-  the type of the pattern, (T [ty] Bool)-against-  the psResultTy for the pattern synonym, T [a] Bool-to get the instantiation a := ty.--This is very unlike DataCons, where univ tyvars match 1-1 the-arguments of the TyCon.--Side note: I (SG) get the impression that instantiated return types should-generate a *required* constraint for pattern synonyms, rather than a *provided*-constraint like it's the case for GADTs. For example, I'd expect these-declarations to have identical semantics:--    pattern Just42 :: Maybe Int-    pattern Just42 = Just 42--    pattern Just'42 :: (a ~ Int) => Maybe a-    pattern Just'42 = Just 42--The latter generates the proper required constraint, the former does not.-Also rather different to GADTs is the fact that Just42 doesn't have any-universally quantified type variables, whereas Just'42 or MkS above has.--Note [Pattern synonym representation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the following pattern synonym declaration--        pattern P x = MkT [x] (Just 42)--where-        data T a where-              MkT :: (Show a, Ord b) => [b] -> a -> T a--so pattern P has type--        b -> T (Maybe t)--with the following typeclass constraints:--        requires: (Eq t, Num t)-        provides: (Show (Maybe t), Ord b)--In this case, the fields of MkPatSyn will be set as follows:--  psArgs       = [b]-  psArity      = 1-  psInfix      = False--  psUnivTyVars = [t]-  psExTyVars   = [b]-  psProvTheta  = (Show (Maybe t), Ord b)-  psReqTheta   = (Eq t, Num t)-  psResultTy  = T (Maybe t)--Note [Matchers and builders for pattern synonyms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For each pattern synonym P, we generate--  * a "matcher" function, used to desugar uses of P in patterns,-    which implements pattern matching--  * A "builder" function (for bidirectional pattern synonyms only),-    used to desugar uses of P in expressions, which constructs P-values.--For the above example, the matcher function has type:--        $mP :: forall (r :: ?) t. (Eq t, Num t)-            => T (Maybe t)-            -> (forall b. (Show (Maybe t), Ord b) => b -> r)-            -> (Void# -> r)-            -> r--with the following implementation:--        $mP @r @t $dEq $dNum scrut cont fail-          = case scrut of-              MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x-              _                                 -> fail Void#--Notice that the return type 'r' has an open kind, so that it can-be instantiated by an unboxed type; for example where we see-     f (P x) = 3#--The extra Void# argument for the failure continuation is needed so that-it is lazy even when the result type is unboxed.--For the same reason, if the pattern has no arguments, an extra Void#-argument is added to the success continuation as well.--For *bidirectional* pattern synonyms, we also generate a "builder"-function which implements the pattern synonym in an expression-context. For our running example, it will be:--        $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b)-            => b -> T (Maybe t)-        $bP x = MkT [x] (Just 42)--NB: the existential/universal and required/provided split does not-apply to the builder since you are only putting stuff in, not getting-stuff out.--Injectivity of bidirectional pattern synonyms is checked in-tcPatToExpr which walks the pattern and returns its corresponding-expression when available.--Note [Builder for pattern synonyms with unboxed type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For bidirectional pattern synonyms that have no arguments and have an-unboxed type, we add an extra Void# argument to the builder, else it-would be a top-level declaration with an unboxed type.--        pattern P = 0#--        $bP :: Void# -> Int#-        $bP _ = 0#--This means that when typechecking an occurrence of P in an expression,-we must remember that the builder has this void argument. This is-done by TcPatSyn.patSynBuilderOcc.--Note [Pattern synonyms and the data type Type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The type of a pattern synonym is of the form (See Note-[Pattern synonym signatures] in TcSigs):--    forall univ_tvs. req => forall ex_tvs. prov => ...--We cannot in general represent this by a value of type Type:-- - if ex_tvs is empty, then req and prov cannot be distinguished from-   each other- - if req is empty, then univ_tvs and ex_tvs cannot be distinguished-   from each other, and moreover, prov is seen as the "required" context-   (as it is the only context)---************************************************************************-*                                                                      *-\subsection{Instances}-*                                                                      *-************************************************************************--}--instance Eq PatSyn where-    (==) = (==) `on` getUnique-    (/=) = (/=) `on` getUnique--instance Uniquable PatSyn where-    getUnique = psUnique--instance NamedThing PatSyn where-    getName = patSynName--instance Outputable PatSyn where-    ppr = ppr . getName--instance OutputableBndr PatSyn where-    pprInfixOcc = pprInfixName . getName-    pprPrefixOcc = pprPrefixName . getName--instance Data.Data PatSyn where-    -- don't traverse?-    toConstr _   = abstractConstr "PatSyn"-    gunfold _ _  = error "gunfold"-    dataTypeOf _ = mkNoRepType "PatSyn"--{--************************************************************************-*                                                                      *-\subsection{Construction}-*                                                                      *-************************************************************************--}---- | Build a new pattern synonym-mkPatSyn :: Name-         -> Bool                 -- ^ Is the pattern synonym declared infix?-         -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type-                                       -- variables and required dicts-         -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type-                                       -- variables and provided dicts-         -> [Type]               -- ^ Original arguments-         -> Type                 -- ^ Original result type-         -> (Id, Bool)           -- ^ Name of matcher-         -> Maybe (Id, Bool)     -- ^ Name of builder-         -> [FieldLabel]         -- ^ Names of fields for-                                 --   a record pattern synonym-         -> PatSyn- -- NB: The univ and ex vars are both in TyBinder form and TyVar form for- -- convenience. All the TyBinders should be Named!-mkPatSyn name declared_infix-         (univ_tvs, req_theta)-         (ex_tvs, prov_theta)-         orig_args-         orig_res_ty-         matcher builder field_labels-    = MkPatSyn {psName = name, psUnique = getUnique name,-                psUnivTyVars = univ_tvs,-                psExTyVars = ex_tvs,-                psProvTheta = prov_theta, psReqTheta = req_theta,-                psInfix = declared_infix,-                psArgs = orig_args,-                psArity = length orig_args,-                psResultTy = orig_res_ty,-                psMatcher = matcher,-                psBuilder = builder,-                psFieldLabels = field_labels-                }---- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification-patSynName :: PatSyn -> Name-patSynName = psName---- | Should the 'PatSyn' be presented infix?-patSynIsInfix :: PatSyn -> Bool-patSynIsInfix = psInfix---- | Arity of the pattern synonym-patSynArity :: PatSyn -> Arity-patSynArity = psArity--patSynArgs :: PatSyn -> [Type]-patSynArgs = psArgs--patSynFieldLabels :: PatSyn -> [FieldLabel]-patSynFieldLabels = psFieldLabels---- | Extract the type for any given labelled field of the 'DataCon'-patSynFieldType :: PatSyn -> FieldLabelString -> Type-patSynFieldType ps label-  = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of-      Just (_, ty) -> ty-      Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label)--patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder]-patSynUnivTyVarBinders = psUnivTyVars--patSynExTyVars :: PatSyn -> [TyVar]-patSynExTyVars ps = binderVars (psExTyVars ps)--patSynExTyVarBinders :: PatSyn -> [TyVarBinder]-patSynExTyVarBinders = psExTyVars--patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)-patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs-                    , psProvTheta = prov, psReqTheta = req-                    , psArgs = arg_tys, psResultTy = res_ty })-  = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty)--patSynMatcher :: PatSyn -> (Id,Bool)-patSynMatcher = psMatcher--patSynBuilder :: PatSyn -> Maybe (Id, Bool)-patSynBuilder = psBuilder--updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn-updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })-  = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }-  where-    tidy_pr (id, dummy) = (tidy_fn id, dummy)--patSynInstArgTys :: PatSyn -> [Type] -> [Type]--- Return the types of the argument patterns--- e.g.  data D a = forall b. MkD a b (b->a)---       pattern P f x y = MkD (x,True) y f---          D :: forall a. forall b. a -> b -> (b->a) -> D a---          P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c---   patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]--- NB: the inst_tys should be both universal and existential-patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs-                           , psExTyVars = ex_tvs, psArgs = arg_tys })-                 inst_tys-  = ASSERT2( tyvars `equalLength` inst_tys-          , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys )-    map (substTyWith tyvars inst_tys) arg_tys-  where-    tyvars = binderVars (univ_tvs ++ ex_tvs)--patSynInstResTy :: PatSyn -> [Type] -> Type--- Return the type of whole pattern--- E.g.  pattern P x y = Just (x,x,y)---         P :: a -> b -> Just (a,a,b)---         (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)--- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars-patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs-                          , psResultTy = res_ty })-                inst_tys-  = ASSERT2( univ_tvs `equalLength` inst_tys-           , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )-    substTyWith (binderVars univ_tvs) inst_tys res_ty---- | Print the type of a pattern synonym. The foralls are printed explicitly-pprPatSynType :: PatSyn -> SDoc-pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs,  psReqTheta  = req_theta-                        , psExTyVars   = ex_tvs,    psProvTheta = prov_theta-                        , psArgs       = orig_args, psResultTy = orig_res_ty })-  = sep [ pprForAll univ_tvs-        , pprThetaArrowTy req_theta-        , ppWhen insert_empty_ctxt $ parens empty <+> darrow-        , pprType sigma_ty ]-  where-    sigma_ty = mkForAllTys ex_tvs  $-               mkInvisFunTys prov_theta $-               mkVisFunTys orig_args orig_res_ty-    insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs)
− compiler/basicTypes/PatSyn.hs-boot 
@@ -1,13 +0,0 @@-module PatSyn where--import BasicTypes (Arity)-import {-# SOURCE #-} TyCoRep (Type)-import Var (TyVar)-import Name (Name)--data PatSyn--patSynArity :: PatSyn -> Arity-patSynInstArgTys :: PatSyn -> [Type] -> [Type]-patSynExTyVars :: PatSyn -> [TyVar]-patSynName :: PatSyn -> Name
− compiler/basicTypes/Predicate.hs 
@@ -1,228 +0,0 @@-{---Describes predicates as they are considered by the solver.---}--module Predicate (-  Pred(..), classifyPredType,-  isPredTy, isEvVarType,--  -- Equality predicates-  EqRel(..), eqRelRole,-  isEqPrimPred, isEqPred,-  getEqPredTys, getEqPredTys_maybe, getEqPredRole,-  predTypeEqRel,-  mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,-  mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,--  -- Class predicates-  mkClassPred, isDictTy,-  isClassPred, isEqPredClass, isCTupleClass,-  getClassPredTys, getClassPredTys_maybe,--  -- Implicit parameters-  isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, hasIPPred,--  -- Evidence variables-  DictId, isEvVar, isDictId-  ) where--import GhcPrelude--import Type-import Class-import TyCon-import Var-import Coercion--import PrelNames--import FastString-import Outputable-import Util--import Control.Monad ( guard )---- | A predicate in the solver. The solver tries to prove Wanted predicates--- from Given ones.-data Pred-  = ClassPred Class [Type]-  | EqPred EqRel Type Type-  | IrredPred PredType-  | ForAllPred [TyVar] [PredType] PredType-     -- ForAllPred: see Note [Quantified constraints] in TcCanonical-  -- NB: There is no TuplePred case-  --     Tuple predicates like (Eq a, Ord b) are just treated-  --     as ClassPred, as if we had a tuple class with two superclasses-  --        class (c1, c2) => (%,%) c1 c2--classifyPredType :: PredType -> Pred-classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of-    Just (tc, [_, _, ty1, ty2])-      | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2-      | tc `hasKey` eqPrimTyConKey     -> EqPred NomEq ty1 ty2--    Just (tc, tys)-      | Just clas <- tyConClass_maybe tc-      -> ClassPred clas tys--    _ | (tvs, rho) <- splitForAllTys ev_ty-      , (theta, pred) <- splitFunTys rho-      , not (null tvs && null theta)-      -> ForAllPred tvs theta pred--      | otherwise-      -> IrredPred ev_ty---- --------------------- Dictionary types -----------------------------------mkClassPred :: Class -> [Type] -> PredType-mkClassPred clas tys = mkTyConApp (classTyCon clas) tys--isDictTy :: Type -> Bool-isDictTy = isClassPred--getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type])-getClassPredTys ty = case getClassPredTys_maybe ty of-        Just (clas, tys) -> (clas, tys)-        Nothing          -> pprPanic "getClassPredTys" (ppr ty)--getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])-getClassPredTys_maybe ty = case splitTyConApp_maybe ty of-        Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys)-        _ -> Nothing---- --------------------- Equality predicates ------------------------------------- | A choice of equality relation. This is separate from the type 'Role'--- because 'Phantom' does not define a (non-trivial) equality relation.-data EqRel = NomEq | ReprEq-  deriving (Eq, Ord)--instance Outputable EqRel where-  ppr NomEq  = text "nominal equality"-  ppr ReprEq = text "representational equality"--eqRelRole :: EqRel -> Role-eqRelRole NomEq  = Nominal-eqRelRole ReprEq = Representational--getEqPredTys :: PredType -> (Type, Type)-getEqPredTys ty-  = case splitTyConApp_maybe ty of-      Just (tc, [_, _, ty1, ty2])-        |  tc `hasKey` eqPrimTyConKey-        || tc `hasKey` eqReprPrimTyConKey-        -> (ty1, ty2)-      _ -> pprPanic "getEqPredTys" (ppr ty)--getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type)-getEqPredTys_maybe ty-  = case splitTyConApp_maybe ty of-      Just (tc, [_, _, ty1, ty2])-        | tc `hasKey` eqPrimTyConKey     -> Just (Nominal, ty1, ty2)-        | tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2)-      _ -> Nothing--getEqPredRole :: PredType -> Role-getEqPredRole ty = eqRelRole (predTypeEqRel ty)---- | Get the equality relation relevant for a pred type.-predTypeEqRel :: PredType -> EqRel-predTypeEqRel ty-  | Just (tc, _) <- splitTyConApp_maybe ty-  , tc `hasKey` eqReprPrimTyConKey-  = ReprEq-  | otherwise-  = NomEq--{--------------------------------------------Predicates on PredType---------------------------------------------}--{--Note [Evidence for quantified constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The superclass mechanism in TcCanonical.makeSuperClasses risks-taking a quantified constraint like-   (forall a. C a => a ~ b)-and generate superclass evidence-   (forall a. C a => a ~# b)--This is a funny thing: neither isPredTy nor isCoVarType are true-of it.  So we are careful not to generate it in the first place:-see Note [Equality superclasses in quantified constraints]-in TcCanonical.--}--isEvVarType :: Type -> Bool--- True of (a) predicates, of kind Constraint, such as (Eq a), and (a ~ b)---         (b) coercion types, such as (t1 ~# t2) or (t1 ~R# t2)--- See Note [Types for coercions, predicates, and evidence] in TyCoRep--- See Note [Evidence for quantified constraints]-isEvVarType ty = isCoVarType ty || isPredTy ty--isEqPredClass :: Class -> Bool--- True of (~) and (~~)-isEqPredClass cls =  cls `hasKey` eqTyConKey-                  || cls `hasKey` heqTyConKey--isClassPred, isEqPred, isEqPrimPred, isIPPred :: PredType -> Bool-isClassPred ty = case tyConAppTyCon_maybe ty of-    Just tyCon | isClassTyCon tyCon -> True-    _                               -> False--isEqPred ty  -- True of (a ~ b) and (a ~~ b)-             -- ToDo: should we check saturation?-  | Just tc <- tyConAppTyCon_maybe ty-  , Just cls <- tyConClass_maybe tc-  = isEqPredClass cls-  | otherwise-  = False--isEqPrimPred ty = isCoVarType ty-  -- True of (a ~# b) (a ~R# b)--isIPPred ty = case tyConAppTyCon_maybe ty of-    Just tc -> isIPTyCon tc-    _       -> False--isIPTyCon :: TyCon -> Bool-isIPTyCon tc = tc `hasKey` ipClassKey-  -- Class and its corresponding TyCon have the same Unique--isIPClass :: Class -> Bool-isIPClass cls = cls `hasKey` ipClassKey--isCTupleClass :: Class -> Bool-isCTupleClass cls = isTupleTyCon (classTyCon cls)--isIPPred_maybe :: Type -> Maybe (FastString, Type)-isIPPred_maybe ty =-  do (tc,[t1,t2]) <- splitTyConApp_maybe ty-     guard (isIPTyCon tc)-     x <- isStrLitTy t1-     return (x,t2)--hasIPPred :: PredType -> Bool-hasIPPred pred-  = case classifyPredType pred of-      ClassPred cls tys-        | isIPClass     cls -> True-        | isCTupleClass cls -> any hasIPPred tys-      _other -> False--{--************************************************************************-*                                                                      *-              Evidence variables-*                                                                      *-************************************************************************--}--isEvVar :: Var -> Bool-isEvVar var = isEvVarType (varType var)--isDictId :: Id -> Bool-isDictId id = isDictTy (varType id)
− compiler/basicTypes/RdrName.hs 
@@ -1,1387 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}--{-# LANGUAGE CPP, DeriveDataTypeable #-}---- |--- #name_types#--- GHC uses several kinds of name internally:------ * 'OccName.OccName': see "OccName#name_types"------ * 'RdrName.RdrName' is the type of names that come directly from the parser. They---   have not yet had their scoping and binding resolved by the renamer and can be---   thought of to a first approximation as an 'OccName.OccName' with an optional module---   qualifier------ * 'Name.Name': see "Name#name_types"------ * 'Id.Id': see "Id#name_types"------ * 'Var.Var': see "Var#name_types"--module RdrName (-        -- * The main type-        RdrName(..),    -- Constructors exported only to GHC.Iface.Binary--        -- ** Construction-        mkRdrUnqual, mkRdrQual,-        mkUnqual, mkVarUnqual, mkQual, mkOrig,-        nameRdrName, getRdrName,--        -- ** Destruction-        rdrNameOcc, rdrNameSpace, demoteRdrName,-        isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual,-        isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,--        -- * Local mapping of 'RdrName' to 'Name.Name'-        LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,-        lookupLocalRdrEnv, lookupLocalRdrOcc,-        elemLocalRdrEnv, inLocalRdrEnvScope,-        localRdrEnvElts, delLocalRdrEnvList,--        -- * Global mapping of 'RdrName' to 'GlobalRdrElt's-        GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,-        lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,-        pprGlobalRdrEnv, globalRdrEnvElts,-        lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel,-        lookupGRE_Name_OccName,-        getGRE_NameQualifier_maybes,-        transformGREs, pickGREs, pickGREsModExp,--        -- * GlobalRdrElts-        gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE,-        greRdrNames, greSrcSpan, greQualModName,-        gresToAvailInfo,--        -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'-        GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel,-        unQualOK, qualSpecOK, unQualSpecOK,-        pprNameProvenance,-        Parent(..), greParent_maybe,-        ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),-        importSpecLoc, importSpecModule, isExplicitItem, bestImport,--        -- * Utils for StarIsType-        starInfo-  ) where--#include "HsVersions.h"--import GhcPrelude--import Module-import Name-import Avail-import NameSet-import Maybes-import SrcLoc-import FastString-import FieldLabel-import Outputable-import Unique-import UniqFM-import UniqSet-import Util-import NameEnv--import Data.Data-import Data.List( sortBy )--{--************************************************************************-*                                                                      *-\subsection{The main data type}-*                                                                      *-************************************************************************--}---- | Reader Name------ Do not use the data constructors of RdrName directly: prefer the family--- of functions that creates them, such as 'mkRdrUnqual'------ - Note: A Located RdrName will only have API Annotations if it is a---         compound one,---   e.g.------ > `bar`--- > ( ~ )------ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',---           'ApiAnnotation.AnnOpen'  @'('@ or @'['@ or @'[:'@,---           'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,,---           'ApiAnnotation.AnnBackquote' @'`'@,---           'ApiAnnotation.AnnVal'---           'ApiAnnotation.AnnTilde',---- For details on above see note [Api annotations] in ApiAnnotation-data RdrName-  = Unqual OccName-        -- ^ Unqualified  name-        ---        -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.-        -- Create such a 'RdrName' with 'mkRdrUnqual'--  | Qual ModuleName OccName-        -- ^ Qualified name-        ---        -- A qualified name written by the user in-        -- /source/ code.  The module isn't necessarily-        -- the module where the thing is defined;-        -- just the one from which it is imported.-        -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@.-        -- Create such a 'RdrName' with 'mkRdrQual'--  | Orig Module OccName-        -- ^ Original name-        ---        -- An original name; the module is the /defining/ module.-        -- This is used when GHC generates code that will be fed-        -- into the renamer (e.g. from deriving clauses), but where-        -- we want to say \"Use Prelude.map dammit\". One of these-        -- can be created with 'mkOrig'--  | Exact Name-        -- ^ Exact name-        ---        -- We know exactly the 'Name'. This is used:-        ---        --  (1) When the parser parses built-in syntax like @[]@-        --      and @(,)@, but wants a 'RdrName' from it-        ---        --  (2) By Template Haskell, when TH has generated a unique name-        ---        -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name'-  deriving Data--{--************************************************************************-*                                                                      *-\subsection{Simple functions}-*                                                                      *-************************************************************************--}--instance HasOccName RdrName where-  occName = rdrNameOcc--rdrNameOcc :: RdrName -> OccName-rdrNameOcc (Qual _ occ) = occ-rdrNameOcc (Unqual occ) = occ-rdrNameOcc (Orig _ occ) = occ-rdrNameOcc (Exact name) = nameOccName name--rdrNameSpace :: RdrName -> NameSpace-rdrNameSpace = occNameSpace . rdrNameOcc---- demoteRdrName lowers the NameSpace of RdrName.--- see Note [Demotion] in OccName-demoteRdrName :: RdrName -> Maybe RdrName-demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ)-demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ)-demoteRdrName (Orig _ _) = panic "demoteRdrName"-demoteRdrName (Exact _) = panic "demoteRdrName"--        -- These two are the basic constructors-mkRdrUnqual :: OccName -> RdrName-mkRdrUnqual occ = Unqual occ--mkRdrQual :: ModuleName -> OccName -> RdrName-mkRdrQual mod occ = Qual mod occ--mkOrig :: Module -> OccName -> RdrName-mkOrig mod occ = Orig mod occ------------------        -- These two are used when parsing source files-        -- They do encode the module and occurrence names-mkUnqual :: NameSpace -> FastString -> RdrName-mkUnqual sp n = Unqual (mkOccNameFS sp n)--mkVarUnqual :: FastString -> RdrName-mkVarUnqual n = Unqual (mkVarOccFS n)---- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and--- the 'OccName' are taken from the first and second elements of the tuple respectively-mkQual :: NameSpace -> (FastString, FastString) -> RdrName-mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n)--getRdrName :: NamedThing thing => thing -> RdrName-getRdrName name = nameRdrName (getName name)--nameRdrName :: Name -> RdrName-nameRdrName name = Exact name--- Keep the Name even for Internal names, so that the--- unique is still there for debug printing, particularly--- of Types (which are converted to IfaceTypes before printing)--nukeExact :: Name -> RdrName-nukeExact n-  | isExternalName n = Orig (nameModule n) (nameOccName n)-  | otherwise        = Unqual (nameOccName n)--isRdrDataCon :: RdrName -> Bool-isRdrTyVar   :: RdrName -> Bool-isRdrTc      :: RdrName -> Bool--isRdrDataCon rn = isDataOcc (rdrNameOcc rn)-isRdrTyVar   rn = isTvOcc   (rdrNameOcc rn)-isRdrTc      rn = isTcOcc   (rdrNameOcc rn)--isSrcRdrName :: RdrName -> Bool-isSrcRdrName (Unqual _) = True-isSrcRdrName (Qual _ _) = True-isSrcRdrName _          = False--isUnqual :: RdrName -> Bool-isUnqual (Unqual _) = True-isUnqual _          = False--isQual :: RdrName -> Bool-isQual (Qual _ _) = True-isQual _          = False--isQual_maybe :: RdrName -> Maybe (ModuleName, OccName)-isQual_maybe (Qual m n) = Just (m,n)-isQual_maybe _          = Nothing--isOrig :: RdrName -> Bool-isOrig (Orig _ _) = True-isOrig _          = False--isOrig_maybe :: RdrName -> Maybe (Module, OccName)-isOrig_maybe (Orig m n) = Just (m,n)-isOrig_maybe _          = Nothing--isExact :: RdrName -> Bool-isExact (Exact _) = True-isExact _         = False--isExact_maybe :: RdrName -> Maybe Name-isExact_maybe (Exact n) = Just n-isExact_maybe _         = Nothing--{--************************************************************************-*                                                                      *-\subsection{Instances}-*                                                                      *-************************************************************************--}--instance Outputable RdrName where-    ppr (Exact name)   = ppr name-    ppr (Unqual occ)   = ppr occ-    ppr (Qual mod occ) = ppr mod <> dot <> ppr occ-    ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ)--instance OutputableBndr RdrName where-    pprBndr _ n-        | isTvOcc (rdrNameOcc n) = char '@' <> ppr n-        | otherwise              = ppr n--    pprInfixOcc  rdr = pprInfixVar  (isSymOcc (rdrNameOcc rdr)) (ppr rdr)-    pprPrefixOcc rdr-      | Just name <- isExact_maybe rdr = pprPrefixName name-             -- pprPrefixName has some special cases, so-             -- we delegate to them rather than reproduce them-      | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)--instance Eq RdrName where-    (Exact n1)    == (Exact n2)    = n1==n2-        -- Convert exact to orig-    (Exact n1)    == r2@(Orig _ _) = nukeExact n1 == r2-    r1@(Orig _ _) == (Exact n2)    = r1 == nukeExact n2--    (Orig m1 o1)  == (Orig m2 o2)  = m1==m2 && o1==o2-    (Qual m1 o1)  == (Qual m2 o2)  = m1==m2 && o1==o2-    (Unqual o1)   == (Unqual o2)   = o1==o2-    _             == _             = False--instance Ord RdrName where-    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }-    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }-    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }-    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }--        -- Exact < Unqual < Qual < Orig-        -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig-        --      before comparing so that Prelude.map == the exact Prelude.map, but-        --      that meant that we reported duplicates when renaming bindings-        --      generated by Template Haskell; e.g-        --      do { n1 <- newName "foo"; n2 <- newName "foo";-        --           <decl involving n1,n2> }-        --      I think we can do without this conversion-    compare (Exact n1) (Exact n2) = n1 `compare` n2-    compare (Exact _)  _          = LT--    compare (Unqual _)   (Exact _)    = GT-    compare (Unqual o1)  (Unqual  o2) = o1 `compare` o2-    compare (Unqual _)   _            = LT--    compare (Qual _ _)   (Exact _)    = GT-    compare (Qual _ _)   (Unqual _)   = GT-    compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2)-    compare (Qual _ _)   (Orig _ _)   = LT--    compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2)-    compare (Orig _ _)   _            = GT--{--************************************************************************-*                                                                      *-                        LocalRdrEnv-*                                                                      *-************************************************************************--}---- | Local Reader Environment------ This environment is used to store local bindings--- (@let@, @where@, lambda, @case@).--- It is keyed by OccName, because we never use it for qualified names--- We keep the current mapping, *and* the set of all Names in scope--- Reason: see Note [Splicing Exact names] in GHC.Rename.Env-data LocalRdrEnv = LRE { lre_env      :: OccEnv Name-                       , lre_in_scope :: NameSet }--instance Outputable LocalRdrEnv where-  ppr (LRE {lre_env = env, lre_in_scope = ns})-    = hang (text "LocalRdrEnv {")-         2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env-                 , text "in_scope ="-                    <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr)-                 ] <+> char '}')-    where-      ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name-                     -- So we can see if the keys line up correctly--emptyLocalRdrEnv :: LocalRdrEnv-emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv-                       , lre_in_scope = emptyNameSet }--extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv--- The Name should be a non-top-level thing-extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name-  = WARN( isExternalName name, ppr name )-    lre { lre_env      = extendOccEnv env (nameOccName name) name-        , lre_in_scope = extendNameSet ns name }--extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv-extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names-  = WARN( any isExternalName names, ppr names )-    lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]-        , lre_in_scope = extendNameSetList ns names }--lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name-lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr-  | Unqual occ <- rdr-  = lookupOccEnv env occ--  -- See Note [Local bindings with Exact Names]-  | Exact name <- rdr-  , name `elemNameSet` ns-  = Just name--  | otherwise-  = Nothing--lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name-lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ--elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool-elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns })-  = case rdr_name of-      Unqual occ -> occ  `elemOccEnv` env-      Exact name -> name `elemNameSet` ns  -- See Note [Local bindings with Exact Names]-      Qual {} -> False-      Orig {} -> False--localRdrEnvElts :: LocalRdrEnv -> [Name]-localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env--inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool--- This is the point of the NameSet-inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns--delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv-delLocalRdrEnvList lre@(LRE { lre_env = env }) occs-  = lre { lre_env = delListFromOccEnv env occs }--{--Note [Local bindings with Exact Names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-With Template Haskell we can make local bindings that have Exact Names.-Computing shadowing etc may use elemLocalRdrEnv (at least it certainly-does so in GHC.Rename.Types.bindHsQTyVars), so for an Exact Name we must consult-the in-scope-name-set.---************************************************************************-*                                                                      *-                        GlobalRdrEnv-*                                                                      *-************************************************************************--}---- | Global Reader Environment-type GlobalRdrEnv = OccEnv [GlobalRdrElt]--- ^ Keyed by 'OccName'; when looking up a qualified name--- we look up the 'OccName' part, and then check the 'Provenance'--- to see if the appropriate qualification is valid.  This--- saves routinely doubling the size of the env by adding both--- qualified and unqualified names to the domain.------ The list in the codomain is required because there may be name clashes--- These only get reported on lookup, not on construction------ INVARIANT 1: All the members of the list have distinct---              'gre_name' fields; that is, no duplicate Names------ INVARIANT 2: Imported provenance => Name is an ExternalName---              However LocalDefs can have an InternalName.  This---              happens only when type-checking a [d| ... |] Template---              Haskell quotation; see this note in GHC.Rename.Names---              Note [Top-level Names in Template Haskell decl quotes]------ INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then---                 greOccName gre = occ------              NB: greOccName gre is usually the same as---                  nameOccName (gre_name gre), but not always in the---                  case of record selectors; see greOccName---- | Global Reader Element------ An element of the 'GlobalRdrEnv'-data GlobalRdrElt-  = GRE { gre_name :: Name-        , gre_par  :: Parent-        , gre_lcl :: Bool          -- ^ True <=> the thing was defined locally-        , gre_imp :: [ImportSpec]  -- ^ In scope through these imports-    } deriving (Data, Eq)-         -- INVARIANT: either gre_lcl = True or gre_imp is non-empty-         -- See Note [GlobalRdrElt provenance]---- | The children of a Name are the things that are abbreviated by the ".."---   notation in export lists.  See Note [Parents]-data Parent = NoParent-            | ParentIs  { par_is :: Name }-            | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }-              -- ^ See Note [Parents for record fields]-            deriving (Eq, Data)--instance Outputable Parent where-   ppr NoParent        = empty-   ppr (ParentIs n)    = text "parent:" <> ppr n-   ppr (FldParent n f) = text "fldparent:"-                             <> ppr n <> colon <> ppr f--plusParent :: Parent -> Parent -> Parent--- See Note [Combining parents]-plusParent p1@(ParentIs _)    p2 = hasParent p1 p2-plusParent p1@(FldParent _ _) p2 = hasParent p1 p2-plusParent p1 p2@(ParentIs _)    = hasParent p2 p1-plusParent p1 p2@(FldParent _ _) = hasParent p2 p1-plusParent _ _                   = NoParent--hasParent :: Parent -> Parent -> Parent-#if defined(DEBUG)-hasParent p NoParent = p-hasParent p p'-  | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p')  -- Parents should agree-#endif-hasParent p _  = p---{- Note [GlobalRdrElt provenance]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance",-i.e. how the Name came to be in scope.  It can be in scope two ways:-  - gre_lcl = True: it is bound in this module-  - gre_imp: a list of all the imports that brought it into scope--It's an INVARIANT that you have one or the other; that is, either-gre_lcl is True, or gre_imp is non-empty.--It is just possible to have *both* if there is a module loop: a Name-is defined locally in A, and also brought into scope by importing a-module that SOURCE-imported A.  Example (#7672):-- A.hs-boot   module A where-               data T-- B.hs        module B(Decl.T) where-               import {-# SOURCE #-} qualified A as Decl-- A.hs        module A where-               import qualified B-               data T = Z | S B.T--In A.hs, 'T' is locally bound, *and* imported as B.T.--Note [Parents]-~~~~~~~~~~~~~~~~~-  Parent           Children-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  data T           Data constructors-                   Record-field ids--  data family T    Data constructors and record-field ids-                   of all visible data instances of T--  class C          Class operations-                   Associated type constructors--~~~~~~~~~~~~~~~~~~~~~~~~~- Constructor      Meaning- ~~~~~~~~~~~~~~~~~~~~~~~~-  NoParent        Can not be bundled with a type constructor.-  ParentIs n      Can be bundled with the type constructor corresponding to-                  n.-  FldParent       See Note [Parents for record fields]-----Note [Parents for record fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For record fields, in addition to the Name of the type constructor-(stored in par_is), we use FldParent to store the field label.  This-extra information is used for identifying overloaded record fields-during renaming.--In a definition arising from a normal module (without--XDuplicateRecordFields), par_lbl will be Nothing, meaning that the-field's label is the same as the OccName of the selector's Name.  The-GlobalRdrEnv will contain an entry like this:--    "x" |->  GRE x (FldParent T Nothing) LocalDef--When -XDuplicateRecordFields is enabled for the module that contains-T, the selector's Name will be mangled (see comments in FieldLabel).-Thus we store the actual field label in par_lbl, and the GlobalRdrEnv-entry looks like this:--    "x" |->  GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef--Note that the OccName used when adding a GRE to the environment-(greOccName) now depends on the parent field: for FldParent it is the-field label, if present, rather than the selector name.--~~--Record pattern synonym selectors are treated differently. Their parent-information is `NoParent` in the module in which they are defined. This is because-a pattern synonym `P` has no parent constructor either.--However, if `f` is bundled with a type constructor `T` then whenever `f` is-imported the parent will use the `Parent` constructor so the parent of `f` is-now `T`.---Note [Combining parents]-~~~~~~~~~~~~~~~~~~~~~~~~-With an associated type we might have-   module M where-     class C a where-       data T a-       op :: T a -> a-     instance C Int where-       data T Int = TInt-     instance C Bool where-       data T Bool = TBool--Then:   C is the parent of T-        T is the parent of TInt and TBool-So: in an export list-    C(..) is short for C( op, T )-    T(..) is short for T( TInt, TBool )--Module M exports everything, so its exports will be-   AvailTC C [C,T,op]-   AvailTC T [T,TInt,TBool]-On import we convert to GlobalRdrElt and then combine-those.  For T that will mean we have-  one GRE with Parent C-  one GRE with NoParent-That's why plusParent picks the "best" case.--}---- | make a 'GlobalRdrEnv' where all the elements point to the same--- Provenance (useful for "hiding" imports, or imports with no details).-gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]--- prov = Nothing   => locally bound---        Just spec => imported as described by spec-gresFromAvails prov avails-  = concatMap (gresFromAvail (const prov)) avails--localGREsFromAvail :: AvailInfo -> [GlobalRdrElt]--- Turn an Avail into a list of LocalDef GlobalRdrElts-localGREsFromAvail = gresFromAvail (const Nothing)--gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt]-gresFromAvail prov_fn avail-  = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail)-  where-    mk_gre n-      = case prov_fn n of  -- Nothing => bound locally-                           -- Just is => imported from 'is'-          Nothing -> GRE { gre_name = n, gre_par = mkParent n avail-                         , gre_lcl = True, gre_imp = [] }-          Just is -> GRE { gre_name = n, gre_par = mkParent n avail-                         , gre_lcl = False, gre_imp = [is] }--    mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded-                           , flSelector = n })-      = case prov_fn n of  -- Nothing => bound locally-                           -- Just is => imported from 'is'-          Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl-                         , gre_lcl = True, gre_imp = [] }-          Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl-                         , gre_lcl = False, gre_imp = [is] }-      where-        mb_lbl | is_overloaded = Just lbl-               | otherwise     = Nothing---greQualModName :: GlobalRdrElt -> ModuleName--- Get a suitable module qualifier for the GRE--- (used in mkPrintUnqualified)--- Prerecondition: the gre_name is always External-greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })- | lcl, Just mod <- nameModule_maybe name = moduleName mod- | (is:_) <- iss                          = is_as (is_decl is)- | otherwise                              = pprPanic "greQualModName" (ppr gre)--greRdrNames :: GlobalRdrElt -> [RdrName]-greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss }-  = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss)-  where-    occ    = greOccName gre-    unqual = Unqual occ-    do_spec decl_spec-        | is_qual decl_spec = [qual]-        | otherwise         = [unqual,qual]-        where qual = Qual (is_as decl_spec) occ---- the SrcSpan that pprNameProvenance prints out depends on whether--- the Name is defined locally or not: for a local definition the--- definition site is used, otherwise the location of the import--- declaration.  We want to sort the export locations in--- exportClashErr by this SrcSpan, we need to extract it:-greSrcSpan :: GlobalRdrElt -> SrcSpan-greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )-  | lcl           = nameSrcSpan name-  | (is:_) <- iss = is_dloc (is_decl is)-  | otherwise     = pprPanic "greSrcSpan" (ppr gre)--mkParent :: Name -> AvailInfo -> Parent-mkParent _ (Avail _)           = NoParent-mkParent n (AvailTC m _ _) | n == m    = NoParent-                         | otherwise = ParentIs m--greParent_maybe :: GlobalRdrElt -> Maybe Name-greParent_maybe gre = case gre_par gre of-                        NoParent      -> Nothing-                        ParentIs n    -> Just n-                        FldParent n _ -> Just n---- | Takes a list of distinct GREs and folds them--- into AvailInfos. This is more efficient than mapping each individual--- GRE to an AvailInfo and the folding using `plusAvail` but needs the--- uniqueness assumption.-gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo]-gresToAvailInfo gres-  = nameEnvElts avail_env-  where-    avail_env :: NameEnv AvailInfo -- Keyed by the parent-    (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres--    add :: (NameEnv AvailInfo, NameSet)-        -> GlobalRdrElt-        -> (NameEnv AvailInfo, NameSet)-    add (env, done) gre-      | name `elemNameSet` done-      = (env, done)  -- Don't insert twice into the AvailInfo-      | otherwise-      = ( extendNameEnv_Acc comb availFromGRE env key gre-        , done `extendNameSet` name )-      where-        name = gre_name gre-        key = case greParent_maybe gre of-                 Just parent -> parent-                 Nothing     -> gre_name gre--        -- We want to insert the child `k` into a list of children but-        -- need to maintain the invariant that the parent is first.-        ---        -- We also use the invariant that `k` is not already in `ns`.-        insertChildIntoChildren :: Name -> [Name] -> Name -> [Name]-        insertChildIntoChildren _ [] k = [k]-        insertChildIntoChildren p (n:ns) k-          | p == k = k:n:ns-          | otherwise = n:k:ns--        comb :: GlobalRdrElt -> AvailInfo -> AvailInfo-        comb _ (Avail n) = Avail n -- Duplicated name, should not happen-        comb gre (AvailTC m ns fls)-          = case gre_par gre of-              NoParent    -> AvailTC m (name:ns) fls -- Not sure this ever happens-              ParentIs {} -> AvailTC m (insertChildIntoChildren m ns name) fls-              FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel name mb_lbl : fls)--availFromGRE :: GlobalRdrElt -> AvailInfo-availFromGRE (GRE { gre_name = me, gre_par = parent })-  = case parent of-      ParentIs p                  -> AvailTC p [me] []-      NoParent   | isTyConName me -> AvailTC me [me] []-                 | otherwise      -> avail   me-      FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl]--mkFieldLabel :: Name -> Maybe FastString -> FieldLabel-mkFieldLabel me mb_lbl =-          case mb_lbl of-                 Nothing  -> FieldLabel { flLabel = occNameFS (nameOccName me)-                                        , flIsOverloaded = False-                                        , flSelector = me }-                 Just lbl -> FieldLabel { flLabel = lbl-                                        , flIsOverloaded = True-                                        , flSelector = me }--emptyGlobalRdrEnv :: GlobalRdrEnv-emptyGlobalRdrEnv = emptyOccEnv--globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt]-globalRdrEnvElts env = foldOccEnv (++) [] env--instance Outputable GlobalRdrElt where-  ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre))-               2 (pprNameProvenance gre)--pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc-pprGlobalRdrEnv locals_only env-  = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)"))-             <+> lbrace-         , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ]-             <+> rbrace) ]-  where-    remove_locals gres | locals_only = filter isLocalGRE gres-                       | otherwise   = gres-    pp []   = empty-    pp gres = hang (ppr occ-                     <+> parens (text "unique" <+> ppr (getUnique occ))-                     <> colon)-                 2 (vcat (map ppr gres))-      where-        occ = nameOccName (gre_name (head gres))--lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt]-lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of-                                  Nothing   -> []-                                  Just gres -> gres--greOccName :: GlobalRdrElt -> OccName-greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl-greOccName gre                                            = nameOccName (gre_name gre)--lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]-lookupGRE_RdrName rdr_name env-  = case lookupOccEnv env (rdrNameOcc rdr_name) of-    Nothing   -> []-    Just gres -> pickGREs rdr_name gres--lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt--- ^ Look for precisely this 'Name' in the environment.  This tests--- whether it is in scope, ignoring anything else that might be in--- scope with the same 'OccName'.-lookupGRE_Name env name-  = lookupGRE_Name_OccName env name (nameOccName name)--lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt--- ^ Look for a particular record field selector in the environment, where the--- selector name and field label may be different: the GlobalRdrEnv is keyed on--- the label.  See Note [Parents for record fields] for why this happens.-lookupGRE_FieldLabel env fl-  = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl))--lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt--- ^ Look for precisely this 'Name' in the environment, but with an 'OccName'--- that might differ from that of the 'Name'.  See 'lookupGRE_FieldLabel' and--- Note [Parents for record fields].-lookupGRE_Name_OccName env name occ-  = case [ gre | gre <- lookupGlobalRdrEnv env occ-               , gre_name gre == name ] of-      []    -> Nothing-      [gre] -> Just gre-      gres  -> pprPanic "lookupGRE_Name_OccName"-                        (ppr name $$ ppr occ $$ ppr gres)-               -- See INVARIANT 1 on GlobalRdrEnv---getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]]--- Returns all the qualifiers by which 'x' is in scope--- Nothing means "the unqualified version is in scope"--- [] means the thing is not in scope at all-getGRE_NameQualifier_maybes env name-  = case lookupGRE_Name env name of-      Just gre -> [qualifier_maybe gre]-      Nothing  -> []-  where-    qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss })-      | lcl       = Nothing-      | otherwise = Just $ map (is_as . is_decl) iss--isLocalGRE :: GlobalRdrElt -> Bool-isLocalGRE (GRE {gre_lcl = lcl }) = lcl--isRecFldGRE :: GlobalRdrElt -> Bool-isRecFldGRE (GRE {gre_par = FldParent{}}) = True-isRecFldGRE _                             = False---- Returns the field label of this GRE, if it has one-greLabel :: GlobalRdrElt -> Maybe FieldLabelString-greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl-greLabel (GRE{gre_name = n, gre_par = FldParent{}})     = Just (occNameFS (nameOccName n))-greLabel _                                              = Nothing--unQualOK :: GlobalRdrElt -> Bool--- ^ Test if an unqualified version of this thing would be in scope-unQualOK (GRE {gre_lcl = lcl, gre_imp = iss })-  | lcl = True-  | otherwise = any unQualSpecOK iss--{- Note [GRE filtering]-~~~~~~~~~~~~~~~~~~~~~~~-(pickGREs rdr gres) takes a list of GREs which have the same OccName-as 'rdr', say "x".  It does two things:--(a) filters the GREs to a subset that are in scope-    * Qualified,   as 'M.x'  if want_qual    is Qual M _-    * Unqualified, as 'x'    if want_unqual  is Unqual _--(b) for that subset, filter the provenance field (gre_lcl and gre_imp)-    to ones that brought it into scope qualified or unqualified resp.--Example:-      module A ( f ) where-      import qualified Foo( f )-      import Baz( f )-      f = undefined--Let's suppose that Foo.f and Baz.f are the same entity really, but the local-'f' is different, so there will be two GREs matching "f":-   gre1:  gre_lcl = True,  gre_imp = []-   gre2:  gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ]--The use of "f" in the export list is ambiguous because it's in scope-from the local def and the import Baz(f); but *not* the import qualified Foo.-pickGREs returns two GRE-   gre1:   gre_lcl = True,  gre_imp = []-   gre2:   gre_lcl = False, gre_imp = [ imported from Bar ]--Now the "ambiguous occurrence" message can correctly report how the-ambiguity arises.--}--pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt]--- ^ Takes a list of GREs which have the right OccName 'x'--- Pick those GREs that are in scope---    * Qualified,   as 'M.x'  if want_qual    is Qual M _---    * Unqualified, as 'x'    if want_unqual  is Unqual _------ Return each such GRE, with its ImportSpecs filtered, to reflect--- how it is in scope qualified or unqualified respectively.--- See Note [GRE filtering]-pickGREs (Unqual {})  gres = mapMaybe pickUnqualGRE     gres-pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres-pickGREs _            _    = []  -- I don't think this actually happens--pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt-pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss })-  | not lcl, null iss' = Nothing-  | otherwise          = Just (gre { gre_imp = iss' })-  where-    iss' = filter unQualSpecOK iss--pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt-pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss })-  | not lcl', null iss' = Nothing-  | otherwise           = Just (gre { gre_lcl = lcl', gre_imp = iss' })-  where-    iss' = filter (qualSpecOK mod) iss-    lcl' = lcl && name_is_from mod n--    name_is_from :: ModuleName -> Name -> Bool-    name_is_from mod name = case nameModule_maybe name of-                              Just n_mod -> moduleName n_mod == mod-                              Nothing    -> False--pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)]--- ^ Pick GREs that are in scope *both* qualified *and* unqualified--- Return each GRE that is, as a pair---    (qual_gre, unqual_gre)--- These two GREs are the original GRE with imports filtered to express how--- it is in scope qualified an unqualified respectively------ Used only for the 'module M' item in export list;---   see GHC.Rename.Names.exports_from_avail-pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres--pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt)-pickBothGRE mod gre@(GRE { gre_name = n })-  | isBuiltInSyntax n                = Nothing-  | Just gre1 <- pickQualGRE mod gre-  , Just gre2 <- pickUnqualGRE   gre = Just (gre1, gre2)-  | otherwise                        = Nothing-  where-        -- isBuiltInSyntax filter out names for built-in syntax They-        -- just clutter up the environment (esp tuples), and the-        -- parser will generate Exact RdrNames for them, so the-        -- cluttered envt is no use.  Really, it's only useful for-        -- GHC.Base and GHC.Tuple.---- Building GlobalRdrEnvs--plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv-plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2--mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv-mkGlobalRdrEnv gres-  = foldr add emptyGlobalRdrEnv gres-  where-    add gre env = extendOccEnv_Acc insertGRE singleton env-                                   (greOccName gre)-                                   gre--insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt]-insertGRE new_g [] = [new_g]-insertGRE new_g (old_g : old_gs)-        | gre_name new_g == gre_name old_g-        = new_g `plusGRE` old_g : old_gs-        | otherwise-        = old_g : insertGRE new_g old_gs--plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt--- Used when the gre_name fields match-plusGRE g1 g2-  = GRE { gre_name = gre_name g1-        , gre_lcl  = gre_lcl g1 || gre_lcl g2-        , gre_imp  = gre_imp g1 ++ gre_imp g2-        , gre_par  = gre_par  g1 `plusParent` gre_par  g2 }--transformGREs :: (GlobalRdrElt -> GlobalRdrElt)-              -> [OccName]-              -> GlobalRdrEnv -> GlobalRdrEnv--- ^ Apply a transformation function to the GREs for these OccNames-transformGREs trans_gre occs rdr_env-  = foldr trans rdr_env occs-  where-    trans occ env-      = case lookupOccEnv env occ of-           Just gres -> extendOccEnv env occ (map trans_gre gres)-           Nothing   -> env--extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv-extendGlobalRdrEnv env gre-  = extendOccEnv_Acc insertGRE singleton env-                     (greOccName gre) gre--shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv-shadowNames = foldl' shadowName--{- Note [GlobalRdrEnv shadowing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Before adding new names to the GlobalRdrEnv we nuke some existing entries;-this is "shadowing".  The actual work is done by RdrEnv.shadowName.-Suppose-   env' = shadowName env M.f--Then:-   * Looking up (Unqual f) in env' should succeed, returning M.f,-     even if env contains existing unqualified bindings for f.-     They are shadowed--   * Looking up (Qual M.f) in env' should succeed, returning M.f--   * Looking up (Qual X.f) in env', where X /= M, should be the same as-     looking up (Qual X.f) in env.-     That is, shadowName does /not/ delete earlier qualified bindings--There are two reasons for shadowing:--* The GHCi REPL--  - Ids bought into scope on the command line (eg let x = True) have-    External Names, like Ghci4.x.  We want a new binding for 'x' (say)-    to override the existing binding for 'x'.  Example:--           ghci> :load M    -- Brings `x` and `M.x` into scope-           ghci> x-           ghci> "Hello"-           ghci> M.x-           ghci> "hello"-           ghci> let x = True  -- Shadows `x`-           ghci> x             -- The locally bound `x`-                               -- NOT an ambiguous reference-           ghci> True-           ghci> M.x           -- M.x is still in scope!-           ghci> "Hello"-    So when we add `x = True` we must not delete the `M.x` from the-    `GlobalRdrEnv`; rather we just want to make it "qualified only";-    hence the `mk_fake-imp_spec` in `shadowName`.  See also Note-    [Interactively-bound Ids in GHCi] in GHC.Driver.Types--  - Data types also have External Names, like Ghci4.T; but we still want-    'T' to mean the newly-declared 'T', not an old one.--* Nested Template Haskell declaration brackets-  See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names--  Consider a TH decl quote:-      module M where-        f x = h [d| f = ...f...M.f... |]-  We must shadow the outer unqualified binding of 'f', else we'll get-  a complaint when extending the GlobalRdrEnv, saying that there are-  two bindings for 'f'.  There are several tricky points:--    - This shadowing applies even if the binding for 'f' is in a-      where-clause, and hence is in the *local* RdrEnv not the *global*-      RdrEnv.  This is done in lcl_env_TH in extendGlobalRdrEnvRn.--    - The External Name M.f from the enclosing module must certainly-      still be available.  So we don't nuke it entirely; we just make-      it seem like qualified import.--    - We only shadow *External* names (which come from the main module),-      or from earlier GHCi commands. Do not shadow *Internal* names-      because in the bracket-          [d| class C a where f :: a-              f = 4 |]-      rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the-      class decl, and *separately* extend the envt with the value binding.-      At that stage, the class op 'f' will have an Internal name.--}--shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv--- Remove certain old GREs that share the same OccName as this new Name.--- See Note [GlobalRdrEnv shadowing] for details-shadowName env name-  = alterOccEnv (fmap alter_fn) env (nameOccName name)-  where-    alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt]-    alter_fn gres = mapMaybe (shadow_with name) gres--    shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt-    shadow_with new_name-       old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss })-       = case nameModule_maybe old_name of-           Nothing -> Just old_gre   -- Old name is Internal; do not shadow-           Just old_mod-              | Just new_mod <- nameModule_maybe new_name-              , new_mod == old_mod   -- Old name same as new name; shadow completely-              -> Nothing--              | null iss'            -- Nothing remains-              -> Nothing--              | otherwise-              -> Just (old_gre { gre_lcl = False, gre_imp = iss' })--              where-                iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss-                lcl_imp | lcl       = [mk_fake_imp_spec old_name old_mod]-                        | otherwise = []--    mk_fake_imp_spec old_name old_mod    -- Urgh!-      = ImpSpec id_spec ImpAll-      where-        old_mod_name = moduleName old_mod-        id_spec      = ImpDeclSpec { is_mod = old_mod_name-                                   , is_as = old_mod_name-                                   , is_qual = True-                                   , is_dloc = nameSrcSpan old_name }--    shadow_is :: Name -> ImportSpec -> Maybe ImportSpec-    shadow_is new_name is@(ImpSpec { is_decl = id_spec })-       | Just new_mod <- nameModule_maybe new_name-       , is_as id_spec == moduleName new_mod-       = Nothing   -- Shadow both qualified and unqualified-       | otherwise -- Shadow unqualified only-       = Just (is { is_decl = id_spec { is_qual = True } })---{--************************************************************************-*                                                                      *-                        ImportSpec-*                                                                      *-************************************************************************--}---- | Import Specification------ The 'ImportSpec' of something says how it came to be imported--- It's quite elaborate so that we can give accurate unused-name warnings.-data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec,-                            is_item :: ImpItemSpec }-                deriving( Eq, Data )---- | Import Declaration Specification------ Describes a particular import declaration and is--- shared among all the 'Provenance's for that decl-data ImpDeclSpec-  = ImpDeclSpec {-        is_mod      :: ModuleName, -- ^ Module imported, e.g. @import Muggle@-                                   -- Note the @Muggle@ may well not be-                                   -- the defining module for this thing!--                                   -- TODO: either should be Module, or there-                                   -- should be a Maybe UnitId here too.-        is_as       :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause)-        is_qual     :: Bool,       -- ^ Was this import qualified?-        is_dloc     :: SrcSpan     -- ^ The location of the entire import declaration-    } deriving (Eq, Data)---- | Import Item Specification------ Describes import info a particular Name-data ImpItemSpec-  = ImpAll              -- ^ The import had no import list,-                        -- or had a hiding list--  | ImpSome {-        is_explicit :: Bool,-        is_iloc     :: SrcSpan  -- Location of the import item-    }   -- ^ The import had an import list.-        -- The 'is_explicit' field is @True@ iff the thing was named-        -- /explicitly/ in the import specs rather-        -- than being imported as part of a "..." group. Consider:-        ---        -- > import C( T(..) )-        ---        -- Here the constructors of @T@ are not named explicitly;-        -- only @T@ is named explicitly.-  deriving (Eq, Data)--bestImport :: [ImportSpec] -> ImportSpec--- See Note [Choosing the best import declaration]-bestImport iss-  = case sortBy best iss of-      (is:_) -> is-      []     -> pprPanic "bestImport" (ppr iss)-  where-    best :: ImportSpec -> ImportSpec -> Ordering-    -- Less means better-    -- Unqualified always wins over qualified; then-    -- import-all wins over import-some; then-    -- earlier declaration wins over later-    best (ImpSpec { is_item = item1, is_decl = d1 })-         (ImpSpec { is_item = item2, is_decl = d2 })-      = (is_qual d1 `compare` is_qual d2) `thenCmp`-        (best_item item1 item2)           `thenCmp`-        SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2)--    best_item :: ImpItemSpec -> ImpItemSpec -> Ordering-    best_item ImpAll ImpAll = EQ-    best_item ImpAll (ImpSome {}) = LT-    best_item (ImpSome {}) ImpAll = GT-    best_item (ImpSome { is_explicit = e1 })-              (ImpSome { is_explicit = e2 }) = e1 `compare` e2-     -- False < True, so if e1 is explicit and e2 is not, we get GT--{- Note [Choosing the best import declaration]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When reporting unused import declarations we use the following rules.-   (see [wiki:commentary/compiler/unused-imports])--Say that an import-item is either-  * an entire import-all decl (eg import Foo), or-  * a particular item in an import list (eg import Foo( ..., x, ...)).-The general idea is that for each /occurrence/ of an imported name, we will-attribute that use to one import-item. Once we have processed all the-occurrences, any import items with no uses attributed to them are unused,-and are warned about. More precisely:--1. For every RdrName in the program text, find its GlobalRdrElt.--2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one-   the "chosen import-item", and mark it "used". This is done-   by 'bestImport'--3. After processing all the RdrNames, bleat about any-   import-items that are unused.-   This is done in GHC.Rename.Names.warnUnusedImportDecls.--The function 'bestImport' returns the dominant import among the-ImportSpecs it is given, implementing Step 2.  We say import-item A-dominates import-item B if we choose A over B. In general, we try to-choose the import that is most likely to render other imports-unnecessary.  Here is the dominance relationship we choose:--    a) import Foo dominates import qualified Foo.--    b) import Foo dominates import Foo(x).--    c) Otherwise choose the textually first one.--Rationale for (a).  Consider-   import qualified M  -- Import #1-   import M( x )       -- Import #2-   foo = M.x + x--The unqualified 'x' can only come from import #2.  The qualified 'M.x'-could come from either, but bestImport picks import #2, because it is-more likely to be useful in other imports, as indeed it is in this-case (see #5211 for a concrete example).--But the rules are not perfect; consider-   import qualified M  -- Import #1-   import M( x )       -- Import #2-   foo = M.x + M.y--The M.x will use import #2, but M.y can only use import #1.--}---unQualSpecOK :: ImportSpec -> Bool--- ^ Is in scope unqualified?-unQualSpecOK is = not (is_qual (is_decl is))--qualSpecOK :: ModuleName -> ImportSpec -> Bool--- ^ Is in scope qualified with the given module?-qualSpecOK mod is = mod == is_as (is_decl is)--importSpecLoc :: ImportSpec -> SrcSpan-importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl-importSpecLoc (ImpSpec _    item)   = is_iloc item--importSpecModule :: ImportSpec -> ModuleName-importSpecModule is = is_mod (is_decl is)--isExplicitItem :: ImpItemSpec -> Bool-isExplicitItem ImpAll                        = False-isExplicitItem (ImpSome {is_explicit = exp}) = exp--pprNameProvenance :: GlobalRdrElt -> SDoc--- ^ Print out one place where the name was define/imported--- (With -dppr-debug, print them all)-pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })-  = ifPprDebug (vcat pp_provs)-               (head pp_provs)-  where-    pp_provs = pp_lcl ++ map pp_is iss-    pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)]-                    else []-    pp_is is = sep [ppr is, ppr_defn_site is name]---- If we know the exact definition point (which we may do with GHCi)--- then show that too.  But not if it's just "imported from X".-ppr_defn_site :: ImportSpec -> Name -> SDoc-ppr_defn_site imp_spec name-  | same_module && not (isGoodSrcSpan loc)-  = empty              -- Nothing interesting to say-  | otherwise-  = parens $ hang (text "and originally defined" <+> pp_mod)-                2 (pprLoc loc)-  where-    loc = nameSrcSpan name-    defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name-    same_module = importSpecModule imp_spec == moduleName defining_mod-    pp_mod | same_module = empty-           | otherwise   = text "in" <+> quotes (ppr defining_mod)---instance Outputable ImportSpec where-   ppr imp_spec-     = text "imported" <+> qual-        <+> text "from" <+> quotes (ppr (importSpecModule imp_spec))-        <+> pprLoc (importSpecLoc imp_spec)-     where-       qual | is_qual (is_decl imp_spec) = text "qualified"-            | otherwise                  = empty--pprLoc :: SrcSpan -> SDoc-pprLoc (RealSrcSpan s _)  = text "at" <+> ppr s-pprLoc (UnhelpfulSpan {}) = empty---- | Display info about the treatment of '*' under NoStarIsType.------ With StarIsType, three properties of '*' hold:------   (a) it is not an infix operator---   (b) it is always in scope---   (c) it is a synonym for Data.Kind.Type------ However, the user might not know that he's working on a module with--- NoStarIsType and write code that still assumes (a), (b), and (c), which--- actually do not hold in that module.------ Violation of (a) shows up in the parser. For instance, in the following--- examples, we have '*' not applied to enough arguments:------   data A :: *---   data F :: * -> *------ Violation of (b) or (c) show up in the renamer and the typechecker--- respectively. For instance:------   type K = Either * Bool------ This will parse differently depending on whether StarIsType is enabled,--- but it will parse nonetheless. With NoStarIsType it is parsed as a type--- operator, thus we have ((*) Either Bool). Now there are two cases to--- consider:------   1. There is no definition of (*) in scope. In this case the renamer will---      fail to look it up. This is a violation of assumption (b).------   2. There is a definition of the (*) type operator in scope (for example---      coming from GHC.TypeNats). In this case the user will get a kind---      mismatch error. This is a violation of assumption (c).------ The user might unknowingly be working on a module with NoStarIsType--- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a--- hint whenever an assumption about '*' is violated. Unfortunately, it is--- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b).------ 'starInfo' generates an appropriate hint to the user depending on the--- extensions enabled in the module and the name that triggered the error.--- That is, if we have NoStarIsType and the error is related to '*' or its--- Unicode variant, the resulting SDoc will contain a helpful suggestion.--- Otherwise it is empty.----starInfo :: Bool -> RdrName -> SDoc-starInfo star_is_type rdr_name =-  -- One might ask: if can use `sdocOption sdocStarIsType` here, why bother to-  -- take star_is_type as input? Why not refactor?-  ---  -- The reason is that `sdocOption sdocStarIsType` would indicate that-  -- StarIsType is enabled in the module that tries to load the problematic-  -- definition, not in the module that is being loaded.-  ---  -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint-  -- must be displayed even if we load this definition from a module (or GHCi)-  -- with StarIsType enabled!-  ---  if isUnqualStar && not star_is_type-     then text "With NoStarIsType, " <>-          quotes (ppr rdr_name) <>-          text " is treated as a regular type operator. "-        $$-          text "Did you mean to use " <> quotes (text "Type") <>-          text " from Data.Kind instead?"-      else empty-  where-    -- Does rdr_name look like the user might have meant the '*' kind by it?-    -- We focus on unqualified stars specifically, because qualified stars are-    -- treated as type operators even under StarIsType.-    isUnqualStar-      | Unqual occName <- rdr_name-      = let fs = occNameFS occName-        in fs == fsLit "*" || fs == fsLit "★"-      | otherwise = False
− compiler/basicTypes/SrcLoc.hs 
@@ -1,741 +0,0 @@--- (c) The University of Glasgow, 1992-2006--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveFunctor      #-}-{-# LANGUAGE DeriveFoldable     #-}-{-# LANGUAGE DeriveTraversable  #-}-{-# LANGUAGE FlexibleInstances  #-}-{-# LANGUAGE RecordWildCards    #-}-{-# LANGUAGE TypeFamilies       #-}-{-# LANGUAGE ViewPatterns       #-}-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE PatternSynonyms    #-}----- | This module contains types that relate to the positions of things--- in source files, and allow tagging of those things with locations-module SrcLoc (-        -- * SrcLoc-        RealSrcLoc,             -- Abstract-        SrcLoc(..),--        -- ** Constructing SrcLoc-        mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,--        noSrcLoc,               -- "I'm sorry, I haven't a clue"-        generatedSrcLoc,        -- Code generated within the compiler-        interactiveSrcLoc,      -- Code from an interactive session--        advanceSrcLoc,-        advanceBufPos,--        -- ** Unsafely deconstructing SrcLoc-        -- These are dubious exports, because they crash on some inputs-        srcLocFile,             -- return the file name part-        srcLocLine,             -- return the line part-        srcLocCol,              -- return the column part--        -- * SrcSpan-        RealSrcSpan,            -- Abstract-        SrcSpan(..),--        -- ** Constructing SrcSpan-        mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,-        noSrcSpan,-        wiredInSrcSpan,         -- Something wired into the compiler-        interactiveSrcSpan,-        srcLocSpan, realSrcLocSpan,-        combineSrcSpans,-        srcSpanFirstCharacter,--        -- ** Deconstructing SrcSpan-        srcSpanStart, srcSpanEnd,-        realSrcSpanStart, realSrcSpanEnd,-        srcSpanFileName_maybe,-        pprUserRealSpan,--        -- ** Unsafely deconstructing SrcSpan-        -- These are dubious exports, because they crash on some inputs-        srcSpanFile,-        srcSpanStartLine, srcSpanEndLine,-        srcSpanStartCol, srcSpanEndCol,--        -- ** Predicates on SrcSpan-        isGoodSrcSpan, isOneLineSpan,-        containsSpan,--        -- * StringBuffer locations-        BufPos(..),-        BufSpan(..),--        -- * Located-        Located,-        RealLocated,-        GenLocated(..),--        -- ** Constructing Located-        noLoc,-        mkGeneralLocated,--        -- ** Deconstructing Located-        getLoc, unLoc,-        unRealSrcSpan, getRealSrcSpan,--        -- ** Modifying Located-        mapLoc,--        -- ** Combining and comparing Located values-        eqLocated, cmpLocated, combineLocs, addCLoc,-        leftmost_smallest, leftmost_largest, rightmost_smallest,-        spans, isSubspanOf, isRealSubspanOf, sortLocated,-        sortRealLocated,-        lookupSrcLoc, lookupSrcSpan,--        liftL,--        -- * Parser locations-        PsLoc(..),-        PsSpan(..),-        PsLocated,-        advancePsLoc,-        mkPsSpan,-        psSpanStart,-        psSpanEnd,-        mkSrcSpanPs,--    ) where--import GhcPrelude--import Util-import Json-import Outputable-import FastString--import Control.DeepSeq-import Control.Applicative (liftA2)-import Data.Bits-import Data.Data-import Data.List (sortBy, intercalate)-import Data.Function (on)-import qualified Data.Map as Map--{--************************************************************************-*                                                                      *-\subsection[SrcLoc-SrcLocations]{Source-location information}-*                                                                      *-************************************************************************--We keep information about the {\em definition} point for each entity;-this is the obvious stuff:--}---- | Real Source Location------ Represents a single point within a file-data RealSrcLoc-  = SrcLoc      FastString              -- A precise location (file name)-                {-# UNPACK #-} !Int     -- line number, begins at 1-                {-# UNPACK #-} !Int     -- column number, begins at 1-  deriving (Eq, Ord)---- | 0-based index identifying the raw location in the StringBuffer.------ Unlike 'RealSrcLoc', it is not affected by #line and {-# LINE ... #-}--- pragmas. In particular, notice how 'setSrcLoc' and 'resetAlrLastLoc' in--- Lexer.x update 'PsLoc' preserving 'BufPos'.------ The parser guarantees that 'BufPos' are monotonic. See #17632.-newtype BufPos = BufPos { bufPos :: Int }-  deriving (Eq, Ord, Show)---- | Source Location-data SrcLoc-  = RealSrcLoc !RealSrcLoc !(Maybe BufPos)  -- See Note [Why Maybe BufPos]-  | UnhelpfulLoc FastString     -- Just a general indication-  deriving (Eq, Show)--{--************************************************************************-*                                                                      *-\subsection[SrcLoc-access-fns]{Access functions}-*                                                                      *-************************************************************************--}--mkSrcLoc :: FastString -> Int -> Int -> SrcLoc-mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing--mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc-mkRealSrcLoc x line col = SrcLoc x line col---- | Built-in "bad" 'SrcLoc' values for particular locations-noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc-noSrcLoc          = UnhelpfulLoc (fsLit "<no location info>")-generatedSrcLoc   = UnhelpfulLoc (fsLit "<compiler-generated code>")-interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive>")---- | Creates a "bad" 'SrcLoc' that has no detailed information about its location-mkGeneralSrcLoc :: FastString -> SrcLoc-mkGeneralSrcLoc = UnhelpfulLoc---- | Gives the filename of the 'RealSrcLoc'-srcLocFile :: RealSrcLoc -> FastString-srcLocFile (SrcLoc fname _ _) = fname---- | Raises an error when used on a "bad" 'SrcLoc'-srcLocLine :: RealSrcLoc -> Int-srcLocLine (SrcLoc _ l _) = l---- | Raises an error when used on a "bad" 'SrcLoc'-srcLocCol :: RealSrcLoc -> Int-srcLocCol (SrcLoc _ _ c) = c---- | Move the 'SrcLoc' down by one line if the character is a newline,--- to the next 8-char tabstop if it is a tab, and across by one--- character in any other case-advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc-advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f  (l + 1) 1-advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f  l (advance_tabstop c)-advanceSrcLoc (SrcLoc f l c) _    = SrcLoc f  l (c + 1)--advance_tabstop :: Int -> Int-advance_tabstop c = ((((c - 1) `shiftR` 3) + 1) `shiftL` 3) + 1--advanceBufPos :: BufPos -> BufPos-advanceBufPos (BufPos i) = BufPos (i+1)--{--************************************************************************-*                                                                      *-\subsection[SrcLoc-instances]{Instance declarations for various names}-*                                                                      *-************************************************************************--}--sortLocated :: [Located a] -> [Located a]-sortLocated = sortBy (leftmost_smallest `on` getLoc)--sortRealLocated :: [RealLocated a] -> [RealLocated a]-sortRealLocated = sortBy (compare `on` getLoc)--lookupSrcLoc :: SrcLoc -> Map.Map RealSrcLoc a -> Maybe a-lookupSrcLoc (RealSrcLoc l _) = Map.lookup l-lookupSrcLoc (UnhelpfulLoc _) = const Nothing--lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a-lookupSrcSpan (RealSrcSpan l _) = Map.lookup l-lookupSrcSpan (UnhelpfulSpan _) = const Nothing--instance Outputable RealSrcLoc where-    ppr (SrcLoc src_path src_line src_col)-      = hcat [ pprFastFilePath src_path <> colon-             , int src_line <> colon-             , int src_col ]---- I don't know why there is this style-based difference---        if userStyle sty || debugStyle sty then---            hcat [ pprFastFilePath src_path, char ':',---                   int src_line,---                   char ':', int src_col---                 ]---        else---            hcat [text "{-# LINE ", int src_line, space,---                  char '\"', pprFastFilePath src_path, text " #-}"]--instance Outputable SrcLoc where-    ppr (RealSrcLoc l _) = ppr l-    ppr (UnhelpfulLoc s)  = ftext s--instance Data RealSrcSpan where-  -- don't traverse?-  toConstr _   = abstractConstr "RealSrcSpan"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "RealSrcSpan"--instance Data SrcSpan where-  -- don't traverse?-  toConstr _   = abstractConstr "SrcSpan"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "SrcSpan"--{--************************************************************************-*                                                                      *-\subsection[SrcSpan]{Source Spans}-*                                                                      *-************************************************************************--}--{- |-A 'RealSrcSpan' delimits a portion of a text file.  It could be represented-by a pair of (line,column) coordinates, but in fact we optimise-slightly by using more compact representations for single-line and-zero-length spans, both of which are quite common.--The end position is defined to be the column /after/ the end of the-span.  That is, a span of (1,1)-(1,2) is one character long, and a-span of (1,1)-(1,1) is zero characters long.--}---- | Real Source Span-data RealSrcSpan-  = RealSrcSpan'-        { srcSpanFile     :: !FastString,-          srcSpanSLine    :: {-# UNPACK #-} !Int,-          srcSpanSCol     :: {-# UNPACK #-} !Int,-          srcSpanELine    :: {-# UNPACK #-} !Int,-          srcSpanECol     :: {-# UNPACK #-} !Int-        }-  deriving Eq---- | StringBuffer Source Span-data BufSpan =-  BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos }-  deriving (Eq, Ord, Show)---- | Source Span------ A 'SrcSpan' identifies either a specific portion of a text file--- or a human-readable description of a location.-data SrcSpan =-    RealSrcSpan !RealSrcSpan !(Maybe BufSpan)  -- See Note [Why Maybe BufPos]-  | UnhelpfulSpan !FastString   -- Just a general indication-                                -- also used to indicate an empty span--  deriving (Eq, Show) -- Show is used by Lexer.x, because we-                      -- derive Show for Token--{- Note [Why Maybe BufPos]-~~~~~~~~~~~~~~~~~~~~~~~~~~-In SrcLoc we store (Maybe BufPos); in SrcSpan we store (Maybe BufSpan).-Why the Maybe?--Surely, the lexer can always fill in the buffer position, and it guarantees to do so.-However, sometimes the SrcLoc/SrcSpan is constructed in a different context-where the buffer location is not available, and then we use Nothing instead of-a fake value like BufPos (-1).--Perhaps the compiler could be re-engineered to pass around BufPos more-carefully and never discard it, and this 'Maybe' could be removed. If you're-interested in doing so, you may find this ripgrep query useful:--  rg "RealSrc(Loc|Span).*?Nothing"--For example, it is not uncommon to whip up source locations for e.g. error-messages, constructing a SrcSpan without a BufSpan.--}--instance ToJson SrcSpan where-  json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")]-  json (RealSrcSpan rss _) = json rss--instance ToJson RealSrcSpan where-  json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile))-                                     , ("startLine", JSInt srcSpanSLine)-                                     , ("startCol", JSInt srcSpanSCol)-                                     , ("endLine", JSInt srcSpanELine)-                                     , ("endCol", JSInt srcSpanECol)-                                     ]--instance NFData SrcSpan where-  rnf x = x `seq` ()---- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty-noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan-noSrcSpan          = UnhelpfulSpan (fsLit "<no location info>")-wiredInSrcSpan     = UnhelpfulSpan (fsLit "<wired into compiler>")-interactiveSrcSpan = UnhelpfulSpan (fsLit "<interactive>")---- | Create a "bad" 'SrcSpan' that has not location information-mkGeneralSrcSpan :: FastString -> SrcSpan-mkGeneralSrcSpan = UnhelpfulSpan---- | Create a 'SrcSpan' corresponding to a single point-srcLocSpan :: SrcLoc -> SrcSpan-srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str-srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb)--realSrcLocSpan :: RealSrcLoc -> RealSrcSpan-realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col---- | Create a 'SrcSpan' between two points in a file-mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan-mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2-  where-        line1 = srcLocLine loc1-        line2 = srcLocLine loc2-        col1 = srcLocCol loc1-        col2 = srcLocCol loc2-        file = srcLocFile loc1---- | 'True' if the span is known to straddle only one line.-isOneLineRealSpan :: RealSrcSpan -> Bool-isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _)-  = line1 == line2---- | 'True' if the span is a single point-isPointRealSpan :: RealSrcSpan -> Bool-isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2)-  = line1 == line2 && col1 == col2---- | Create a 'SrcSpan' between two points in a file-mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan-mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str-mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str-mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2)-    = RealSrcSpan (mkRealSrcSpan loc1 loc2) (liftA2 BufSpan mbpos1 mbpos2)---- | Combines two 'SrcSpan' into one that spans at least all the characters--- within both spans. Returns UnhelpfulSpan if the files differ.-combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan-combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful-combineSrcSpans l (UnhelpfulSpan _) = l-combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2)-  | srcSpanFile span1 == srcSpanFile span2-      = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2)-  | otherwise = UnhelpfulSpan (fsLit "<combineSrcSpans: files differ>")---- | Combines two 'SrcSpan' into one that spans at least all the characters--- within both spans. Assumes the "file" part is the same in both inputs-combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan-combineRealSrcSpans span1 span2-  = RealSrcSpan' file line_start col_start line_end col_end-  where-    (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1)-                                  (srcSpanStartLine span2, srcSpanStartCol span2)-    (line_end, col_end)     = max (srcSpanEndLine span1, srcSpanEndCol span1)-                                  (srcSpanEndLine span2, srcSpanEndCol span2)-    file = srcSpanFile span1--combineBufSpans :: BufSpan -> BufSpan -> BufSpan-combineBufSpans span1 span2 = BufSpan start end-  where-    start = min (bufSpanStart span1) (bufSpanStart span2)-    end   = max (bufSpanEnd   span1) (bufSpanEnd   span2)----- | Convert a SrcSpan into one that represents only its first character-srcSpanFirstCharacter :: SrcSpan -> SrcSpan-srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l-srcSpanFirstCharacter (RealSrcSpan span mbspan) =-    RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan)-  where-    loc1@(SrcLoc f l c) = realSrcSpanStart span-    loc2 = SrcLoc f l (c+1)-    mkBufSpan bspan =-      let bpos1@(BufPos i) = bufSpanStart bspan-          bpos2 = BufPos (i+1)-      in BufSpan bpos1 bpos2--{--************************************************************************-*                                                                      *-\subsection[SrcSpan-predicates]{Predicates}-*                                                                      *-************************************************************************--}---- | Test if a 'SrcSpan' is "good", i.e. has precise location information-isGoodSrcSpan :: SrcSpan -> Bool-isGoodSrcSpan (RealSrcSpan _ _) = True-isGoodSrcSpan (UnhelpfulSpan _) = False--isOneLineSpan :: SrcSpan -> Bool--- ^ True if the span is known to straddle only one line.--- For "bad" 'SrcSpan', it returns False-isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s-isOneLineSpan (UnhelpfulSpan _) = False---- | Tests whether the first span "contains" the other span, meaning--- that it covers at least as much source code. True where spans are equal.-containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool-containsSpan s1 s2-  = (srcSpanStartLine s1, srcSpanStartCol s1)-       <= (srcSpanStartLine s2, srcSpanStartCol s2)-    && (srcSpanEndLine s1, srcSpanEndCol s1)-       >= (srcSpanEndLine s2, srcSpanEndCol s2)-    && (srcSpanFile s1 == srcSpanFile s2)-    -- We check file equality last because it is (presumably?) least-    -- likely to fail.-{--%************************************************************************-%*                                                                      *-\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions}-*                                                                      *-************************************************************************--}--srcSpanStartLine :: RealSrcSpan -> Int-srcSpanEndLine :: RealSrcSpan -> Int-srcSpanStartCol :: RealSrcSpan -> Int-srcSpanEndCol :: RealSrcSpan -> Int--srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l-srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l-srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l-srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c--{--************************************************************************-*                                                                      *-\subsection[SrcSpan-access-fns]{Access functions}-*                                                                      *-************************************************************************--}---- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable-srcSpanStart :: SrcSpan -> SrcLoc-srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str-srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b)---- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable-srcSpanEnd :: SrcSpan -> SrcLoc-srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str-srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b)--realSrcSpanStart :: RealSrcSpan -> RealSrcLoc-realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s)-                                  (srcSpanStartLine s)-                                  (srcSpanStartCol s)--realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc-realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s)-                                (srcSpanEndLine s)-                                (srcSpanEndCol s)---- | Obtains the filename for a 'SrcSpan' if it is "good"-srcSpanFileName_maybe :: SrcSpan -> Maybe FastString-srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s)-srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing--{--************************************************************************-*                                                                      *-\subsection[SrcSpan-instances]{Instances}-*                                                                      *-************************************************************************--}---- We want to order RealSrcSpans first by the start point, then by the--- end point.-instance Ord RealSrcSpan where-  a `compare` b =-     (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp`-     (realSrcSpanEnd   a `compare` realSrcSpanEnd   b)--instance Show RealSrcLoc where-  show (SrcLoc filename row col)-      = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col---- Show is used by Lexer.x, because we derive Show for Token-instance Show RealSrcSpan where-  show span@(RealSrcSpan' file sl sc el ec)-    | isPointRealSpan span-    = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc])--    | isOneLineRealSpan span-    = "SrcSpanOneLine " ++ show file ++ " "-                        ++ intercalate " " (map show [sl,sc,ec])--    | otherwise-    = "SrcSpanMultiLine " ++ show file ++ " "-                          ++ intercalate " " (map show [sl,sc,el,ec])---instance Outputable RealSrcSpan where-    ppr span = pprUserRealSpan True span---- I don't know why there is this style-based difference---      = getPprStyle $ \ sty ->---        if userStyle sty || debugStyle sty then---           text (showUserRealSpan True span)---        else---           hcat [text "{-# LINE ", int (srcSpanStartLine span), space,---                 char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]--instance Outputable SrcSpan where-    ppr span = pprUserSpan True span---- I don't know why there is this style-based difference---      = getPprStyle $ \ sty ->---        if userStyle sty || debugStyle sty then---           pprUserSpan True span---        else---           case span of---           UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"---           RealSrcSpan s -> ppr s--pprUserSpan :: Bool -> SrcSpan -> SDoc-pprUserSpan _         (UnhelpfulSpan s) = ftext s-pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s--pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc-pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _)-  | isPointRealSpan span-  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)-         , int line <> colon-         , int col ]--pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol)-  | isOneLineRealSpan span-  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)-         , int line <> colon-         , int scol-         , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ]-            -- For single-character or point spans, we just-            -- output the starting column number--pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol)-  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)-         , parens (int sline <> comma <> int scol)-         , char '-'-         , parens (int eline <> comma <> int ecol') ]- where-   ecol' = if ecol == 0 then ecol else ecol - 1--{--************************************************************************-*                                                                      *-\subsection[Located]{Attaching SrcSpans to things}-*                                                                      *-************************************************************************--}---- | We attach SrcSpans to lots of things, so let's have a datatype for it.-data GenLocated l e = L l e-  deriving (Eq, Ord, Data, Functor, Foldable, Traversable)--type Located = GenLocated SrcSpan-type RealLocated = GenLocated RealSrcSpan--mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b-mapLoc = fmap--unLoc :: GenLocated l e -> e-unLoc (L _ e) = e--getLoc :: GenLocated l e -> l-getLoc (L l _) = l--noLoc :: e -> Located e-noLoc e = L noSrcSpan e--mkGeneralLocated :: String -> e -> Located e-mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e--combineLocs :: Located a -> Located b -> SrcSpan-combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)---- | Combine locations from two 'Located' things and add them to a third thing-addCLoc :: Located a -> Located b -> c -> Located c-addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c---- not clear whether to add a general Eq instance, but this is useful sometimes:---- | Tests whether the two located things are equal-eqLocated :: Eq a => GenLocated l a -> GenLocated l a -> Bool-eqLocated a b = unLoc a == unLoc b---- not clear whether to add a general Ord instance, but this is useful sometimes:---- | Tests the ordering of the two located things-cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering-cmpLocated a b = unLoc a `compare` unLoc b--instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where-  ppr (L l e) = -- TODO: We can't do this since Located was refactored into-                -- GenLocated:-                -- Print spans without the file name etc-                -- ifPprDebug (braces (pprUserSpan False l))-                whenPprDebug (braces (ppr l))-             $$ ppr e--{--************************************************************************-*                                                                      *-\subsection{Ordering SrcSpans for InteractiveUI}-*                                                                      *-************************************************************************--}---- | Strategies for ordering 'SrcSpan's-leftmost_smallest, leftmost_largest, rightmost_smallest :: SrcSpan -> SrcSpan -> Ordering-rightmost_smallest = compareSrcSpanBy (flip compare)-leftmost_smallest = compareSrcSpanBy compare-leftmost_largest = compareSrcSpanBy $ \a b ->-  (realSrcSpanStart a `compare` realSrcSpanStart b)-    `thenCmp`-  (realSrcSpanEnd b `compare` realSrcSpanEnd a)--compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering-compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b-compareSrcSpanBy _   (RealSrcSpan _ _) (UnhelpfulSpan _) = LT-compareSrcSpanBy _   (UnhelpfulSpan _) (RealSrcSpan _ _) = GT-compareSrcSpanBy _   (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ---- | Determines whether a span encloses a given line and column index-spans :: SrcSpan -> (Int, Int) -> Bool-spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan"-spans (RealSrcSpan span _) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span-   where loc = mkRealSrcLoc (srcSpanFile span) l c---- | Determines whether a span is enclosed by another one-isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other-            -> SrcSpan -- ^ The span it may be enclosed by-            -> Bool-isSubspanOf (RealSrcSpan src _) (RealSrcSpan parent _) = isRealSubspanOf src parent-isSubspanOf _ _ = False---- | Determines whether a span is enclosed by another one-isRealSubspanOf :: RealSrcSpan -- ^ The span that may be enclosed by the other-                -> RealSrcSpan -- ^ The span it may be enclosed by-                -> Bool-isRealSubspanOf src parent-    | srcSpanFile parent /= srcSpanFile src = False-    | otherwise = realSrcSpanStart parent <= realSrcSpanStart src &&-                  realSrcSpanEnd parent   >= realSrcSpanEnd src--liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b)-liftL f (L loc a) = do-  a' <- f a-  return $ L loc a'--getRealSrcSpan :: RealLocated a -> RealSrcSpan-getRealSrcSpan (L l _) = l--unRealSrcSpan :: RealLocated a -> a-unRealSrcSpan  (L _ e) = e----- | A location as produced by the parser. Consists of two components:------ * The location in the file, adjusted for #line and {-# LINE ... #-} pragmas (RealSrcLoc)--- * The location in the string buffer (BufPos) with monotonicity guarantees (see #17632)-data PsLoc-  = PsLoc { psRealLoc :: !RealSrcLoc, psBufPos :: !BufPos }-  deriving (Eq, Ord, Show)--data PsSpan-  = PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan }-  deriving (Eq, Ord, Show)--type PsLocated = GenLocated PsSpan--advancePsLoc :: PsLoc -> Char -> PsLoc-advancePsLoc (PsLoc real_loc buf_loc) c =-  PsLoc (advanceSrcLoc real_loc c) (advanceBufPos buf_loc)--mkPsSpan :: PsLoc -> PsLoc -> PsSpan-mkPsSpan (PsLoc r1 b1) (PsLoc r2 b2) = PsSpan (mkRealSrcSpan r1 r2) (BufSpan b1 b2)--psSpanStart :: PsSpan -> PsLoc-psSpanStart (PsSpan r b) = PsLoc (realSrcSpanStart r) (bufSpanStart b)--psSpanEnd :: PsSpan -> PsLoc-psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b)--mkSrcSpanPs :: PsSpan -> SrcSpan-mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Just b)
− compiler/basicTypes/UniqSupply.hs 
@@ -1,224 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE BangPatterns #-}--#if !defined(GHC_LOADED_INTO_GHCI)-{-# LANGUAGE UnboxedTuples #-}-#endif--module UniqSupply (-        -- * Main data type-        UniqSupply, -- Abstractly--        -- ** Operations on supplies-        uniqFromSupply, uniqsFromSupply, -- basic ops-        takeUniqFromSupply, uniqFromMask,--        mkSplitUniqSupply,-        splitUniqSupply, listSplitUniqSupply,--        -- * Unique supply monad and its abstraction-        UniqSM, MonadUnique(..),--        -- ** Operations on the monad-        initUs, initUs_,--        -- * Set supply strategy-        initUniqSupply-  ) where--import GhcPrelude--import Unique-import PlainPanic (panic)--import GHC.IO--import MonadUtils-import Control.Monad-import Data.Bits-import Data.Char-import Control.Monad.Fail as Fail--#include "Unique.h"--{--************************************************************************-*                                                                      *-\subsection{Splittable Unique supply: @UniqSupply@}-*                                                                      *-************************************************************************--}---- | Unique Supply------ A value of type 'UniqSupply' is unique, and it can--- supply /one/ distinct 'Unique'.  Also, from the supply, one can--- also manufacture an arbitrary number of further 'UniqueSupply' values,--- which will be distinct from the first and from all others.-data UniqSupply-  = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this-                   UniqSupply UniqSupply-                                -- when split => these two supplies--mkSplitUniqSupply :: Char -> IO UniqSupply--- ^ Create a unique supply out of thin air. The character given must--- be distinct from those of all calls to this function in the compiler--- for the values generated to be truly unique.--splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)--- ^ Build two 'UniqSupply' from a single one, each of which--- can supply its own 'Unique'.-listSplitUniqSupply :: UniqSupply -> [UniqSupply]--- ^ Create an infinite list of 'UniqSupply' from a single one-uniqFromSupply  :: UniqSupply -> Unique--- ^ Obtain the 'Unique' from this particular 'UniqSupply'-uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite--- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply-takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)--- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply--uniqFromMask :: Char -> IO Unique-uniqFromMask mask-  = do { uqNum <- genSym-       ; return $! mkUnique mask uqNum }--mkSplitUniqSupply c-  = case ord c `shiftL` uNIQUE_BITS of-     !mask -> let-        -- here comes THE MAGIC:--        -- This is one of the most hammered bits in the whole compiler-        mk_supply-          -- NB: Use unsafeInterleaveIO for thread-safety.-          = unsafeInterleaveIO (-                genSym      >>= \ u ->-                mk_supply   >>= \ s1 ->-                mk_supply   >>= \ s2 ->-                return (MkSplitUniqSupply (mask .|. u) s1 s2)-            )-       in-       mk_supply--foreign import ccall unsafe "ghc_lib_parser_genSym" genSym :: IO Int-foreign import ccall unsafe "ghc_lib_parser_initGenSym" initUniqSupply :: Int -> Int -> IO ()--splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)-listSplitUniqSupply  (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2--uniqFromSupply  (MkSplitUniqSupply n _ _)  = mkUniqueGrimily n-uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2-takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1)--{--************************************************************************-*                                                                      *-\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@}-*                                                                      *-************************************************************************--}---- Avoids using unboxed tuples when loading into GHCi-#if !defined(GHC_LOADED_INTO_GHCI)--type UniqResult result = (# result, UniqSupply #)--pattern UniqResult :: a -> b -> (# a, b #)-pattern UniqResult x y = (# x, y #)-{-# COMPLETE UniqResult #-}--#else--data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply-  deriving (Functor)--#endif---- | A monad which just gives the ability to obtain 'Unique's-newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }-    deriving (Functor)--instance Monad UniqSM where-  (>>=) = thenUs-  (>>)  = (*>)--instance Applicative UniqSM where-    pure = returnUs-    (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of-                            UniqResult ff us1 -> case x us1 of-                              UniqResult xx us2 -> UniqResult (ff xx) us2-    (*>) = thenUs_---- TODO: try to get rid of this instance-instance Fail.MonadFail UniqSM where-    fail = panic---- | Run the 'UniqSM' action, returning the final 'UniqSupply'-initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)-initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) }---- | Run the 'UniqSM' action, discarding the final 'UniqSupply'-initUs_ :: UniqSupply -> UniqSM a -> a-initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r }--{-# INLINE thenUs #-}-{-# INLINE returnUs #-}-{-# INLINE splitUniqSupply #-}---- @thenUs@ is where we split the @UniqSupply@.--liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)-liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1)--instance MonadFix UniqSM where-    mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1)--thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b-thenUs (USM expr) cont-  = USM (\us0 -> case (expr us0) of-                   UniqResult result us1 -> unUSM (cont result) us1)--thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b-thenUs_ (USM expr) (USM cont)-  = USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 })--returnUs :: a -> UniqSM a-returnUs result = USM (\us -> UniqResult result us)--getUs :: UniqSM UniqSupply-getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2)---- | A monad for generating unique identifiers-class Monad m => MonadUnique m where-    -- | Get a new UniqueSupply-    getUniqueSupplyM :: m UniqSupply-    -- | Get a new unique identifier-    getUniqueM  :: m Unique-    -- | Get an infinite list of new unique identifiers-    getUniquesM :: m [Unique]--    -- This default definition of getUniqueM, while correct, is not as-    -- efficient as it could be since it needlessly generates and throws away-    -- an extra Unique. For your instances consider providing an explicit-    -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly.-    getUniqueM  = liftM uniqFromSupply  getUniqueSupplyM-    getUniquesM = liftM uniqsFromSupply getUniqueSupplyM--instance MonadUnique UniqSM where-    getUniqueSupplyM = getUs-    getUniqueM  = getUniqueUs-    getUniquesM = getUniquesUs--getUniqueUs :: UniqSM Unique-getUniqueUs = USM (\us0 -> case takeUniqFromSupply us0 of-                           (u,us1) -> UniqResult u us1)--getUniquesUs :: UniqSM [Unique]-getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of-                            (us1,us2) -> UniqResult (uniqsFromSupply us1) us2)
− compiler/basicTypes/Unique.hs 
@@ -1,448 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---@Uniques@ are used to distinguish entities in the compiler (@Ids@,-@Classes@, etc.) from each other.  Thus, @Uniques@ are the basic-comparison key in the compiler.--If there is any single operation that needs to be fast, it is @Unique@--comparison.  Unsurprisingly, there is quite a bit of huff-and-puff-directed to that end.--Some of the other hair in this code is to be able to use a-``splittable @UniqueSupply@'' if requested/possible (not standard-Haskell).--}--{-# LANGUAGE CPP, BangPatterns, MagicHash #-}--module Unique (-        -- * Main data types-        Unique, Uniquable(..),-        uNIQUE_BITS,--        -- ** Constructors, destructors and operations on 'Unique's-        hasKey,--        pprUniqueAlways,--        mkUniqueGrimily,                -- Used in UniqSupply only!-        getKey,                         -- Used in Var, UniqFM, Name only!-        mkUnique, unpkUnique,           -- Used in GHC.Iface.Binary only-        eqUnique, ltUnique,-        incrUnique,--        newTagUnique,                   -- Used in CgCase-        initTyVarUnique,-        initExitJoinUnique,-        nonDetCmpUnique,-        isValidKnownKeyUnique,          -- Used in PrelInfo.knownKeyNamesOkay--        -- ** Making built-in uniques--        -- now all the built-in Uniques (and functions to make them)-        -- [the Oh-So-Wonderful Haskell module system wins again...]-        mkAlphaTyVarUnique,-        mkPrimOpIdUnique, mkPrimOpWrapperUnique,-        mkPreludeMiscIdUnique, mkPreludeDataConUnique,-        mkPreludeTyConUnique, mkPreludeClassUnique,-        mkCoVarUnique,--        mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,-        mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,-        mkCostCentreUnique,--        mkBuiltinUnique,-        mkPseudoUniqueD,-        mkPseudoUniqueE,-        mkPseudoUniqueH,--        -- ** Deriving uniques-        -- *** From TyCon name uniques-        tyConRepNameUnique,-        -- *** From DataCon name uniques-        dataConWorkerUnique, dataConTyRepNameUnique,--        -- ** Local uniques-        -- | These are exposed exclusively for use by 'VarEnv.uniqAway', which-        -- has rather peculiar needs. See Note [Local uniques].-        mkLocalUnique, minLocalUnique, maxLocalUnique-    ) where--#include "HsVersions.h"-#include "Unique.h"--import GhcPrelude--import BasicTypes-import FastString-import Outputable-import Util---- just for implementing a fast [0,61) -> Char function-import GHC.Exts (indexCharOffAddr#, Char(..), Int(..))--import Data.Char        ( chr, ord )-import Data.Bits--{--************************************************************************-*                                                                      *-\subsection[Unique-type]{@Unique@ type and operations}-*                                                                      *-************************************************************************--The @Chars@ are ``tag letters'' that identify the @UniqueSupply@.-Fast comparison is everything on @Uniques@:--}---- | Unique identifier.------ The type of unique identifiers that are used in many places in GHC--- for fast ordering and equality tests. You should generate these with--- the functions from the 'UniqSupply' module------ These are sometimes also referred to as \"keys\" in comments in GHC.-newtype Unique = MkUnique Int--{-# INLINE uNIQUE_BITS #-}-uNIQUE_BITS :: Int-uNIQUE_BITS = finiteBitSize (0 :: Int) - UNIQUE_TAG_BITS--{--Now come the functions which construct uniques from their pieces, and vice versa.-The stuff about unique *supplies* is handled further down this module.--}--unpkUnique      :: Unique -> (Char, Int)        -- The reverse--mkUniqueGrimily :: Int -> Unique                -- A trap-door for UniqSupply-getKey          :: Unique -> Int                -- for Var--incrUnique   :: Unique -> Unique-stepUnique   :: Unique -> Int -> Unique-newTagUnique :: Unique -> Char -> Unique--mkUniqueGrimily = MkUnique--{-# INLINE getKey #-}-getKey (MkUnique x) = x--incrUnique (MkUnique i) = MkUnique (i + 1)-stepUnique (MkUnique i) n = MkUnique (i + n)--mkLocalUnique :: Int -> Unique-mkLocalUnique i = mkUnique 'X' i--minLocalUnique :: Unique-minLocalUnique = mkLocalUnique 0--maxLocalUnique :: Unique-maxLocalUnique = mkLocalUnique uniqueMask---- newTagUnique changes the "domain" of a unique to a different char-newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u---- | How many bits are devoted to the unique index (as opposed to the class--- character).-uniqueMask :: Int-uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1---- pop the Char in the top 8 bits of the Unique(Supply)---- No 64-bit bugs here, as long as we have at least 32 bits. --JSM---- and as long as the Char fits in 8 bits, which we assume anyway!--mkUnique :: Char -> Int -> Unique       -- Builds a unique from pieces--- NOT EXPORTED, so that we can see all the Chars that---               are used in this one module-mkUnique c i-  = MkUnique (tag .|. bits)-  where-    tag  = ord c `shiftL` uNIQUE_BITS-    bits = i .&. uniqueMask--unpkUnique (MkUnique u)-  = let-        -- as long as the Char may have its eighth bit set, we-        -- really do need the logical right-shift here!-        tag = chr (u `shiftR` uNIQUE_BITS)-        i   = u .&. uniqueMask-    in-    (tag, i)---- | The interface file symbol-table encoding assumes that known-key uniques fit--- in 30-bits; verify this.------ See Note [Symbol table representation of names] in GHC.Iface.Binary for details.-isValidKnownKeyUnique :: Unique -> Bool-isValidKnownKeyUnique u =-    case unpkUnique u of-      (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22)--{--************************************************************************-*                                                                      *-\subsection[Uniquable-class]{The @Uniquable@ class}-*                                                                      *-************************************************************************--}---- | Class of things that we can obtain a 'Unique' from-class Uniquable a where-    getUnique :: a -> Unique--hasKey          :: Uniquable a => a -> Unique -> Bool-x `hasKey` k    = getUnique x == k--instance Uniquable FastString where- getUnique fs = mkUniqueGrimily (uniqueOfFS fs)--instance Uniquable Int where- getUnique i = mkUniqueGrimily i--{--************************************************************************-*                                                                      *-\subsection[Unique-instances]{Instance declarations for @Unique@}-*                                                                      *-************************************************************************--And the whole point (besides uniqueness) is fast equality.  We don't-use `deriving' because we want {\em precise} control of ordering-(equality on @Uniques@ is v common).--}---- Note [Unique Determinism]--- ~~~~~~~~~~~~~~~~~~~~~~~~~--- The order of allocated @Uniques@ is not stable across rebuilds.--- The main reason for that is that typechecking interface files pulls--- @Uniques@ from @UniqSupply@ and the interface file for the module being--- currently compiled can, but doesn't have to exist.------ It gets more complicated if you take into account that the interface--- files are loaded lazily and that building multiple files at once has to--- work for any subset of interface files present. When you add parallelism--- this makes @Uniques@ hopelessly random.------ As such, to get deterministic builds, the order of the allocated--- @Uniques@ should not affect the final result.--- see also wiki/deterministic-builds------ Note [Unique Determinism and code generation]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The goal of the deterministic builds (wiki/deterministic-builds, #4012)--- is to get ABI compatible binaries given the same inputs and environment.--- The motivation behind that is that if the ABI doesn't change the--- binaries can be safely reused.--- Note that this is weaker than bit-for-bit identical binaries and getting--- bit-for-bit identical binaries is not a goal for now.--- This means that we don't care about nondeterminism that happens after--- the interface files are created, in particular we don't care about--- register allocation and code generation.--- To track progress on bit-for-bit determinism see #12262.--eqUnique :: Unique -> Unique -> Bool-eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2--ltUnique :: Unique -> Unique -> Bool-ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2---- Provided here to make it explicit at the call-site that it can--- introduce non-determinism.--- See Note [Unique Determinism]--- See Note [No Ord for Unique]-nonDetCmpUnique :: Unique -> Unique -> Ordering-nonDetCmpUnique (MkUnique u1) (MkUnique u2)-  = if u1 == u2 then EQ else if u1 < u2 then LT else GT--{--Note [No Ord for Unique]-~~~~~~~~~~~~~~~~~~~~~~~~~~-As explained in Note [Unique Determinism] the relative order of Uniques-is nondeterministic. To prevent from accidental use the Ord Unique-instance has been removed.-This makes it easier to maintain deterministic builds, but comes with some-drawbacks.-The biggest drawback is that Maps keyed by Uniques can't directly be used.-The alternatives are:--  1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which-  2) Create a newtype wrapper based on Unique ordering where nondeterminism-     is controlled. See Module.ModuleEnv-  3) Change the algorithm to use nonDetCmpUnique and document why it's still-     deterministic-  4) Use TrieMap as done in GHC.Cmm.CommonBlockElim.groupByLabel--}--instance Eq Unique where-    a == b = eqUnique a b-    a /= b = not (eqUnique a b)--instance Uniquable Unique where-    getUnique u = u---- We do sometimes make strings with @Uniques@ in them:--showUnique :: Unique -> String-showUnique uniq-  = case unpkUnique uniq of-      (tag, u) -> finish_show tag u (iToBase62 u)--finish_show :: Char -> Int -> String -> String-finish_show 't' u _pp_u | u < 26-  = -- Special case to make v common tyvars, t1, t2, ...-    -- come out as a, b, ... (shorter, easier to read)-    [chr (ord 'a' + u)]-finish_show tag _ pp_u = tag : pp_u--pprUniqueAlways :: Unique -> SDoc--- The "always" means regardless of -dsuppress-uniques--- It replaces the old pprUnique to remind callers that--- they should consider whether they want to consult--- Opt_SuppressUniques-pprUniqueAlways u-  = text (showUnique u)--instance Outputable Unique where-    ppr = pprUniqueAlways--instance Show Unique where-    show uniq = showUnique uniq--{--************************************************************************-*                                                                      *-\subsection[Utils-base62]{Base-62 numbers}-*                                                                      *-************************************************************************--A character-stingy way to read/write numbers (notably Uniques).-The ``62-its'' are \tr{[0-9a-zA-Z]}.  We don't handle negative Ints.-Code stolen from Lennart.--}--iToBase62 :: Int -> String-iToBase62 n_-  = ASSERT(n_ >= 0) go n_ ""-  where-    go n cs | n < 62-            = let !c = chooseChar62 n in c : cs-            | otherwise-            = go q (c : cs) where (!q, r) = quotRem n 62-                                  !c = chooseChar62 r--    chooseChar62 :: Int -> Char-    {-# INLINE chooseChar62 #-}-    chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n)-    chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#--{--************************************************************************-*                                                                      *-\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things}-*                                                                      *-************************************************************************--Allocation of unique supply characters:-        v,t,u : for renumbering value-, type- and usage- vars.-        B:   builtin-        C-E: pseudo uniques     (used in native-code generator)-        X:   uniques from mkLocalUnique-        _:   unifiable tyvars   (above)-        0-9: prelude things below-             (no numbers left any more..)-        ::   (prelude) parallel array data constructors--        other a-z: lower case chars for unique supplies.  Used so far:--        d       desugarer-        f       AbsC flattener-        g       SimplStg-        k       constraint tuple tycons-        m       constraint tuple datacons-        n       Native codegen-        r       Hsc name cache-        s       simplifier-        z       anonymous sums--}--mkAlphaTyVarUnique     :: Int -> Unique-mkPreludeClassUnique   :: Int -> Unique-mkPreludeTyConUnique   :: Int -> Unique-mkPreludeDataConUnique :: Arity -> Unique-mkPrimOpIdUnique       :: Int -> Unique--- See Note [Primop wrappers] in PrimOp.hs.-mkPrimOpWrapperUnique  :: Int -> Unique-mkPreludeMiscIdUnique  :: Int -> Unique-mkCoVarUnique          :: Int -> Unique--mkAlphaTyVarUnique   i = mkUnique '1' i-mkCoVarUnique        i = mkUnique 'g' i-mkPreludeClassUnique i = mkUnique '2' i------------------------------------------------------- Wired-in type constructor keys occupy *two* slots:---    * u: the TyCon itself---    * u+1: the TyConRepName of the TyCon-mkPreludeTyConUnique i                = mkUnique '3' (2*i)--tyConRepNameUnique :: Unique -> Unique-tyConRepNameUnique  u = incrUnique u------------------------------------------------------- Wired-in data constructor keys occupy *three* slots:---    * u: the DataCon itself---    * u+1: its worker Id---    * u+2: the TyConRepName of the promoted TyCon--- Prelude data constructors are too simple to need wrappers.--mkPreludeDataConUnique i              = mkUnique '6' (3*i)    -- Must be alphabetic-----------------------------------------------------dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique-dataConWorkerUnique  u = incrUnique u-dataConTyRepNameUnique u = stepUnique u 2-----------------------------------------------------mkPrimOpIdUnique op         = mkUnique '9' (2*op)-mkPrimOpWrapperUnique op    = mkUnique '9' (2*op+1)-mkPreludeMiscIdUnique  i    = mkUnique '0' i---- The "tyvar uniques" print specially nicely: a, b, c, etc.--- See pprUnique for details--initTyVarUnique :: Unique-initTyVarUnique = mkUnique 't' 0--mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH,-   mkBuiltinUnique :: Int -> Unique--mkBuiltinUnique i = mkUnique 'B' i-mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs-mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs-mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs--mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique-mkRegSingleUnique = mkUnique 'R'-mkRegSubUnique    = mkUnique 'S'-mkRegPairUnique   = mkUnique 'P'-mkRegClassUnique  = mkUnique 'L'--mkCostCentreUnique :: Int -> Unique-mkCostCentreUnique = mkUnique 'C'--mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique--- See Note [The Unique of an OccName] in OccName-mkVarOccUnique  fs = mkUnique 'i' (uniqueOfFS fs)-mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs)-mkTvOccUnique   fs = mkUnique 'v' (uniqueOfFS fs)-mkTcOccUnique   fs = mkUnique 'c' (uniqueOfFS fs)--initExitJoinUnique :: Unique-initExitJoinUnique = mkUnique 's' 0-
− compiler/basicTypes/Var.hs 
@@ -1,763 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section{@Vars@: Variables}--}--{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}---- |--- #name_types#--- GHC uses several kinds of name internally:------ * 'OccName.OccName': see "OccName#name_types"------ * 'RdrName.RdrName': see "RdrName#name_types"------ * 'Name.Name': see "Name#name_types"------ * 'Id.Id': see "Id#name_types"------ * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally---   potentially contain type variables, which have a 'TyCoRep.Kind'---   rather than a 'TyCoRep.Type' and only contain some extra---   details during typechecking.------   These 'Var.Var' names may either be global or local, see "Var#globalvslocal"------ #globalvslocal#--- Global 'Id's and 'Var's are those that are imported or correspond---    to a data constructor, primitive operation, or record selectors.--- Local 'Id's and 'Var's are those bound within an expression---    (e.g. by a lambda) or at the top level of the module being compiled.--module Var (-        -- * The main data type and synonyms-        Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId,-        TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar,--        -- * In and Out variants-        InVar,  InCoVar,  InId,  InTyVar,-        OutVar, OutCoVar, OutId, OutTyVar,--        -- ** Taking 'Var's apart-        varName, varUnique, varType,--        -- ** Modifying 'Var's-        setVarName, setVarUnique, setVarType, updateVarType,-        updateVarTypeM,--        -- ** Constructing, taking apart, modifying 'Id's-        mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar,-        idInfo, idDetails,-        lazySetIdInfo, setIdDetails, globaliseId,-        setIdExported, setIdNotExported,--        -- ** Predicates-        isId, isTyVar, isTcTyVar,-        isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar,-        isGlobalId, isExportedId,-        mustHaveLocalBinding,--        -- * ArgFlags-        ArgFlag(..), isVisibleArgFlag, isInvisibleArgFlag, sameVis,-        AnonArgFlag(..), ForallVisFlag(..), argToForallVisFlag,--        -- * TyVar's-        VarBndr(..), TyCoVarBinder, TyVarBinder,-        binderVar, binderVars, binderArgFlag, binderType,-        mkTyCoVarBinder, mkTyCoVarBinders,-        mkTyVarBinder, mkTyVarBinders,-        isTyVarBinder,--        -- ** Constructing TyVar's-        mkTyVar, mkTcTyVar,--        -- ** Taking 'TyVar's apart-        tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,--        -- ** Modifying 'TyVar's-        setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind,-        updateTyVarKindM,--        nonDetCmpVar--    ) where--#include "HsVersions.h"--import GhcPrelude--import {-# SOURCE #-}   TyCoRep( Type, Kind )-import {-# SOURCE #-}   TyCoPpr( pprKind )-import {-# SOURCE #-}   TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv )-import {-# SOURCE #-}   IdInfo( IdDetails, IdInfo, coVarDetails, isCoVarDetails,-                                vanillaIdInfo, pprIdDetails )--import Name hiding (varName)-import Unique ( Uniquable, Unique, getKey, getUnique-              , mkUniqueGrimily, nonDetCmpUnique )-import Util-import Binary-import Outputable--import Data.Data--{--************************************************************************-*                                                                      *-                     Synonyms-*                                                                      *-************************************************************************--- These synonyms are here and not in Id because otherwise we need a very--- large number of SOURCE imports of Id.hs :-(--}---- | Identifier-type Id    = Var       -- A term-level identifier-                       --  predicate: isId---- | Coercion Variable-type CoVar = Id        -- See Note [Evidence: EvIds and CoVars]-                       --   predicate: isCoVar---- |-type NcId  = Id        -- A term-level (value) variable that is-                       -- /not/ an (unlifted) coercion-                       --    predicate: isNonCoVarId---- | Type or kind Variable-type TyVar   = Var     -- Type *or* kind variable (historical)---- | Type or Kind Variable-type TKVar   = Var     -- Type *or* kind variable (historical)---- | Type variable that might be a metavariable-type TcTyVar = Var---- | Type Variable-type TypeVar = Var     -- Definitely a type variable---- | Kind Variable-type KindVar = Var     -- Definitely a kind variable-                       -- See Note [Kind and type variables]---- See Note [Evidence: EvIds and CoVars]--- | Evidence Identifier-type EvId   = Id        -- Term-level evidence: DictId, IpId, or EqVar---- | Evidence Variable-type EvVar  = EvId      -- ...historical name for EvId---- | Dictionary Function Identifier-type DFunId = Id        -- A dictionary function---- | Dictionary Identifier-type DictId = EvId      -- A dictionary variable---- | Implicit parameter Identifier-type IpId   = EvId      -- A term-level implicit parameter---- | Equality Variable-type EqVar  = EvId      -- Boxed equality evidence-type JoinId = Id        -- A join variable---- | Type or Coercion Variable-type TyCoVar = Id       -- Type, *or* coercion variable-                        --   predicate: isTyCoVar---{- Many passes apply a substitution, and it's very handy to have type-   synonyms to remind us whether or not the substitution has been applied -}--type InVar      = Var-type InTyVar    = TyVar-type InCoVar    = CoVar-type InId       = Id-type OutVar     = Var-type OutTyVar   = TyVar-type OutCoVar   = CoVar-type OutId      = Id----{- Note [Evidence: EvIds and CoVars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* An EvId (evidence Id) is a term-level evidence variable-  (dictionary, implicit parameter, or equality). Could be boxed or unboxed.--* DictId, IpId, and EqVar are synonyms when we know what kind of-  evidence we are talking about.  For example, an EqVar has type (t1 ~ t2).--* A CoVar is always an un-lifted coercion, of type (t1 ~# t2) or (t1 ~R# t2)--Note [Kind and type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Before kind polymorphism, TyVar were used to mean type variables. Now-they are used to mean kind *or* type variables. KindVar is used when we-know for sure that it is a kind variable. In future, we might want to-go over the whole compiler code to use:-   - TKVar   to mean kind or type variables-   - TypeVar to mean         type variables only-   - KindVar to mean kind         variables---************************************************************************-*                                                                      *-\subsection{The main data type declarations}-*                                                                      *-************************************************************************---Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a-@Type@, and an @IdInfo@ (non-essential info about it, e.g.,-strictness).  The essential info about different kinds of @Vars@ is-in its @VarDetails@.--}---- | Variable------ Essentially a typed 'Name', that may also contain some additional information--- about the 'Var' and its use sites.-data Var-  = TyVar {  -- Type and kind variables-             -- see Note [Kind and type variables]-        varName    :: !Name,-        realUnique :: {-# UNPACK #-} !Int,-                                     -- ^ Key for fast comparison-                                     -- Identical to the Unique in the name,-                                     -- cached here for speed-        varType    :: Kind           -- ^ The type or kind of the 'Var' in question- }--  | TcTyVar {                           -- Used only during type inference-                                        -- Used for kind variables during-                                        -- inference, as well-        varName        :: !Name,-        realUnique     :: {-# UNPACK #-} !Int,-        varType        :: Kind,-        tc_tv_details  :: TcTyVarDetails-  }--  | Id {-        varName    :: !Name,-        realUnique :: {-# UNPACK #-} !Int,-        varType    :: Type,-        idScope    :: IdScope,-        id_details :: IdDetails,        -- Stable, doesn't change-        id_info    :: IdInfo }          -- Unstable, updated by simplifier---- | Identifier Scope-data IdScope    -- See Note [GlobalId/LocalId]-  = GlobalId-  | LocalId ExportFlag--data ExportFlag   -- See Note [ExportFlag on binders]-  = NotExported   -- ^ Not exported: may be discarded as dead code.-  | Exported      -- ^ Exported: kept alive--{- Note [ExportFlag on binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-An ExportFlag of "Exported" on a top-level binder says "keep this-binding alive; do not drop it as dead code".  This transitively-keeps alive all the other top-level bindings that this binding refers-to.  This property is persisted all the way down the pipeline, so that-the binding will be compiled all the way to object code, and its-symbols will appear in the linker symbol table.--However, note that this use of "exported" is quite different to the-export list on a Haskell module.  Setting the ExportFlag on an Id does-/not/ mean that if you import the module (in Haskell source code) you-will see this Id.  Of course, things that appear in the export list-of the source Haskell module do indeed have their ExportFlag set.-But many other things, such as dictionary functions, are kept alive-by having their ExportFlag set, even though they are not exported-in the source-code sense.--We should probably use a different term for ExportFlag, like-KeepAlive.--Note [GlobalId/LocalId]-~~~~~~~~~~~~~~~~~~~~~~~-A GlobalId is-  * always a constant (top-level)-  * imported, or data constructor, or primop, or record selector-  * has a Unique that is globally unique across the whole-    GHC invocation (a single invocation may compile multiple modules)-  * never treated as a candidate by the free-variable finder;-        it's a constant!--A LocalId is-  * bound within an expression (lambda, case, local let(rec))-  * or defined at top level in the module being compiled-  * always treated as a candidate by the free-variable finder--After CoreTidy, top-level LocalIds are turned into GlobalIds--}--instance Outputable Var where-  ppr var = sdocOption sdocSuppressVarKinds $ \supp_var_kinds ->-            getPprStyle $ \ppr_style ->-            if |  debugStyle ppr_style && (not supp_var_kinds)-                 -> parens (ppr (varName var) <+> ppr_debug var ppr_style <+>-                          dcolon <+> pprKind (tyVarKind var))-               |  otherwise-                 -> ppr (varName var) <> ppr_debug var ppr_style--ppr_debug :: Var -> PprStyle -> SDoc-ppr_debug (TyVar {}) sty-  | debugStyle sty = brackets (text "tv")-ppr_debug (TcTyVar {tc_tv_details = d}) sty-  | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d)-ppr_debug (Id { idScope = s, id_details = d }) sty-  | debugStyle sty = brackets (ppr_id_scope s <> pprIdDetails d)-ppr_debug _ _ = empty--ppr_id_scope :: IdScope -> SDoc-ppr_id_scope GlobalId              = text "gid"-ppr_id_scope (LocalId Exported)    = text "lidx"-ppr_id_scope (LocalId NotExported) = text "lid"--instance NamedThing Var where-  getName = varName--instance Uniquable Var where-  getUnique = varUnique--instance Eq Var where-    a == b = realUnique a == realUnique b--instance Ord Var where-    a <= b = realUnique a <= realUnique b-    a <  b = realUnique a <  realUnique b-    a >= b = realUnique a >= realUnique b-    a >  b = realUnique a >  realUnique b-    a `compare` b = a `nonDetCmpVar` b---- | Compare Vars by their Uniques.--- This is what Ord Var does, provided here to make it explicit at the--- call-site that it can introduce non-determinism.--- See Note [Unique Determinism]-nonDetCmpVar :: Var -> Var -> Ordering-nonDetCmpVar a b = varUnique a `nonDetCmpUnique` varUnique b--instance Data Var where-  -- don't traverse?-  toConstr _   = abstractConstr "Var"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "Var"--instance HasOccName Var where-  occName = nameOccName . varName--varUnique :: Var -> Unique-varUnique var = mkUniqueGrimily (realUnique var)--setVarUnique :: Var -> Unique -> Var-setVarUnique var uniq-  = var { realUnique = getKey uniq,-          varName = setNameUnique (varName var) uniq }--setVarName :: Var -> Name -> Var-setVarName var new_name-  = var { realUnique = getKey (getUnique new_name),-          varName = new_name }--setVarType :: Id -> Type -> Id-setVarType id ty = id { varType = ty }--updateVarType :: (Type -> Type) -> Id -> Id-updateVarType f id = id { varType = f (varType id) }--updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id-updateVarTypeM f id = do { ty' <- f (varType id)-                         ; return (id { varType = ty' }) }--{- *********************************************************************-*                                                                      *-*                   ArgFlag-*                                                                      *-********************************************************************* -}---- | Argument Flag------ Is something required to appear in source Haskell ('Required'),--- permitted by request ('Specified') (visible type application), or--- prohibited entirely from appearing in source Haskell ('Inferred')?--- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep-data ArgFlag = Inferred | Specified | Required-  deriving (Eq, Ord, Data)-  -- (<) on ArgFlag means "is less visible than"---- | Does this 'ArgFlag' classify an argument that is written in Haskell?-isVisibleArgFlag :: ArgFlag -> Bool-isVisibleArgFlag Required = True-isVisibleArgFlag _        = False---- | Does this 'ArgFlag' classify an argument that is not written in Haskell?-isInvisibleArgFlag :: ArgFlag -> Bool-isInvisibleArgFlag = not . isVisibleArgFlag---- | Do these denote the same level of visibility? 'Required'--- arguments are visible, others are not. So this function--- equates 'Specified' and 'Inferred'. Used for printing.-sameVis :: ArgFlag -> ArgFlag -> Bool-sameVis Required Required = True-sameVis Required _        = False-sameVis _        Required = False-sameVis _        _        = True--instance Outputable ArgFlag where-  ppr Required  = text "[req]"-  ppr Specified = text "[spec]"-  ppr Inferred  = text "[infrd]"--instance Binary ArgFlag where-  put_ bh Required  = putByte bh 0-  put_ bh Specified = putByte bh 1-  put_ bh Inferred  = putByte bh 2--  get bh = do-    h <- getByte bh-    case h of-      0 -> return Required-      1 -> return Specified-      _ -> return Inferred---- | The non-dependent version of 'ArgFlag'.---- Appears here partly so that it's together with its friend ArgFlag,--- but also because it is used in IfaceType, rather early in the--- compilation chain--- See Note [AnonArgFlag vs. ForallVisFlag]-data AnonArgFlag-  = VisArg    -- ^ Used for @(->)@: an ordinary non-dependent arrow.-              --   The argument is visible in source code.-  | InvisArg  -- ^ Used for @(=>)@: a non-dependent predicate arrow.-              --   The argument is invisible in source code.-  deriving (Eq, Ord, Data)--instance Outputable AnonArgFlag where-  ppr VisArg   = text "[vis]"-  ppr InvisArg = text "[invis]"--instance Binary AnonArgFlag where-  put_ bh VisArg   = putByte bh 0-  put_ bh InvisArg = putByte bh 1--  get bh = do-    h <- getByte bh-    case h of-      0 -> return VisArg-      _ -> return InvisArg---- | Is a @forall@ invisible (e.g., @forall a b. {...}@, with a dot) or visible--- (e.g., @forall a b -> {...}@, with an arrow)?---- See Note [AnonArgFlag vs. ForallVisFlag]-data ForallVisFlag-  = ForallVis   -- ^ A visible @forall@ (with an arrow)-  | ForallInvis -- ^ An invisible @forall@ (with a dot)-  deriving (Eq, Ord, Data)--instance Outputable ForallVisFlag where-  ppr f = text $ case f of-                   ForallVis   -> "ForallVis"-                   ForallInvis -> "ForallInvis"---- | Convert an 'ArgFlag' to its corresponding 'ForallVisFlag'.-argToForallVisFlag :: ArgFlag -> ForallVisFlag-argToForallVisFlag Required  = ForallVis-argToForallVisFlag Specified = ForallInvis-argToForallVisFlag Inferred  = ForallInvis--{--Note [AnonArgFlag vs. ForallVisFlag]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The AnonArgFlag and ForallVisFlag data types are quite similar at a first-glance:--  data AnonArgFlag   = VisArg    | InvisArg-  data ForallVisFlag = ForallVis | ForallInvis--Both data types keep track of visibility of some sort. AnonArgFlag tracks-whether a FunTy has a visible argument (->) or an invisible predicate argument-(=>). ForallVisFlag tracks whether a `forall` quantifier is visible-(forall a -> {...}) or invisible (forall a. {...}).--Given their similarities, it's tempting to want to combine these two data types-into one, but they actually represent distinct concepts. AnonArgFlag reflects a-property of *Core* types, whereas ForallVisFlag reflects a property of the GHC-AST. In other words, AnonArgFlag is all about internals, whereas ForallVisFlag-is all about surface syntax. Therefore, they are kept as separate data types.--}--{- *********************************************************************-*                                                                      *-*                   VarBndr, TyCoVarBinder-*                                                                      *-********************************************************************* -}---- Variable Binder------ VarBndr is polymorphic in both var and visibility fields.--- Currently there are six different uses of 'VarBndr':---   * Var.TyVarBinder   = VarBndr TyVar ArgFlag---   * Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag---   * TyCon.TyConBinder     = VarBndr TyVar TyConBndrVis---   * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis---   * IfaceType.IfaceForAllBndr  = VarBndr IfaceBndr ArgFlag---   * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis-data VarBndr var argf = Bndr var argf-  deriving( Data )---- | Variable Binder------ A 'TyCoVarBinder' is the binder of a ForAllTy--- It's convenient to define this synonym here rather its natural--- home in TyCoRep, because it's used in DataCon.hs-boot------ A 'TyVarBinder' is a binder with only TyVar-type TyCoVarBinder = VarBndr TyCoVar ArgFlag-type TyVarBinder   = VarBndr TyVar ArgFlag--binderVar :: VarBndr tv argf -> tv-binderVar (Bndr v _) = v--binderVars :: [VarBndr tv argf] -> [tv]-binderVars tvbs = map binderVar tvbs--binderArgFlag :: VarBndr tv argf -> argf-binderArgFlag (Bndr _ argf) = argf--binderType :: VarBndr TyCoVar argf -> Type-binderType (Bndr tv _) = varType tv---- | Make a named binder-mkTyCoVarBinder :: ArgFlag -> TyCoVar -> TyCoVarBinder-mkTyCoVarBinder vis var = Bndr var vis---- | Make a named binder--- 'var' should be a type variable-mkTyVarBinder :: ArgFlag -> TyVar -> TyVarBinder-mkTyVarBinder vis var-  = ASSERT( isTyVar var )-    Bndr var vis---- | Make many named binders-mkTyCoVarBinders :: ArgFlag -> [TyCoVar] -> [TyCoVarBinder]-mkTyCoVarBinders vis = map (mkTyCoVarBinder vis)---- | Make many named binders--- Input vars should be type variables-mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder]-mkTyVarBinders vis = map (mkTyVarBinder vis)--isTyVarBinder :: TyCoVarBinder -> Bool-isTyVarBinder (Bndr v _) = isTyVar v--instance Outputable tv => Outputable (VarBndr tv ArgFlag) where-  ppr (Bndr v Required)  = ppr v-  ppr (Bndr v Specified) = char '@' <> ppr v-  ppr (Bndr v Inferred)  = braces (ppr v)--instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where-  put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis }--  get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) }--instance NamedThing tv => NamedThing (VarBndr tv flag) where-  getName (Bndr tv _) = getName tv--{--************************************************************************-*                                                                      *-*                 Type and kind variables                              *-*                                                                      *-************************************************************************--}--tyVarName :: TyVar -> Name-tyVarName = varName--tyVarKind :: TyVar -> Kind-tyVarKind = varType--setTyVarUnique :: TyVar -> Unique -> TyVar-setTyVarUnique = setVarUnique--setTyVarName :: TyVar -> Name -> TyVar-setTyVarName   = setVarName--setTyVarKind :: TyVar -> Kind -> TyVar-setTyVarKind tv k = tv {varType = k}--updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar-updateTyVarKind update tv = tv {varType = update (tyVarKind tv)}--updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar-updateTyVarKindM update tv-  = do { k' <- update (tyVarKind tv)-       ; return $ tv {varType = k'} }--mkTyVar :: Name -> Kind -> TyVar-mkTyVar name kind = TyVar { varName    = name-                          , realUnique = getKey (nameUnique name)-                          , varType  = kind-                          }--mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar-mkTcTyVar name kind details-  = -- NB: 'kind' may be a coercion kind; cf, 'TcMType.newMetaCoVar'-    TcTyVar {   varName    = name,-                realUnique = getKey (nameUnique name),-                varType  = kind,-                tc_tv_details = details-        }--tcTyVarDetails :: TyVar -> TcTyVarDetails--- See Note [TcTyVars in the typechecker] in TcType-tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details-tcTyVarDetails (TyVar {})                            = vanillaSkolemTv-tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var))--setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar-setTcTyVarDetails tv details = tv { tc_tv_details = details }--{--%************************************************************************-%*                                                                      *-\subsection{Ids}-*                                                                      *-************************************************************************--}--idInfo :: HasDebugCallStack => Id -> IdInfo-idInfo (Id { id_info = info }) = info-idInfo other                   = pprPanic "idInfo" (ppr other)--idDetails :: Id -> IdDetails-idDetails (Id { id_details = details }) = details-idDetails other                         = pprPanic "idDetails" (ppr other)---- The next three have a 'Var' suffix even though they always build--- Ids, because Id.hs uses 'mkGlobalId' etc with different types-mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id-mkGlobalVar details name ty info-  = mk_id name ty GlobalId details info--mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id-mkLocalVar details name ty info-  = mk_id name ty (LocalId NotExported) details  info--mkCoVar :: Name -> Type -> CoVar--- Coercion variables have no IdInfo-mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo---- | Exported 'Var's will not be removed as dead code-mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id-mkExportedLocalVar details name ty info-  = mk_id name ty (LocalId Exported) details info--mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id-mk_id name ty scope details info-  = Id { varName    = name,-         realUnique = getKey (nameUnique name),-         varType    = ty,-         idScope    = scope,-         id_details = details,-         id_info    = info }----------------------lazySetIdInfo :: Id -> IdInfo -> Var-lazySetIdInfo id info = id { id_info = info }--setIdDetails :: Id -> IdDetails -> Id-setIdDetails id details = id { id_details = details }--globaliseId :: Id -> Id--- ^ If it's a local, make it global-globaliseId id = id { idScope = GlobalId }--setIdExported :: Id -> Id--- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors--- and class operations, which are born as global 'Id's and automatically exported-setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported }-setIdExported id@(Id { idScope = GlobalId })   = id-setIdExported tv                               = pprPanic "setIdExported" (ppr tv)--setIdNotExported :: Id -> Id--- ^ We can only do this to LocalIds-setIdNotExported id = ASSERT( isLocalId id )-                      id { idScope = LocalId NotExported }--{--************************************************************************-*                                                                      *-\subsection{Predicates over variables}-*                                                                      *-************************************************************************--}---- | Is this a type-level (i.e., computationally irrelevant, thus erasable)--- variable? Satisfies @isTyVar = not . isId@.-isTyVar :: Var -> Bool        -- True of both TyVar and TcTyVar-isTyVar (TyVar {})   = True-isTyVar (TcTyVar {}) = True-isTyVar _            = False--isTcTyVar :: Var -> Bool      -- True of TcTyVar only-isTcTyVar (TcTyVar {}) = True-isTcTyVar _            = False--isTyCoVar :: Var -> Bool-isTyCoVar v = isTyVar v || isCoVar v---- | Is this a value-level (i.e., computationally relevant) 'Id'entifier?--- Satisfies @isId = not . isTyVar@.-isId :: Var -> Bool-isId (Id {}) = True-isId _       = False---- | Is this a coercion variable?--- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@.-isCoVar :: Var -> Bool-isCoVar (Id { id_details = details }) = isCoVarDetails details-isCoVar _                             = False---- | Is this a term variable ('Id') that is /not/ a coercion variable?--- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@.-isNonCoVarId :: Var -> Bool-isNonCoVarId (Id { id_details = details }) = not (isCoVarDetails details)-isNonCoVarId _                             = False--isLocalId :: Var -> Bool-isLocalId (Id { idScope = LocalId _ }) = True-isLocalId _                            = False---- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's--- These are the variables that we need to pay attention to when finding free--- variables, or doing dependency analysis.-isLocalVar :: Var -> Bool-isLocalVar v = not (isGlobalId v)--isGlobalId :: Var -> Bool-isGlobalId (Id { idScope = GlobalId }) = True-isGlobalId _                           = False---- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's--- that must have a binding in this module.  The converse--- is not quite right: there are some global 'Id's that must have--- bindings, such as record selectors.  But that doesn't matter,--- because it's only used for assertions-mustHaveLocalBinding        :: Var -> Bool-mustHaveLocalBinding var = isLocalVar var---- | 'isExportedIdVar' means \"don't throw this away\"-isExportedId :: Var -> Bool-isExportedId (Id { idScope = GlobalId })        = True-isExportedId (Id { idScope = LocalId Exported}) = True-isExportedId _ = False
− compiler/basicTypes/Var.hs-boot 
@@ -1,15 +0,0 @@--- Var.hs-boot is Imported (only) by TyCoRep.hs-boot-module Var where--import GhcPrelude ()-  -- We compile this module with -XNoImplicitPrelude (for some-  -- reason), so if there are no imports it does not seem to-  -- depend on anything.  But it does! We must, for example,-  -- compile GHC.Types in the ghc-prim library first.-  -- So this otherwise-unnecessary import tells the build system-  -- that this module depends on GhcPrelude, which ensures-  -- that GHC.Type is built first.--data ArgFlag-data AnonArgFlag-data Var
− compiler/basicTypes/VarEnv.hs 
@@ -1,632 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}--module VarEnv (-        -- * Var, Id and TyVar environments (maps)-        VarEnv, IdEnv, TyVarEnv, CoVarEnv, TyCoVarEnv,--        -- ** Manipulating these environments-        emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly,-        elemVarEnv, disjointVarEnv,-        extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly,-        extendVarEnvList,-        plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C,-        plusVarEnvList, alterVarEnv,-        delVarEnvList, delVarEnv, delVarEnv_Directly,-        minusVarEnv, intersectsVarEnv,-        lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,-        mapVarEnv, zipVarEnv,-        modifyVarEnv, modifyVarEnv_Directly,-        isEmptyVarEnv,-        elemVarEnvByKey, lookupVarEnv_Directly,-        filterVarEnv, filterVarEnv_Directly, restrictVarEnv,-        partitionVarEnv,--        -- * Deterministic Var environments (maps)-        DVarEnv, DIdEnv, DTyVarEnv,--        -- ** Manipulating these environments-        emptyDVarEnv, mkDVarEnv,-        dVarEnvElts,-        extendDVarEnv, extendDVarEnv_C,-        extendDVarEnvList,-        lookupDVarEnv, elemDVarEnv,-        isEmptyDVarEnv, foldDVarEnv,-        mapDVarEnv, filterDVarEnv,-        modifyDVarEnv,-        alterDVarEnv,-        plusDVarEnv, plusDVarEnv_C,-        unitDVarEnv,-        delDVarEnv,-        delDVarEnvList,-        minusDVarEnv,-        partitionDVarEnv,-        anyDVarEnv,--        -- * The InScopeSet type-        InScopeSet,--        -- ** Operations on InScopeSets-        emptyInScopeSet, mkInScopeSet, delInScopeSet,-        extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,-        getInScopeVars, lookupInScope, lookupInScope_Directly,-        unionInScope, elemInScopeSet, uniqAway,-        varSetInScope,-        unsafeGetFreshLocalUnique,--        -- * The RnEnv2 type-        RnEnv2,--        -- ** Operations on RnEnv2s-        mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var,-        rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe,-        rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap,-        delBndrL, delBndrR, delBndrsL, delBndrsR,-        addRnInScopeSet,-        rnEtaL, rnEtaR,-        rnInScope, rnInScopeSet, lookupRnInScope,-        rnEnvL, rnEnvR,--        -- * TidyEnv and its operation-        TidyEnv,-        emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList-    ) where--import GhcPrelude-import qualified Data.IntMap.Strict as IntMap -- TODO: Move this to UniqFM--import OccName-import Name-import Var-import VarSet-import UniqSet-import UniqFM-import UniqDFM-import Unique-import Util-import Maybes-import Outputable--{--************************************************************************-*                                                                      *-                In-scope sets-*                                                                      *-************************************************************************--}---- | A set of variables that are in scope at some point--- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides--- the motivation for this abstraction.-newtype InScopeSet = InScope VarSet-        -- Note [Lookups in in-scope set]-        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-        -- We store a VarSet here, but we use this for lookups rather than just-        -- membership tests. Typically the InScopeSet contains the canonical-        -- version of the variable (e.g. with an informative unfolding), so this-        -- lookup is useful (see, for instance, Note [In-scope set as a-        -- substitution]).--instance Outputable InScopeSet where-  ppr (InScope s) =-    text "InScope" <+>-    braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s)))-                      -- It's OK to use nonDetEltsUniqSet here because it's-                      -- only for pretty printing-                      -- In-scope sets get big, and with -dppr-debug-                      -- the output is overwhelming--emptyInScopeSet :: InScopeSet-emptyInScopeSet = InScope emptyVarSet--getInScopeVars ::  InScopeSet -> VarSet-getInScopeVars (InScope vs) = vs--mkInScopeSet :: VarSet -> InScopeSet-mkInScopeSet in_scope = InScope in_scope--extendInScopeSet :: InScopeSet -> Var -> InScopeSet-extendInScopeSet (InScope in_scope) v-   = InScope (extendVarSet in_scope v)--extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet-extendInScopeSetList (InScope in_scope) vs-   = InScope $ foldl' extendVarSet in_scope vs--extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet-extendInScopeSetSet (InScope in_scope) vs-   = InScope (in_scope `unionVarSet` vs)--delInScopeSet :: InScopeSet -> Var -> InScopeSet-delInScopeSet (InScope in_scope) v = InScope (in_scope `delVarSet` v)--elemInScopeSet :: Var -> InScopeSet -> Bool-elemInScopeSet v (InScope in_scope) = v `elemVarSet` in_scope---- | Look up a variable the 'InScopeSet'.  This lets you map from--- the variable's identity (unique) to its full value.-lookupInScope :: InScopeSet -> Var -> Maybe Var-lookupInScope (InScope in_scope) v  = lookupVarSet in_scope v--lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var-lookupInScope_Directly (InScope in_scope) uniq-  = lookupVarSet_Directly in_scope uniq--unionInScope :: InScopeSet -> InScopeSet -> InScopeSet-unionInScope (InScope s1) (InScope s2)-  = InScope (s1 `unionVarSet` s2)--varSetInScope :: VarSet -> InScopeSet -> Bool-varSetInScope vars (InScope s1) = vars `subVarSet` s1--{--Note [Local uniques]-~~~~~~~~~~~~~~~~~~~~-Sometimes one must create conjure up a unique which is unique in a particular-context (but not necessarily globally unique). For instance, one might need to-create a fresh local identifier which does not shadow any of the locally-in-scope variables.  For this we purpose we provide 'uniqAway'.--'uniqAway' is implemented in terms of the 'unsafeGetFreshLocalUnique'-operation, which generates an unclaimed 'Unique' from an 'InScopeSet'. To-ensure that we do not conflict with uniques allocated by future allocations-from 'UniqSupply's, Uniques generated by 'unsafeGetFreshLocalUnique' are-allocated into a dedicated region of the unique space (namely the X tag).--Note that one must be quite carefully when using uniques generated in this way-since they are only locally unique. In particular, two successive calls to-'uniqAway' on the same 'InScopeSet' will produce the same unique.- -}---- | @uniqAway in_scope v@ finds a unique that is not used in the--- in-scope set, and gives that to v. See Note [Local uniques].-uniqAway :: InScopeSet -> Var -> Var--- It starts with v's current unique, of course, in the hope that it won't--- have to change, and thereafter uses the successor to the last derived unique--- found in the in-scope set.-uniqAway in_scope var-  | var `elemInScopeSet` in_scope = uniqAway' in_scope var      -- Make a new one-  | otherwise                     = var                         -- Nothing to do--uniqAway' :: InScopeSet -> Var -> Var--- This one *always* makes up a new variable-uniqAway' in_scope var-  = setVarUnique var (unsafeGetFreshLocalUnique in_scope)---- | @unsafeGetFreshUnique in_scope@ finds a unique that is not in-scope in the--- given 'InScopeSet'. This must be used very carefully since one can very easily--- introduce non-unique 'Unique's this way. See Note [Local uniques].-unsafeGetFreshLocalUnique :: InScopeSet -> Unique-unsafeGetFreshLocalUnique (InScope set)-  | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set)-  , let uniq' = mkLocalUnique uniq-  , not $ uniq' `ltUnique` minLocalUnique-  = incrUnique uniq'--  | otherwise-  = minLocalUnique--{--************************************************************************-*                                                                      *-                Dual renaming-*                                                                      *-************************************************************************--}---- | Rename Environment 2------ When we are comparing (or matching) types or terms, we are faced with--- \"going under\" corresponding binders.  E.g. when comparing:------ > \x. e1     ~   \y. e2------ Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of--- things we must be careful of.  In particular, @x@ might be free in @e2@, or--- y in @e1@.  So the idea is that we come up with a fresh binder that is free--- in neither, and rename @x@ and @y@ respectively.  That means we must maintain:------ 1. A renaming for the left-hand expression------ 2. A renaming for the right-hand expressions------ 3. An in-scope set------ Furthermore, when matching, we want to be able to have an 'occurs check',--- to prevent:------ > \x. f   ~   \y. y------ matching with [@f@ -> @y@].  So for each expression we want to know that set of--- locally-bound variables. That is precisely the domain of the mappings 1.--- and 2., but we must ensure that we always extend the mappings as we go in.------ All of this information is bundled up in the 'RnEnv2'-data RnEnv2-  = RV2 { envL     :: VarEnv Var        -- Renaming for Left term-        , envR     :: VarEnv Var        -- Renaming for Right term-        , in_scope :: InScopeSet }      -- In scope in left or right terms---- The renamings envL and envR are *guaranteed* to contain a binding--- for every variable bound as we go into the term, even if it is not--- renamed.  That way we can ask what variables are locally bound--- (inRnEnvL, inRnEnvR)--mkRnEnv2 :: InScopeSet -> RnEnv2-mkRnEnv2 vars = RV2     { envL     = emptyVarEnv-                        , envR     = emptyVarEnv-                        , in_scope = vars }--addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2-addRnInScopeSet env vs-  | isEmptyVarSet vs = env-  | otherwise        = env { in_scope = extendInScopeSetSet (in_scope env) vs }--rnInScope :: Var -> RnEnv2 -> Bool-rnInScope x env = x `elemInScopeSet` in_scope env--rnInScopeSet :: RnEnv2 -> InScopeSet-rnInScopeSet = in_scope---- | Retrieve the left mapping-rnEnvL :: RnEnv2 -> VarEnv Var-rnEnvL = envL---- | Retrieve the right mapping-rnEnvR :: RnEnv2 -> VarEnv Var-rnEnvR = envR--rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2--- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length-rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR--rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2--- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term,---                       and binder @bR@ in the Right term.--- It finds a new binder, @new_b@,--- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@-rnBndr2 env bL bR = fst $ rnBndr2_var env bL bR--rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var)--- ^ Similar to 'rnBndr2' but returns the new variable as well as the--- new environment-rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR-  = (RV2 { envL            = extendVarEnv envL bL new_b   -- See Note-         , envR            = extendVarEnv envR bR new_b   -- [Rebinding]-         , in_scope = extendInScopeSet in_scope new_b }, new_b)-  where-        -- Find a new binder not in scope in either term-    new_b | not (bL `elemInScopeSet` in_scope) = bL-          | not (bR `elemInScopeSet` in_scope) = bR-          | otherwise                          = uniqAway' in_scope bL--        -- Note [Rebinding]-        -- If the new var is the same as the old one, note that-        -- the extendVarEnv *deletes* any current renaming-        -- E.g.   (\x. \x. ...)  ~  (\y. \z. ...)-        ---        --   Inside \x  \y      { [x->y], [y->y],       {y} }-        --       \x  \z         { [x->x], [y->y, z->x], {y,x} }--rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var)--- ^ Similar to 'rnBndr2' but used when there's a binder on the left--- side only.-rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL-  = (RV2 { envL     = extendVarEnv envL bL new_b-         , envR     = envR-         , in_scope = extendInScopeSet in_scope new_b }, new_b)-  where-    new_b = uniqAway in_scope bL--rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var)--- ^ Similar to 'rnBndr2' but used when there's a binder on the right--- side only.-rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR-  = (RV2 { envR     = extendVarEnv envR bR new_b-         , envL     = envL-         , in_scope = extendInScopeSet in_scope new_b }, new_b)-  where-    new_b = uniqAway in_scope bR--rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var)--- ^ Similar to 'rnBndrL' but used for eta expansion--- See Note [Eta expansion]-rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL-  = (RV2 { envL     = extendVarEnv envL bL new_b-         , envR     = extendVarEnv envR new_b new_b     -- Note [Eta expansion]-         , in_scope = extendInScopeSet in_scope new_b }, new_b)-  where-    new_b = uniqAway in_scope bL--rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var)--- ^ Similar to 'rnBndr2' but used for eta expansion--- See Note [Eta expansion]-rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR-  = (RV2 { envL     = extendVarEnv envL new_b new_b     -- Note [Eta expansion]-         , envR     = extendVarEnv envR bR new_b-         , in_scope = extendInScopeSet in_scope new_b }, new_b)-  where-    new_b = uniqAway in_scope bR--delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2-delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v-  = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v }-delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v-  = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v }--delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2-delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v-  = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v }-delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v-  = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v }--rnOccL, rnOccR :: RnEnv2 -> Var -> Var--- ^ Look up the renaming of an occurrence in the left or right term-rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v-rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v--rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var--- ^ Look up the renaming of an occurrence in the left or right term-rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v-rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v--inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool--- ^ Tells whether a variable is locally bound-inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env-inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env--lookupRnInScope :: RnEnv2 -> Var -> Var-lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v--nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2--- ^ Wipe the left or right side renaming-nukeRnEnvL env = env { envL = emptyVarEnv }-nukeRnEnvR env = env { envR = emptyVarEnv }--rnSwap :: RnEnv2 -> RnEnv2--- ^ swap the meaning of left and right-rnSwap (RV2 { envL = envL, envR = envR, in_scope = in_scope })-  = RV2 { envL = envR, envR = envL, in_scope = in_scope }--{--Note [Eta expansion]-~~~~~~~~~~~~~~~~~~~~-When matching-     (\x.M) ~ N-we rename x to x' with, where x' is not in scope in-either term.  Then we want to behave as if we'd seen-     (\x'.M) ~ (\x'.N x')-Since x' isn't in scope in N, the form (\x'. N x') doesn't-capture any variables in N.  But we must nevertheless extend-the envR with a binding [x' -> x'], to support the occurs check.-For example, if we don't do this, we can get silly matches like-        forall a.  (\y.a)  ~   v-succeeding with [a -> v y], which is bogus of course.---************************************************************************-*                                                                      *-                Tidying-*                                                                      *-************************************************************************--}---- | Tidy Environment------ When tidying up print names, we keep a mapping of in-scope occ-names--- (the 'TidyOccEnv') and a Var-to-Var of the current renamings-type TidyEnv = (TidyOccEnv, VarEnv Var)--emptyTidyEnv :: TidyEnv-emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)--mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv-mkEmptyTidyEnv occ_env = (occ_env, emptyVarEnv)--delTidyEnvList :: TidyEnv -> [Var] -> TidyEnv-delTidyEnvList (occ_env, var_env) vs = (occ_env', var_env')-  where-    occ_env' = occ_env `delTidyOccEnvList` map (occNameFS . getOccName) vs-    var_env' = var_env `delVarEnvList` vs--{--************************************************************************-*                                                                      *-\subsection{@VarEnv@s}-*                                                                      *-************************************************************************--}---- | Variable Environment-type VarEnv elt     = UniqFM elt---- | Identifier Environment-type IdEnv elt      = VarEnv elt---- | Type Variable Environment-type TyVarEnv elt   = VarEnv elt---- | Type or Coercion Variable Environment-type TyCoVarEnv elt = VarEnv elt---- | Coercion Variable Environment-type CoVarEnv elt   = VarEnv elt--emptyVarEnv       :: VarEnv a-mkVarEnv          :: [(Var, a)] -> VarEnv a-mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a-zipVarEnv         :: [Var] -> [a] -> VarEnv a-unitVarEnv        :: Var -> a -> VarEnv a-alterVarEnv       :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a-extendVarEnv      :: VarEnv a -> Var -> a -> VarEnv a-extendVarEnv_C    :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a-extendVarEnv_Acc  :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b-extendVarEnv_Directly :: VarEnv a -> Unique -> a -> VarEnv a-plusVarEnv        :: VarEnv a -> VarEnv a -> VarEnv a-plusVarEnvList    :: [VarEnv a] -> VarEnv a-extendVarEnvList  :: VarEnv a -> [(Var, a)] -> VarEnv a--lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a-filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a-delVarEnv_Directly    :: VarEnv a -> Unique -> VarEnv a-partitionVarEnv   :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a)-restrictVarEnv    :: VarEnv a -> VarSet -> VarEnv a-delVarEnvList     :: VarEnv a -> [Var] -> VarEnv a-delVarEnv         :: VarEnv a -> Var -> VarEnv a-minusVarEnv       :: VarEnv a -> VarEnv b -> VarEnv a-intersectsVarEnv  :: VarEnv a -> VarEnv a -> Bool-plusVarEnv_C      :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a-plusVarEnv_CD     :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a-plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a-mapVarEnv         :: (a -> b) -> VarEnv a -> VarEnv b-modifyVarEnv      :: (a -> a) -> VarEnv a -> Var -> VarEnv a--isEmptyVarEnv     :: VarEnv a -> Bool-lookupVarEnv      :: VarEnv a -> Var -> Maybe a-filterVarEnv      :: (a -> Bool) -> VarEnv a -> VarEnv a-lookupVarEnv_NF   :: VarEnv a -> Var -> a-lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a-elemVarEnv        :: Var -> VarEnv a -> Bool-elemVarEnvByKey   :: Unique -> VarEnv a -> Bool-disjointVarEnv    :: VarEnv a -> VarEnv a -> Bool--elemVarEnv       = elemUFM-elemVarEnvByKey  = elemUFM_Directly-disjointVarEnv   = disjointUFM-alterVarEnv      = alterUFM-extendVarEnv     = addToUFM-extendVarEnv_C   = addToUFM_C-extendVarEnv_Acc = addToUFM_Acc-extendVarEnv_Directly = addToUFM_Directly-extendVarEnvList = addListToUFM-plusVarEnv_C     = plusUFM_C-plusVarEnv_CD    = plusUFM_CD-plusMaybeVarEnv_C = plusMaybeUFM_C-delVarEnvList    = delListFromUFM-delVarEnv        = delFromUFM-minusVarEnv      = minusUFM-intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2))-plusVarEnv       = plusUFM-plusVarEnvList   = plusUFMList-lookupVarEnv     = lookupUFM-filterVarEnv     = filterUFM-lookupWithDefaultVarEnv = lookupWithDefaultUFM-mapVarEnv        = mapUFM-mkVarEnv         = listToUFM-mkVarEnv_Directly= listToUFM_Directly-emptyVarEnv      = emptyUFM-unitVarEnv       = unitUFM-isEmptyVarEnv    = isNullUFM-lookupVarEnv_Directly = lookupUFM_Directly-filterVarEnv_Directly = filterUFM_Directly-delVarEnv_Directly    = delFromUFM_Directly-partitionVarEnv       = partitionUFM--restrictVarEnv env vs = filterVarEnv_Directly keep env-  where-    keep u _ = u `elemVarSetByKey` vs--zipVarEnv tyvars tys   = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)-lookupVarEnv_NF env id = case lookupVarEnv env id of-                         Just xx -> xx-                         Nothing -> panic "lookupVarEnv_NF: Nothing"--{--@modifyVarEnv@: Look up a thing in the VarEnv,-then mash it with the modify function, and put it back.--}--modifyVarEnv mangle_fn env key-  = case (lookupVarEnv env key) of-      Nothing -> env-      Just xx -> extendVarEnv env key (mangle_fn xx)--modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a-modifyVarEnv_Directly mangle_fn env key-  = case (lookupUFM_Directly env key) of-      Nothing -> env-      Just xx -> addToUFM_Directly env key (mangle_fn xx)---- Deterministic VarEnv--- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need--- DVarEnv.---- | Deterministic Variable Environment-type DVarEnv elt = UniqDFM elt---- | Deterministic Identifier Environment-type DIdEnv elt = DVarEnv elt---- | Deterministic Type Variable Environment-type DTyVarEnv elt = DVarEnv elt--emptyDVarEnv :: DVarEnv a-emptyDVarEnv = emptyUDFM--dVarEnvElts :: DVarEnv a -> [a]-dVarEnvElts = eltsUDFM--mkDVarEnv :: [(Var, a)] -> DVarEnv a-mkDVarEnv = listToUDFM--extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a-extendDVarEnv = addToUDFM--minusDVarEnv :: DVarEnv a -> DVarEnv a' -> DVarEnv a-minusDVarEnv = minusUDFM--lookupDVarEnv :: DVarEnv a -> Var -> Maybe a-lookupDVarEnv = lookupUDFM--foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b-foldDVarEnv = foldUDFM--mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b-mapDVarEnv = mapUDFM--filterDVarEnv      :: (a -> Bool) -> DVarEnv a -> DVarEnv a-filterDVarEnv = filterUDFM--alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a-alterDVarEnv = alterUDFM--plusDVarEnv :: DVarEnv a -> DVarEnv a -> DVarEnv a-plusDVarEnv = plusUDFM--plusDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a-plusDVarEnv_C = plusUDFM_C--unitDVarEnv :: Var -> a -> DVarEnv a-unitDVarEnv = unitUDFM--delDVarEnv :: DVarEnv a -> Var -> DVarEnv a-delDVarEnv = delFromUDFM--delDVarEnvList :: DVarEnv a -> [Var] -> DVarEnv a-delDVarEnvList = delListFromUDFM--isEmptyDVarEnv :: DVarEnv a -> Bool-isEmptyDVarEnv = isNullUDFM--elemDVarEnv :: Var -> DVarEnv a -> Bool-elemDVarEnv = elemUDFM--extendDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> Var -> a -> DVarEnv a-extendDVarEnv_C = addToUDFM_C--modifyDVarEnv :: (a -> a) -> DVarEnv a -> Var -> DVarEnv a-modifyDVarEnv mangle_fn env key-  = case (lookupDVarEnv env key) of-      Nothing -> env-      Just xx -> extendDVarEnv env key (mangle_fn xx)--partitionDVarEnv :: (a -> Bool) -> DVarEnv a -> (DVarEnv a, DVarEnv a)-partitionDVarEnv = partitionUDFM--extendDVarEnvList :: DVarEnv a -> [(Var, a)] -> DVarEnv a-extendDVarEnvList = addListToUDFM--anyDVarEnv :: (a -> Bool) -> DVarEnv a -> Bool-anyDVarEnv = anyUDFM
− compiler/basicTypes/VarSet.hs 
@@ -1,354 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}--{-# LANGUAGE CPP #-}--module VarSet (-        -- * Var, Id and TyVar set types-        VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet,--        -- ** Manipulating these sets-        emptyVarSet, unitVarSet, mkVarSet,-        extendVarSet, extendVarSetList,-        elemVarSet, subVarSet,-        unionVarSet, unionVarSets, mapUnionVarSet,-        intersectVarSet, intersectsVarSet, disjointVarSet,-        isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,-        minusVarSet, filterVarSet, mapVarSet,-        anyVarSet, allVarSet,-        transCloVarSet, fixVarSet,-        lookupVarSet_Directly, lookupVarSet, lookupVarSetByName,-        sizeVarSet, seqVarSet,-        elemVarSetByKey, partitionVarSet,-        pluralVarSet, pprVarSet,-        nonDetFoldVarSet,--        -- * Deterministic Var set types-        DVarSet, DIdSet, DTyVarSet, DTyCoVarSet,--        -- ** Manipulating these sets-        emptyDVarSet, unitDVarSet, mkDVarSet,-        extendDVarSet, extendDVarSetList,-        elemDVarSet, dVarSetElems, subDVarSet,-        unionDVarSet, unionDVarSets, mapUnionDVarSet,-        intersectDVarSet, dVarSetIntersectVarSet,-        intersectsDVarSet, disjointDVarSet,-        isEmptyDVarSet, delDVarSet, delDVarSetList,-        minusDVarSet, foldDVarSet, filterDVarSet, mapDVarSet,-        dVarSetMinusVarSet, anyDVarSet, allDVarSet,-        transCloDVarSet,-        sizeDVarSet, seqDVarSet,-        partitionDVarSet,-        dVarSetToVarSet,-    ) where--#include "HsVersions.h"--import GhcPrelude--import Var      ( Var, TyVar, CoVar, TyCoVar, Id )-import Unique-import Name     ( Name )-import UniqSet-import UniqDSet-import UniqFM( disjointUFM, pluralUFM, pprUFM )-import UniqDFM( disjointUDFM, udfmToUfm, anyUDFM, allUDFM )-import Outputable (SDoc)---- | A non-deterministic Variable Set------ A non-deterministic set of variables.--- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not--- deterministic and why it matters. Use DVarSet if the set eventually--- gets converted into a list or folded over in a way where the order--- changes the generated code, for example when abstracting variables.-type VarSet       = UniqSet Var---- | Identifier Set-type IdSet        = UniqSet Id---- | Type Variable Set-type TyVarSet     = UniqSet TyVar---- | Coercion Variable Set-type CoVarSet     = UniqSet CoVar---- | Type or Coercion Variable Set-type TyCoVarSet   = UniqSet TyCoVar--emptyVarSet     :: VarSet-intersectVarSet :: VarSet -> VarSet -> VarSet-unionVarSet     :: VarSet -> VarSet -> VarSet-unionVarSets    :: [VarSet] -> VarSet--mapUnionVarSet  :: (a -> VarSet) -> [a] -> VarSet--- ^ map the function over the list, and union the results--unitVarSet      :: Var -> VarSet-extendVarSet    :: VarSet -> Var -> VarSet-extendVarSetList:: VarSet -> [Var] -> VarSet-elemVarSet      :: Var -> VarSet -> Bool-delVarSet       :: VarSet -> Var -> VarSet-delVarSetList   :: VarSet -> [Var] -> VarSet-minusVarSet     :: VarSet -> VarSet -> VarSet-isEmptyVarSet   :: VarSet -> Bool-mkVarSet        :: [Var] -> VarSet-lookupVarSet_Directly :: VarSet -> Unique -> Maybe Var-lookupVarSet    :: VarSet -> Var -> Maybe Var-                        -- Returns the set element, which may be-                        -- (==) to the argument, but not the same as-lookupVarSetByName :: VarSet -> Name -> Maybe Var-sizeVarSet      :: VarSet -> Int-filterVarSet    :: (Var -> Bool) -> VarSet -> VarSet--delVarSetByKey  :: VarSet -> Unique -> VarSet-elemVarSetByKey :: Unique -> VarSet -> Bool-partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet)--emptyVarSet     = emptyUniqSet-unitVarSet      = unitUniqSet-extendVarSet    = addOneToUniqSet-extendVarSetList= addListToUniqSet-intersectVarSet = intersectUniqSets--intersectsVarSet:: VarSet -> VarSet -> Bool     -- True if non-empty intersection-disjointVarSet  :: VarSet -> VarSet -> Bool     -- True if empty intersection-subVarSet       :: VarSet -> VarSet -> Bool     -- True if first arg is subset of second-        -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty;-        -- ditto disjointVarSet, subVarSet--unionVarSet     = unionUniqSets-unionVarSets    = unionManyUniqSets-elemVarSet      = elementOfUniqSet-minusVarSet     = minusUniqSet-delVarSet       = delOneFromUniqSet-delVarSetList   = delListFromUniqSet-isEmptyVarSet   = isEmptyUniqSet-mkVarSet        = mkUniqSet-lookupVarSet_Directly = lookupUniqSet_Directly-lookupVarSet    = lookupUniqSet-lookupVarSetByName = lookupUniqSet-sizeVarSet      = sizeUniqSet-filterVarSet    = filterUniqSet-delVarSetByKey  = delOneFromUniqSet_Directly-elemVarSetByKey = elemUniqSet_Directly-partitionVarSet = partitionUniqSet--mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs---- See comments with type signatures-intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2)-disjointVarSet   s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2)-subVarSet        s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2)--anyVarSet :: (Var -> Bool) -> VarSet -> Bool-anyVarSet = uniqSetAny--allVarSet :: (Var -> Bool) -> VarSet -> Bool-allVarSet = uniqSetAll--mapVarSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b-mapVarSet = mapUniqSet--nonDetFoldVarSet :: (Var -> a -> a) -> a -> VarSet -> a-nonDetFoldVarSet = nonDetFoldUniqSet--fixVarSet :: (VarSet -> VarSet)   -- Map the current set to a new set-          -> VarSet -> VarSet--- (fixVarSet f s) repeatedly applies f to the set s,--- until it reaches a fixed point.-fixVarSet fn vars-  | new_vars `subVarSet` vars = vars-  | otherwise                 = fixVarSet fn new_vars-  where-    new_vars = fn vars--transCloVarSet :: (VarSet -> VarSet)-                  -- Map some variables in the set to-                  -- extra variables that should be in it-               -> VarSet -> VarSet--- (transCloVarSet f s) repeatedly applies f to new candidates, adding any--- new variables to s that it finds thereby, until it reaches a fixed point.------ The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet)--- for efficiency, so that the test can be batched up.--- It's essential that fn will work fine if given new candidates--- one at a time; ie  fn {v1,v2} = fn v1 `union` fn v2--- Use fixVarSet if the function needs to see the whole set all at once-transCloVarSet fn seeds-  = go seeds seeds-  where-    go :: VarSet  -- Accumulating result-       -> VarSet  -- Work-list; un-processed subset of accumulating result-       -> VarSet-    -- Specification: go acc vs = acc `union` transClo fn vs--    go acc candidates-       | isEmptyVarSet new_vs = acc-       | otherwise            = go (acc `unionVarSet` new_vs) new_vs-       where-         new_vs = fn candidates `minusVarSet` acc--seqVarSet :: VarSet -> ()-seqVarSet s = sizeVarSet s `seq` ()---- | Determines the pluralisation suffix appropriate for the length of a set--- in the same way that plural from Outputable does for lists.-pluralVarSet :: VarSet -> SDoc-pluralVarSet = pluralUFM . getUniqSet---- | Pretty-print a non-deterministic set.--- The order of variables is non-deterministic and for pretty-printing that--- shouldn't be a problem.--- Having this function helps contain the non-determinism created with--- nonDetEltsUFM.--- Passing a list to the pretty-printing function allows the caller--- to decide on the order of Vars (eg. toposort them) without them having--- to use nonDetEltsUFM at the call site. This prevents from let-binding--- non-deterministically ordered lists and reusing them where determinism--- matters.-pprVarSet :: VarSet          -- ^ The things to be pretty printed-          -> ([Var] -> SDoc) -- ^ The pretty printing function to use on the-                             -- elements-          -> SDoc            -- ^ 'SDoc' where the things have been pretty-                             -- printed-pprVarSet = pprUFM . getUniqSet---- Deterministic VarSet--- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need--- DVarSet.---- | Deterministic Variable Set-type DVarSet     = UniqDSet Var---- | Deterministic Identifier Set-type DIdSet      = UniqDSet Id---- | Deterministic Type Variable Set-type DTyVarSet   = UniqDSet TyVar---- | Deterministic Type or Coercion Variable Set-type DTyCoVarSet = UniqDSet TyCoVar--emptyDVarSet :: DVarSet-emptyDVarSet = emptyUniqDSet--unitDVarSet :: Var -> DVarSet-unitDVarSet = unitUniqDSet--mkDVarSet :: [Var] -> DVarSet-mkDVarSet = mkUniqDSet---- The new element always goes to the right of existing ones.-extendDVarSet :: DVarSet -> Var -> DVarSet-extendDVarSet = addOneToUniqDSet--elemDVarSet :: Var -> DVarSet -> Bool-elemDVarSet = elementOfUniqDSet--dVarSetElems :: DVarSet -> [Var]-dVarSetElems = uniqDSetToList--subDVarSet :: DVarSet -> DVarSet -> Bool-subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2)--unionDVarSet :: DVarSet -> DVarSet -> DVarSet-unionDVarSet = unionUniqDSets--unionDVarSets :: [DVarSet] -> DVarSet-unionDVarSets = unionManyUniqDSets---- | Map the function over the list, and union the results-mapUnionDVarSet  :: (a -> DVarSet) -> [a] -> DVarSet-mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs--intersectDVarSet :: DVarSet -> DVarSet -> DVarSet-intersectDVarSet = intersectUniqDSets--dVarSetIntersectVarSet :: DVarSet -> VarSet -> DVarSet-dVarSetIntersectVarSet = uniqDSetIntersectUniqSet---- | True if empty intersection-disjointDVarSet :: DVarSet -> DVarSet -> Bool-disjointDVarSet s1 s2 = disjointUDFM (getUniqDSet s1) (getUniqDSet s2)---- | True if non-empty intersection-intersectsDVarSet :: DVarSet -> DVarSet -> Bool-intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2)--isEmptyDVarSet :: DVarSet -> Bool-isEmptyDVarSet = isEmptyUniqDSet--delDVarSet :: DVarSet -> Var -> DVarSet-delDVarSet = delOneFromUniqDSet--minusDVarSet :: DVarSet -> DVarSet -> DVarSet-minusDVarSet = minusUniqDSet--dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet-dVarSetMinusVarSet = uniqDSetMinusUniqSet--foldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a-foldDVarSet = foldUniqDSet--anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool-anyDVarSet p = anyUDFM p . getUniqDSet--allDVarSet :: (Var -> Bool) -> DVarSet -> Bool-allDVarSet p = allUDFM p . getUniqDSet--mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b-mapDVarSet = mapUniqDSet--filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet-filterDVarSet = filterUniqDSet--sizeDVarSet :: DVarSet -> Int-sizeDVarSet = sizeUniqDSet---- | Partition DVarSet according to the predicate given-partitionDVarSet :: (Var -> Bool) -> DVarSet -> (DVarSet, DVarSet)-partitionDVarSet = partitionUniqDSet---- | Delete a list of variables from DVarSet-delDVarSetList :: DVarSet -> [Var] -> DVarSet-delDVarSetList = delListFromUniqDSet--seqDVarSet :: DVarSet -> ()-seqDVarSet s = sizeDVarSet s `seq` ()---- | Add a list of variables to DVarSet-extendDVarSetList :: DVarSet -> [Var] -> DVarSet-extendDVarSetList = addListToUniqDSet---- | Convert a DVarSet to a VarSet by forgetting the order of insertion-dVarSetToVarSet :: DVarSet -> VarSet-dVarSetToVarSet = unsafeUFMToUniqSet . udfmToUfm . getUniqDSet---- | transCloVarSet for DVarSet-transCloDVarSet :: (DVarSet -> DVarSet)-                  -- Map some variables in the set to-                  -- extra variables that should be in it-                -> DVarSet -> DVarSet--- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any--- new variables to s that it finds thereby, until it reaches a fixed point.------ The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet)--- for efficiency, so that the test can be batched up.--- It's essential that fn will work fine if given new candidates--- one at a time; ie  fn {v1,v2} = fn v1 `union` fn v2-transCloDVarSet fn seeds-  = go seeds seeds-  where-    go :: DVarSet  -- Accumulating result-       -> DVarSet  -- Work-list; un-processed subset of accumulating result-       -> DVarSet-    -- Specification: go acc vs = acc `union` transClo fn vs--    go acc candidates-       | isEmptyDVarSet new_vs = acc-       | otherwise            = go (acc `unionDVarSet` new_vs) new_vs-       where-         new_vs = fn candidates `minusDVarSet` acc
compiler/iface/BinFingerprint.hs view
@@ -14,7 +14,7 @@  import Fingerprint import Binary-import Name+import GHC.Types.Name import PlainPanic import Util
− compiler/main/Annotations.hs 
@@ -1,148 +0,0 @@--- |--- Support for source code annotation feature of GHC. That is the ANN pragma.------ (c) The University of Glasgow 2006--- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998----{-# LANGUAGE DeriveFunctor #-}-module Annotations (-        -- * Main Annotation data types-        Annotation(..), AnnPayload,-        AnnTarget(..), CoreAnnTarget,-        getAnnTargetName_maybe,--        -- * AnnEnv for collecting and querying Annotations-        AnnEnv,-        mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv,-        findAnns, findAnnsByTypeRep,-        deserializeAnns-    ) where--import GhcPrelude--import Binary-import Module           ( Module-                        , ModuleEnv, emptyModuleEnv, extendModuleEnvWith-                        , plusModuleEnv_C, lookupWithDefaultModuleEnv-                        , mapModuleEnv )-import NameEnv-import Name-import Outputable-import GHC.Serialized--import Control.Monad-import Data.Maybe-import Data.Typeable-import Data.Word        ( Word8 )----- | Represents an annotation after it has been sufficiently desugared from--- it's initial form of 'HsDecls.AnnDecl'-data Annotation = Annotation {-        ann_target :: CoreAnnTarget,    -- ^ The target of the annotation-        ann_value  :: AnnPayload-    }--type AnnPayload = Serialized    -- ^ The "payload" of an annotation-                                --   allows recovery of its value at a given type,-                                --   and can be persisted to an interface file---- | An annotation target-data AnnTarget name-  = NamedTarget name          -- ^ We are annotating something with a name:-                              --      a type or identifier-  | ModuleTarget Module       -- ^ We are annotating a particular module-  deriving (Functor)---- | The kind of annotation target found in the middle end of the compiler-type CoreAnnTarget = AnnTarget Name---- | Get the 'name' of an annotation target if it exists.-getAnnTargetName_maybe :: AnnTarget name -> Maybe name-getAnnTargetName_maybe (NamedTarget nm) = Just nm-getAnnTargetName_maybe _                = Nothing--instance Outputable name => Outputable (AnnTarget name) where-    ppr (NamedTarget nm) = text "Named target" <+> ppr nm-    ppr (ModuleTarget mod) = text "Module target" <+> ppr mod--instance Binary name => Binary (AnnTarget name) where-    put_ bh (NamedTarget a) = do-        putByte bh 0-        put_ bh a-    put_ bh (ModuleTarget a) = do-        putByte bh 1-        put_ bh a-    get bh = do-        h <- getByte bh-        case h of-            0 -> liftM NamedTarget  $ get bh-            _ -> liftM ModuleTarget $ get bh--instance Outputable Annotation where-    ppr ann = ppr (ann_target ann)---- | A collection of annotations-data AnnEnv = MkAnnEnv { ann_mod_env :: !(ModuleEnv [AnnPayload])-                       , ann_name_env :: !(NameEnv [AnnPayload])-                       }---- | An empty annotation environment.-emptyAnnEnv :: AnnEnv-emptyAnnEnv = MkAnnEnv emptyModuleEnv emptyNameEnv---- | Construct a new annotation environment that contains the list of--- annotations provided.-mkAnnEnv :: [Annotation] -> AnnEnv-mkAnnEnv = extendAnnEnvList emptyAnnEnv---- | Add the given annotation to the environment.-extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv-extendAnnEnvList env =-  foldl' extendAnnEnv env--extendAnnEnv :: AnnEnv -> Annotation -> AnnEnv-extendAnnEnv (MkAnnEnv mod_env name_env) (Annotation tgt payload) =-  case tgt of-    NamedTarget name -> MkAnnEnv mod_env (extendNameEnv_C (++) name_env name [payload])-    ModuleTarget mod -> MkAnnEnv (extendModuleEnvWith (++) mod_env mod [payload]) name_env---- | Union two annotation environments.-plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv-plusAnnEnv a b =-  MkAnnEnv { ann_mod_env = plusModuleEnv_C (++) (ann_mod_env a) (ann_mod_env b)-           , ann_name_env = plusNameEnv_C (++) (ann_name_env a) (ann_name_env b)-           }---- | Find the annotations attached to the given target as 'Typeable'---   values of your choice. If no deserializer is specified,---   only transient annotations will be returned.-findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]-findAnns deserialize env-  = mapMaybe (fromSerialized deserialize) . findAnnPayloads env---- | Find the annotations attached to the given target as 'Typeable'---   values of your choice. If no deserializer is specified,---   only transient annotations will be returned.-findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]]-findAnnsByTypeRep env target tyrep-  = [ ws | Serialized tyrep' ws <- findAnnPayloads env target-    , tyrep' == tyrep ]---- | Find payloads for the given 'CoreAnnTarget' in an 'AnnEnv'.-findAnnPayloads :: AnnEnv -> CoreAnnTarget -> [AnnPayload]-findAnnPayloads env target =-  case target of-    ModuleTarget mod -> lookupWithDefaultModuleEnv (ann_mod_env env) [] mod-    NamedTarget name -> fromMaybe [] $ lookupNameEnv (ann_name_env env) name---- | Deserialize all annotations of a given type. This happens lazily, that is---   no deserialization will take place until the [a] is actually demanded and---   the [a] can also be empty (the UniqFM is not filtered).-deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])-deserializeAnns deserialize env-  = ( mapModuleEnv deserAnns (ann_mod_env env)-    , mapNameEnv deserAnns (ann_name_env env)-    )-  where deserAnns = mapMaybe (fromSerialized deserialize)-
compiler/main/Constants.hs view
@@ -42,5 +42,9 @@ fLOAT_SIZE :: Int fLOAT_SIZE = 4 +-- Size of double in bytes.+dOUBLE_SIZE :: Int+dOUBLE_SIZE = 8+ tARGET_MAX_CHAR :: Int tARGET_MAX_CHAR = 0x10ffff
compiler/main/ErrUtils.hs view
@@ -71,7 +71,7 @@ import Outputable import Panic import qualified PprColour as Col-import SrcLoc+import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session import FastString (unpackFS) import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)@@ -764,7 +764,7 @@     where whenPrintTimings = liftIO . when (prtimings == PrintTimings)           eventBegins dflags w = do             whenPrintTimings $ traceMarkerIO (eventBeginsDoc dflags w)-            liftIO $ traceEventIO (eventEndsDoc dflags w)+            liftIO $ traceEventIO (eventBeginsDoc dflags w)           eventEnds dflags w = do             whenPrintTimings $ traceMarkerIO (eventEndsDoc dflags w)             liftIO $ traceEventIO (eventEndsDoc dflags w)
compiler/main/ErrUtils.hs-boot view
@@ -4,7 +4,7 @@  import GhcPrelude import Outputable (SDoc, PprStyle )-import SrcLoc (SrcSpan)+import GHC.Types.SrcLoc (SrcSpan) import Json import {-# SOURCE #-} GHC.Driver.Session ( DynFlags )
compiler/main/HeaderInfo.hs view
@@ -28,10 +28,10 @@ import Lexer import FastString import GHC.Hs-import Module+import GHC.Types.Module import PrelNames import StringBuffer-import SrcLoc+import GHC.Types.SrcLoc import GHC.Driver.Session import ErrUtils import Util@@ -40,7 +40,7 @@ import Bag              ( emptyBag, listToBag, unitBag ) import MonadUtils import Exception-import BasicTypes+import GHC.Types.Basic import qualified GHC.LanguageExtensions as LangExt  import Control.Monad
compiler/main/SysTools/Terminal.hs view
@@ -32,20 +32,13 @@ stderrSupportsAnsiColors :: IO Bool stderrSupportsAnsiColors = do #if defined(MIN_VERSION_terminfo)-  queryTerminal stdError `andM` do-    (termSupportsColors <$> setupTermFromEnv)-      `catch` \ (_ :: SetupTermError) ->-        pure False-+    stderr_available <- queryTerminal stdError+    if stderr_available then+      fmap termSupportsColors setupTermFromEnv+        `catch` \ (_ :: SetupTermError) -> pure False+    else+      pure False   where--    andM :: Monad m => m Bool -> m Bool -> m Bool-    andM mx my = do-      x <- mx-      if x-        then my-        else pure x-     termSupportsColors :: Terminal -> Bool     termSupportsColors term = fromMaybe 0 (getCapability term termColors) > 0
compiler/main/UnitInfo.hs view
@@ -37,8 +37,8 @@  import FastString import Outputable-import Module-import Unique+import GHC.Types.Module as Module+import GHC.Types.Unique  -- ----------------------------------------------------------------------------- -- Our UnitInfo type is the InstalledPackageInfo from ghc-boot,@@ -58,7 +58,10 @@ --       other compact string types, e.g. plain ByteString or Text.  newtype SourcePackageId    = SourcePackageId    FastString deriving (Eq, Ord)-newtype PackageName        = PackageName        FastString deriving (Eq, Ord)+newtype PackageName = PackageName+   { unPackageName :: FastString+   }+   deriving (Eq, Ord)  instance BinaryStringRep SourcePackageId where   fromStringRep = SourcePackageId . mkFastStringByteString
compiler/parser/ApiAnnotation.hs view
@@ -15,9 +15,9 @@  import GhcPrelude -import RdrName+import GHC.Types.Name.Reader import Outputable-import SrcLoc+import GHC.Types.SrcLoc import qualified Data.Map as Map import Data.Data
compiler/parser/HaddockUtils.hs view
@@ -5,7 +5,7 @@ import GhcPrelude  import GHC.Hs-import SrcLoc+import GHC.Types.SrcLoc  import Control.Monad
compiler/parser/RdrHsSyn.hs view
@@ -104,24 +104,24 @@  import GhcPrelude import GHC.Hs           -- Lots of it-import TyCon            ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )-import DataCon          ( DataCon, dataConTyCon )-import ConLike          ( ConLike(..) )-import CoAxiom          ( Role, fsFromRole )-import RdrName-import Name-import BasicTypes+import GHC.Core.TyCon          ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )+import GHC.Core.DataCon        ( DataCon, dataConTyCon )+import GHC.Core.ConLike        ( ConLike(..) )+import GHC.Core.Coercion.Axiom ( Role, fsFromRole )+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.Basic import Lexer-import Lexeme           ( isLexCon )-import Type             ( TyThing(..), funTyCon )+import GHC.Utils.Lexeme ( isLexCon )+import GHC.Core.Type    ( TyThing(..), funTyCon ) import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,                           nilDataConName, nilDataConKey,                           listTyConName, listTyConKey, eqTyCon_RDR,                           tupleTyConName, cTupleTyConNameArity_maybe )-import ForeignCall+import GHC.Types.ForeignCall import PrelNames        ( allNameStrings )-import SrcLoc-import Unique           ( hasKey )+import GHC.Types.SrcLoc+import GHC.Types.Unique ( hasKey ) import OrdList          ( OrdList, fromOL ) import Bag              ( emptyBag, consBag ) import Outputable@@ -2548,7 +2548,7 @@ -- The (Maybe Activation) is because the user can omit -- the activation spec (and usually does) mkInlinePragma src (inl, match_info) mb_act-  = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes+  = InlinePragma { inl_src = src -- Note [Pragma source text] in GHC.Types.Basic                  , inl_inline = inl                  , inl_sat    = Nothing                  , inl_act    = act
− compiler/prelude/ForeignCall.hs 
@@ -1,348 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[Foreign]{Foreign calls}--}--{-# LANGUAGE DeriveDataTypeable #-}--module ForeignCall (-        ForeignCall(..), isSafeForeignCall,-        Safety(..), playSafe, playInterruptible,--        CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,-        CCallSpec(..),-        CCallTarget(..), isDynamicTarget,-        CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,--        Header(..), CType(..),-    ) where--import GhcPrelude--import FastString-import Binary-import Outputable-import Module-import BasicTypes ( SourceText, pprWithSourceText )--import Data.Char-import Data.Data--{--************************************************************************-*                                                                      *-\subsubsection{Data types}-*                                                                      *-************************************************************************--}--newtype ForeignCall = CCall CCallSpec-  deriving Eq--isSafeForeignCall :: ForeignCall -> Bool-isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe---- We may need more clues to distinguish foreign calls--- but this simple printer will do for now-instance Outputable ForeignCall where-  ppr (CCall cc)  = ppr cc--data Safety-  = PlaySafe            -- Might invoke Haskell GC, or do a call back, or-                        -- switch threads, etc.  So make sure things are-                        -- tidy before the call. Additionally, in the threaded-                        -- RTS we arrange for the external call to be executed-                        -- by a separate OS thread, i.e., _concurrently_ to the-                        -- execution of other Haskell threads.--  | PlayInterruptible   -- Like PlaySafe, but additionally-                        -- the worker thread running this foreign call may-                        -- be unceremoniously killed, so it must be scheduled-                        -- on an unbound thread.--  | PlayRisky           -- None of the above can happen; the call will return-                        -- without interacting with the runtime system at all-  deriving ( Eq, Show, Data )-        -- Show used just for Show Lex.Token, I think--instance Outputable Safety where-  ppr PlaySafe = text "safe"-  ppr PlayInterruptible = text "interruptible"-  ppr PlayRisky = text "unsafe"--playSafe :: Safety -> Bool-playSafe PlaySafe = True-playSafe PlayInterruptible = True-playSafe PlayRisky = False--playInterruptible :: Safety -> Bool-playInterruptible PlayInterruptible = True-playInterruptible _ = False--{--************************************************************************-*                                                                      *-\subsubsection{Calling C}-*                                                                      *-************************************************************************--}--data CExportSpec-  = CExportStatic               -- foreign export ccall foo :: ty-        SourceText              -- of the CLabelString.-                                -- See note [Pragma source text] in BasicTypes-        CLabelString            -- C Name of exported function-        CCallConv-  deriving Data--data CCallSpec-  =  CCallSpec  CCallTarget     -- What to call-                CCallConv       -- Calling convention to use.-                Safety-  deriving( Eq )---- The call target:---- | How to call a particular function in C-land.-data CCallTarget-  -- An "unboxed" ccall# to named function in a particular package.-  = StaticTarget-        SourceText                -- of the CLabelString.-                                  -- See note [Pragma source text] in BasicTypes-        CLabelString                    -- C-land name of label.--        (Maybe UnitId)              -- What package the function is in.-                                        -- If Nothing, then it's taken to be in the current package.-                                        -- Note: This information is only used for PrimCalls on Windows.-                                        --       See CLabel.labelDynamic and CoreToStg.coreToStgApp-                                        --       for the difference in representation between PrimCalls-                                        --       and ForeignCalls. If the CCallTarget is representing-                                        --       a regular ForeignCall then it's safe to set this to Nothing.--  -- The first argument of the import is the name of a function pointer (an Addr#).-  --    Used when importing a label as "foreign import ccall "dynamic" ..."-        Bool                            -- True => really a function-                                        -- False => a value; only-                                        -- allowed in CAPI imports-  | DynamicTarget--  deriving( Eq, Data )--isDynamicTarget :: CCallTarget -> Bool-isDynamicTarget DynamicTarget = True-isDynamicTarget _             = False--{--Stuff to do with calling convention:--ccall:          Caller allocates parameters, *and* deallocates them.--stdcall:        Caller allocates parameters, callee deallocates.-                Function name has @N after it, where N is number of arg bytes-                e.g.  _Foo@8. This convention is x86 (win32) specific.--See: http://www.programmersheaven.com/2/Calling-conventions--}---- any changes here should be replicated in  the CallConv type in template haskell-data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv-  deriving (Eq, Data)--instance Outputable CCallConv where-  ppr StdCallConv = text "stdcall"-  ppr CCallConv   = text "ccall"-  ppr CApiConv    = text "capi"-  ppr PrimCallConv = text "prim"-  ppr JavaScriptCallConv = text "javascript"--defaultCCallConv :: CCallConv-defaultCCallConv = CCallConv--ccallConvToInt :: CCallConv -> Int-ccallConvToInt StdCallConv = 0-ccallConvToInt CCallConv   = 1-ccallConvToInt CApiConv    = panic "ccallConvToInt CApiConv"-ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"-ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv"--{--Generate the gcc attribute corresponding to the given-calling convention (used by PprAbsC):--}--ccallConvAttribute :: CCallConv -> SDoc-ccallConvAttribute StdCallConv       = text "__attribute__((__stdcall__))"-ccallConvAttribute CCallConv         = empty-ccallConvAttribute CApiConv          = empty-ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"-ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv"--type CLabelString = FastString          -- A C label, completely unencoded--pprCLabelString :: CLabelString -> SDoc-pprCLabelString lbl = ftext lbl--isCLabelString :: CLabelString -> Bool  -- Checks to see if this is a valid C label-isCLabelString lbl-  = all ok (unpackFS lbl)-  where-    ok c = isAlphaNum c || c == '_' || c == '.'-        -- The '.' appears in e.g. "foo.so" in the-        -- module part of a ExtName.  Maybe it should be separate---- Printing into C files:--instance Outputable CExportSpec where-  ppr (CExportStatic _ str _) = pprCLabelString str--instance Outputable CCallSpec where-  ppr (CCallSpec fun cconv safety)-    = hcat [ whenPprDebug callconv, ppr_fun fun ]-    where-      callconv = text "{-" <> ppr cconv <> text "-}"--      gc_suf | playSafe safety = text "_GC"-             | otherwise       = empty--      ppr_fun (StaticTarget st _fn mPkgId isFun)-        = text (if isFun then "__pkg_ccall"-                         else "__pkg_ccall_value")-       <> gc_suf-       <+> (case mPkgId of-            Nothing -> empty-            Just pkgId -> ppr pkgId)-       <+> (pprWithSourceText st empty)--      ppr_fun DynamicTarget-        = text "__dyn_ccall" <> gc_suf <+> text "\"\""---- The filename for a C header file--- Note [Pragma source text] in BasicTypes-data Header = Header SourceText FastString-    deriving (Eq, Data)--instance Outputable Header where-    ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h)---- | A C type, used in CAPI FFI calls------  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@,---        'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal',---        'ApiAnnotation.AnnClose' @'\#-}'@,---- For details on above see note [Api annotations] in ApiAnnotation-data CType = CType SourceText -- Note [Pragma source text] in BasicTypes-                   (Maybe Header) -- header to include for this type-                   (SourceText,FastString) -- the type itself-    deriving (Eq, Data)--instance Outputable CType where-    ppr (CType stp mh (stct,ct))-      = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc-        <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}"-        where hDoc = case mh of-                     Nothing -> empty-                     Just h -> ppr h--{--************************************************************************-*                                                                      *-\subsubsection{Misc}-*                                                                      *-************************************************************************--}--instance Binary ForeignCall where-    put_ bh (CCall aa) = put_ bh aa-    get bh = do aa <- get bh; return (CCall aa)--instance Binary Safety where-    put_ bh PlaySafe = do-            putByte bh 0-    put_ bh PlayInterruptible = do-            putByte bh 1-    put_ bh PlayRisky = do-            putByte bh 2-    get bh = do-            h <- getByte bh-            case h of-              0 -> do return PlaySafe-              1 -> do return PlayInterruptible-              _ -> do return PlayRisky--instance Binary CExportSpec where-    put_ bh (CExportStatic ss aa ab) = do-            put_ bh ss-            put_ bh aa-            put_ bh ab-    get bh = do-          ss <- get bh-          aa <- get bh-          ab <- get bh-          return (CExportStatic ss aa ab)--instance Binary CCallSpec where-    put_ bh (CCallSpec aa ab ac) = do-            put_ bh aa-            put_ bh ab-            put_ bh ac-    get bh = do-          aa <- get bh-          ab <- get bh-          ac <- get bh-          return (CCallSpec aa ab ac)--instance Binary CCallTarget where-    put_ bh (StaticTarget ss aa ab ac) = do-            putByte bh 0-            put_ bh ss-            put_ bh aa-            put_ bh ab-            put_ bh ac-    put_ bh DynamicTarget = do-            putByte bh 1-    get bh = do-            h <- getByte bh-            case h of-              0 -> do ss <- get bh-                      aa <- get bh-                      ab <- get bh-                      ac <- get bh-                      return (StaticTarget ss aa ab ac)-              _ -> do return DynamicTarget--instance Binary CCallConv where-    put_ bh CCallConv = do-            putByte bh 0-    put_ bh StdCallConv = do-            putByte bh 1-    put_ bh PrimCallConv = do-            putByte bh 2-    put_ bh CApiConv = do-            putByte bh 3-    put_ bh JavaScriptCallConv = do-            putByte bh 4-    get bh = do-            h <- getByte bh-            case h of-              0 -> do return CCallConv-              1 -> do return StdCallConv-              2 -> do return PrimCallConv-              3 -> do return CApiConv-              _ -> do return JavaScriptCallConv--instance Binary CType where-    put_ bh (CType s mh fs) = do put_ bh s-                                 put_ bh mh-                                 put_ bh fs-    get bh = do s  <- get bh-                mh <- get bh-                fs <- get bh-                return (CType s mh fs)--instance Binary Header where-    put_ bh (Header s h) = put_ bh s >> put_ bh h-    get bh = do s <- get bh-                h <- get bh-                return (Header s h)
compiler/prelude/KnownUniques.hs view
@@ -29,13 +29,13 @@ import GhcPrelude  import TysWiredIn-import TyCon-import DataCon-import Id-import BasicTypes+import GHC.Core.TyCon+import GHC.Core.DataCon+import GHC.Types.Id+import GHC.Types.Basic import Outputable-import Unique-import Name+import GHC.Types.Unique+import GHC.Types.Name import Util  import Data.Bits@@ -65,7 +65,7 @@ -- tag (used to identify the sum's TypeRep binding). -- -- This layout is chosen to remain compatible with the usual unique allocation--- for wired-in data constructors described in Unique.hs+-- for wired-in data constructors described in GHC.Types.Unique -- -- TyCon for sum of arity k: --   00000000 kkkkkkkk 11111100
compiler/prelude/KnownUniques.hs-boot view
@@ -1,9 +1,9 @@ module KnownUniques where  import GhcPrelude-import Unique-import Name-import BasicTypes+import GHC.Types.Unique+import GHC.Types.Name+import GHC.Types.Basic  -- Needed by TysWiredIn knownUniqueName :: Unique -> Maybe Name
compiler/prelude/PrelNames.hs view
@@ -139,7 +139,7 @@ When GHC reads the package data base, it (internally only) pretends it has UnitId `integer-wired-in` instead of the actual UnitId (which includes the version number); just like for `base` and other packages, as described in-Note [Wired-in packages] in Module. This is done in Packages.findWiredInPackages.+Note [Wired-in packages] in GHC.Types.Module. This is done in Packages.findWiredInPackages. -}  {-# LANGUAGE CPP #-}@@ -160,12 +160,12 @@  import GhcPrelude -import Module-import OccName-import RdrName-import Unique-import Name-import SrcLoc+import GHC.Types.Module+import GHC.Types.Name.Occurrence+import GHC.Types.Name.Reader+import GHC.Types.Unique+import GHC.Types.Name+import GHC.Types.SrcLoc import FastString  {-@@ -803,9 +803,6 @@ showCommaSpace_RDR      = varQual_RDR gHC_SHOW (fsLit "showCommaSpace") showParen_RDR           = varQual_RDR gHC_SHOW (fsLit "showParen") -undefined_RDR :: RdrName-undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")- error_RDR :: RdrName error_RDR = varQual_RDR gHC_ERR (fsLit "error") @@ -1592,17 +1589,8 @@ showClassKey            = mkPreludeClassUnique 17 ixClassKey              = mkPreludeClassUnique 18 -typeableClassKey, typeable1ClassKey, typeable2ClassKey, typeable3ClassKey,-    typeable4ClassKey, typeable5ClassKey, typeable6ClassKey, typeable7ClassKey-    :: Unique+typeableClassKey :: Unique typeableClassKey        = mkPreludeClassUnique 20-typeable1ClassKey       = mkPreludeClassUnique 21-typeable2ClassKey       = mkPreludeClassUnique 22-typeable3ClassKey       = mkPreludeClassUnique 23-typeable4ClassKey       = mkPreludeClassUnique 24-typeable5ClassKey       = mkPreludeClassUnique 25-typeable6ClassKey       = mkPreludeClassUnique 26-typeable7ClassKey       = mkPreludeClassUnique 27  monadFixClassKey :: Unique monadFixClassKey        = mkPreludeClassUnique 28@@ -1768,10 +1756,6 @@ tVarPrimTyConKey                        = mkPreludeTyConUnique 79 compactPrimTyConKey                     = mkPreludeTyConUnique 80 --- dotnet interop-objectTyConKey :: Unique-objectTyConKey                          = mkPreludeTyConUnique 83- eitherTyConKey :: Unique eitherTyConKey                          = mkPreludeTyConUnique 84 @@ -2245,18 +2229,6 @@ rationalToFloatIdKey, rationalToDoubleIdKey :: Unique rationalToFloatIdKey   = mkPreludeMiscIdUnique 130 rationalToDoubleIdKey  = mkPreludeMiscIdUnique 131---- dotnet interop-unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey,-    unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique-unmarshalObjectIdKey          = mkPreludeMiscIdUnique 150-marshalObjectIdKey            = mkPreludeMiscIdUnique 151-marshalStringIdKey            = mkPreludeMiscIdUnique 152-unmarshalStringIdKey          = mkPreludeMiscIdUnique 153-checkDotnetResNameIdKey       = mkPreludeMiscIdUnique 154--undefinedKey :: Unique-undefinedKey                  = mkPreludeMiscIdUnique 155  magicDictKey :: Unique magicDictKey                  = mkPreludeMiscIdUnique 156
compiler/prelude/PrelNames.hs-boot view
@@ -1,7 +1,7 @@ module PrelNames where -import Module-import Unique+import GHC.Types.Module+import GHC.Types.Unique  mAIN :: Module liftedTypeKindTyConKey :: Unique
− compiler/prelude/PrelRules.hs 
@@ -1,2256 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[ConFold]{Constant Folder}--Conceptually, constant folding should be parameterized with the kind-of target machine to get identical behaviour during compilation time-and runtime. We cheat a little bit here...--ToDo:-   check boundaries before folding, e.g. we can fold the Float addition-   (i1 + i2) only if it results in a valid Float.--}--{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards,-    DeriveFunctor #-}-{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}--module PrelRules-   ( primOpRules-   , builtinRules-   , caseRules-   )-where--#include "HsVersions.h"--import GhcPrelude--import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId )--import GHC.Core-import GHC.Core.Make-import Id-import Literal-import GHC.Core.SimpleOpt ( exprIsLiteral_maybe )-import PrimOp             ( PrimOp(..), tagToEnumKey )-import TysWiredIn-import TysPrim-import TyCon       ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon-                   , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons-                   , tyConFamilySize )-import DataCon     ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )-import GHC.Core.Utils  ( cheapEqExpr, cheapEqExpr', exprIsHNF, exprType-                       , stripTicksTop, stripTicksTopT, mkTicks )-import GHC.Core.Unfold ( exprIsConApp_maybe )-import Type-import OccName     ( occNameFS )-import PrelNames-import Maybes      ( orElse )-import Name        ( Name, nameOccName )-import Outputable-import FastString-import BasicTypes-import GHC.Driver.Session-import GHC.Platform-import Util-import Coercion     (mkUnbranchedAxInstCo,mkSymCo,Role(..))--import Control.Applicative ( Alternative(..) )--import Control.Monad-import qualified Control.Monad.Fail as MonadFail-import Data.Bits as Bits-import qualified Data.ByteString as BS-import Data.Int-import Data.Ratio-import Data.Word--{--Note [Constant folding]-~~~~~~~~~~~~~~~~~~~~~~~-primOpRules generates a rewrite rule for each primop-These rules do what is often called "constant folding"-E.g. the rules for +# might say-        4 +# 5 = 9-Well, of course you'd need a lot of rules if you did it-like that, so we use a BuiltinRule instead, so that we-can match in any two literal values.  So the rule is really-more like-        (Lit x) +# (Lit y) = Lit (x+#y)-where the (+#) on the rhs is done at compile time--That is why these rules are built in here.--}--primOpRules :: Name -> PrimOp -> Maybe CoreRule-    -- ToDo: something for integer-shift ops?-    --       NotOp-primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ]-primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ]---- Int operations-primOpRules nm IntAddOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))-                                               , identityDynFlags zeroi-                                               , numFoldingRules IntAddOp intPrimOps-                                               ]-primOpRules nm IntSubOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))-                                               , rightIdentityDynFlags zeroi-                                               , equalArgs >> retLit zeroi-                                               , numFoldingRules IntSubOp intPrimOps-                                               ]-primOpRules nm IntAddCOp   = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+))-                                               , identityCDynFlags zeroi ]-primOpRules nm IntSubCOp   = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-))-                                               , rightIdentityCDynFlags zeroi-                                               , equalArgs >> retLitNoC zeroi ]-primOpRules nm IntMulOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))-                                               , zeroElem zeroi-                                               , identityDynFlags onei-                                               , numFoldingRules IntMulOp intPrimOps-                                               ]-primOpRules nm IntQuotOp   = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)-                                               , leftZero zeroi-                                               , rightIdentityDynFlags onei-                                               , equalArgs >> retLit onei ]-primOpRules nm IntRemOp    = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)-                                               , leftZero zeroi-                                               , do l <- getLiteral 1-                                                    dflags <- getDynFlags-                                                    guard (l == onei dflags)-                                                    retLit zeroi-                                               , equalArgs >> retLit zeroi-                                               , equalArgs >> retLit zeroi ]-primOpRules nm AndIOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.))-                                               , idempotent-                                               , zeroElem zeroi ]-primOpRules nm OrIOp       = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))-                                               , idempotent-                                               , identityDynFlags zeroi ]-primOpRules nm XorIOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor)-                                               , identityDynFlags zeroi-                                               , equalArgs >> retLit zeroi ]-primOpRules nm NotIOp      = mkPrimOpRule nm 1 [ unaryLit complementOp-                                               , inversePrimOp NotIOp ]-primOpRules nm IntNegOp    = mkPrimOpRule nm 1 [ unaryLit negOp-                                               , inversePrimOp IntNegOp ]-primOpRules nm ISllOp      = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL)-                                               , rightIdentityDynFlags zeroi ]-primOpRules nm ISraOp      = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR)-                                               , rightIdentityDynFlags zeroi ]-primOpRules nm ISrlOp      = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical-                                               , rightIdentityDynFlags zeroi ]---- Word operations-primOpRules nm WordAddOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))-                                               , identityDynFlags zerow-                                               , numFoldingRules WordAddOp wordPrimOps-                                               ]-primOpRules nm WordSubOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))-                                               , rightIdentityDynFlags zerow-                                               , equalArgs >> retLit zerow-                                               , numFoldingRules WordSubOp wordPrimOps-                                               ]-primOpRules nm WordAddCOp  = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+))-                                               , identityCDynFlags zerow ]-primOpRules nm WordSubCOp  = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-))-                                               , rightIdentityCDynFlags zerow-                                               , equalArgs >> retLitNoC zerow ]-primOpRules nm WordMulOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))-                                               , identityDynFlags onew-                                               , numFoldingRules WordMulOp wordPrimOps-                                               ]-primOpRules nm WordQuotOp  = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)-                                               , rightIdentityDynFlags onew ]-primOpRules nm WordRemOp   = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)-                                               , leftZero zerow-                                               , do l <- getLiteral 1-                                                    dflags <- getDynFlags-                                                    guard (l == onew dflags)-                                                    retLit zerow-                                               , equalArgs >> retLit zerow ]-primOpRules nm AndOp       = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))-                                               , idempotent-                                               , zeroElem zerow ]-primOpRules nm OrOp        = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))-                                               , idempotent-                                               , identityDynFlags zerow ]-primOpRules nm XorOp       = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)-                                               , identityDynFlags zerow-                                               , equalArgs >> retLit zerow ]-primOpRules nm NotOp       = mkPrimOpRule nm 1 [ unaryLit complementOp-                                               , inversePrimOp NotOp ]-primOpRules nm SllOp       = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ]-primOpRules nm SrlOp       = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ]---- coercions-primOpRules nm Word2IntOp     = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit-                                                  , inversePrimOp Int2WordOp ]-primOpRules nm Int2WordOp     = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit-                                                  , inversePrimOp Word2IntOp ]-primOpRules nm Narrow8IntOp   = mkPrimOpRule nm 1 [ liftLit narrow8IntLit-                                                  , subsumedByPrimOp Narrow8IntOp-                                                  , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp-                                                  , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp-                                                  , narrowSubsumesAnd AndIOp Narrow8IntOp 8 ]-primOpRules nm Narrow16IntOp  = mkPrimOpRule nm 1 [ liftLit narrow16IntLit-                                                  , subsumedByPrimOp Narrow8IntOp-                                                  , subsumedByPrimOp Narrow16IntOp-                                                  , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp-                                                  , narrowSubsumesAnd AndIOp Narrow16IntOp 16 ]-primOpRules nm Narrow32IntOp  = mkPrimOpRule nm 1 [ liftLit narrow32IntLit-                                                  , subsumedByPrimOp Narrow8IntOp-                                                  , subsumedByPrimOp Narrow16IntOp-                                                  , subsumedByPrimOp Narrow32IntOp-                                                  , removeOp32-                                                  , narrowSubsumesAnd AndIOp Narrow32IntOp 32 ]-primOpRules nm Narrow8WordOp  = mkPrimOpRule nm 1 [ liftLit narrow8WordLit-                                                  , subsumedByPrimOp Narrow8WordOp-                                                  , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp-                                                  , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp-                                                  , narrowSubsumesAnd AndOp Narrow8WordOp 8 ]-primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit-                                                  , subsumedByPrimOp Narrow8WordOp-                                                  , subsumedByPrimOp Narrow16WordOp-                                                  , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp-                                                  , narrowSubsumesAnd AndOp Narrow16WordOp 16 ]-primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit-                                                  , subsumedByPrimOp Narrow8WordOp-                                                  , subsumedByPrimOp Narrow16WordOp-                                                  , subsumedByPrimOp Narrow32WordOp-                                                  , removeOp32-                                                  , narrowSubsumesAnd AndOp Narrow32WordOp 32 ]-primOpRules nm OrdOp          = mkPrimOpRule nm 1 [ liftLit char2IntLit-                                                  , inversePrimOp ChrOp ]-primOpRules nm ChrOp          = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs-                                                       guard (litFitsInChar lit)-                                                       liftLit int2CharLit-                                                  , inversePrimOp OrdOp ]-primOpRules nm Float2IntOp    = mkPrimOpRule nm 1 [ liftLit float2IntLit ]-primOpRules nm Int2FloatOp    = mkPrimOpRule nm 1 [ liftLit int2FloatLit ]-primOpRules nm Double2IntOp   = mkPrimOpRule nm 1 [ liftLit double2IntLit ]-primOpRules nm Int2DoubleOp   = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ]--- SUP: Not sure what the standard says about precision in the following 2 cases-primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ]-primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ]---- Float-primOpRules nm FloatAddOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))-                                                , identity zerof ]-primOpRules nm FloatSubOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))-                                                , rightIdentity zerof ]-primOpRules nm FloatMulOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))-                                                , identity onef-                                                , strengthReduction twof FloatAddOp  ]-                         -- zeroElem zerof doesn't hold because of NaN-primOpRules nm FloatDivOp   = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))-                                                , rightIdentity onef ]-primOpRules nm FloatNegOp   = mkPrimOpRule nm 1 [ unaryLit negOp-                                                , inversePrimOp FloatNegOp ]---- Double-primOpRules nm DoubleAddOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))-                                                 , identity zerod ]-primOpRules nm DoubleSubOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))-                                                 , rightIdentity zerod ]-primOpRules nm DoubleMulOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))-                                                 , identity oned-                                                 , strengthReduction twod DoubleAddOp  ]-                          -- zeroElem zerod doesn't hold because of NaN-primOpRules nm DoubleDivOp   = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))-                                                 , rightIdentity oned ]-primOpRules nm DoubleNegOp   = mkPrimOpRule nm 1 [ unaryLit negOp-                                                 , inversePrimOp DoubleNegOp ]---- Relational operators--primOpRules nm IntEqOp    = mkRelOpRule nm (==) [ litEq True ]-primOpRules nm IntNeOp    = mkRelOpRule nm (/=) [ litEq False ]-primOpRules nm CharEqOp   = mkRelOpRule nm (==) [ litEq True ]-primOpRules nm CharNeOp   = mkRelOpRule nm (/=) [ litEq False ]--primOpRules nm IntGtOp    = mkRelOpRule nm (>)  [ boundsCmp Gt ]-primOpRules nm IntGeOp    = mkRelOpRule nm (>=) [ boundsCmp Ge ]-primOpRules nm IntLeOp    = mkRelOpRule nm (<=) [ boundsCmp Le ]-primOpRules nm IntLtOp    = mkRelOpRule nm (<)  [ boundsCmp Lt ]--primOpRules nm CharGtOp   = mkRelOpRule nm (>)  [ boundsCmp Gt ]-primOpRules nm CharGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]-primOpRules nm CharLeOp   = mkRelOpRule nm (<=) [ boundsCmp Le ]-primOpRules nm CharLtOp   = mkRelOpRule nm (<)  [ boundsCmp Lt ]--primOpRules nm FloatGtOp  = mkFloatingRelOpRule nm (>)-primOpRules nm FloatGeOp  = mkFloatingRelOpRule nm (>=)-primOpRules nm FloatLeOp  = mkFloatingRelOpRule nm (<=)-primOpRules nm FloatLtOp  = mkFloatingRelOpRule nm (<)-primOpRules nm FloatEqOp  = mkFloatingRelOpRule nm (==)-primOpRules nm FloatNeOp  = mkFloatingRelOpRule nm (/=)--primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>)-primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=)-primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=)-primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<)-primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==)-primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=)--primOpRules nm WordGtOp   = mkRelOpRule nm (>)  [ boundsCmp Gt ]-primOpRules nm WordGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]-primOpRules nm WordLeOp   = mkRelOpRule nm (<=) [ boundsCmp Le ]-primOpRules nm WordLtOp   = mkRelOpRule nm (<)  [ boundsCmp Lt ]-primOpRules nm WordEqOp   = mkRelOpRule nm (==) [ litEq True ]-primOpRules nm WordNeOp   = mkRelOpRule nm (/=) [ litEq False ]--primOpRules nm AddrAddOp  = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ]--primOpRules nm SeqOp      = mkPrimOpRule nm 4 [ seqRule ]-primOpRules nm SparkOp    = mkPrimOpRule nm 4 [ sparkRule ]--primOpRules _  _          = Nothing--{--************************************************************************-*                                                                      *-\subsection{Doing the business}-*                                                                      *-************************************************************************--}---- useful shorthands-mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule-mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)--mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)-            -> [RuleM CoreExpr] -> Maybe CoreRule-mkRelOpRule nm cmp extra-  = mkPrimOpRule nm 2 $-    binaryCmpLit cmp : equal_rule : extra-  where-        -- x `cmp` x does not depend on x, so-        -- compute it for the arbitrary value 'True'-        -- and use that result-    equal_rule = do { equalArgs-                    ; dflags <- getDynFlags-                    ; return (if cmp True True-                              then trueValInt  dflags-                              else falseValInt dflags) }--{- Note [Rules for floating-point comparisons]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need different rules for floating-point values because for floats-it is not true that x = x (for NaNs); so we do not want the equal_rule-rule that mkRelOpRule uses.--Note also that, in the case of equality/inequality, we do /not/-want to switch to a case-expression.  For example, we do not want-to convert-   case (eqFloat# x 3.8#) of-     True -> this-     False -> that-to-  case x of-    3.8#::Float# -> this-    _            -> that-See #9238.  Reason: comparing floating-point values for equality-delicate, and we don't want to implement that delicacy in the code for-case expressions.  So we make it an invariant of Core that a case-expression never scrutinises a Float# or Double#.--This transformation is what the litEq rule does;-see Note [The litEq rule: converting equality to case].-So we /refrain/ from using litEq for mkFloatingRelOpRule.--}--mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)-                    -> Maybe CoreRule--- See Note [Rules for floating-point comparisons]-mkFloatingRelOpRule nm cmp-  = mkPrimOpRule nm 2 [binaryCmpLit cmp]---- common constants-zeroi, onei, zerow, onew :: DynFlags -> Literal-zeroi dflags = mkLitInt  dflags 0-onei  dflags = mkLitInt  dflags 1-zerow dflags = mkLitWord dflags 0-onew  dflags = mkLitWord dflags 1--zerof, onef, twof, zerod, oned, twod :: Literal-zerof = mkLitFloat 0.0-onef  = mkLitFloat 1.0-twof  = mkLitFloat 2.0-zerod = mkLitDouble 0.0-oned  = mkLitDouble 1.0-twod  = mkLitDouble 2.0--cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool)-      -> Literal -> Literal -> Maybe CoreExpr-cmpOp dflags cmp = go-  where-    done True  = Just $ trueValInt  dflags-    done False = Just $ falseValInt dflags--    -- These compares are at different types-    go (LitChar i1)   (LitChar i2)   = done (i1 `cmp` i2)-    go (LitFloat i1)  (LitFloat i2)  = done (i1 `cmp` i2)-    go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2)-    go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _)-      | nt1 /= nt2 = Nothing-      | otherwise  = done (i1 `cmp` i2)-    go _               _               = Nothing------------------------------negOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Negate-negOp _      (LitFloat 0.0)  = Nothing  -- can't represent -0.0 as a Rational-negOp dflags (LitFloat f)    = Just (mkFloatVal dflags (-f))-negOp _      (LitDouble 0.0) = Nothing-negOp dflags (LitDouble d)   = Just (mkDoubleVal dflags (-d))-negOp dflags (LitNumber nt i t)-   | litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (-i) t))-negOp _      _                = Nothing--complementOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Binary complement-complementOp dflags (LitNumber nt i t) =-   Just (Lit (mkLitNumberWrap dflags nt (complement i) t))-complementOp _      _            = Nothing-----------------------------intOp2 :: (Integral a, Integral b)-       => (a -> b -> Integer)-       -> DynFlags -> Literal -> Literal -> Maybe CoreExpr-intOp2 = intOp2' . const--intOp2' :: (Integral a, Integral b)-        => (DynFlags -> a -> b -> Integer)-        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr-intOp2' op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) =-  let o = op dflags-  in  intResult dflags (fromInteger i1 `o` fromInteger i2)-intOp2' _  _      _            _            = Nothing  -- Could find LitLit--intOpC2 :: (Integral a, Integral b)-        => (a -> b -> Integer)-        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr-intOpC2 op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do-  intCResult dflags (fromInteger i1 `op` fromInteger i2)-intOpC2 _  _      _            _            = Nothing  -- Could find LitLit--shiftRightLogical :: DynFlags -> Integer -> Int -> Integer--- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do--- Do this by converting to Word and back.  Obviously this won't work for big--- values, but its ok as we use it here-shiftRightLogical dflags x n =-    case platformWordSize (targetPlatform dflags) of-      PW4 -> fromIntegral (fromInteger x `shiftR` n :: Word32)-      PW8 -> fromIntegral (fromInteger x `shiftR` n :: Word64)-----------------------------retLit :: (DynFlags -> Literal) -> RuleM CoreExpr-retLit l = do dflags <- getDynFlags-              return $ Lit $ l dflags--retLitNoC :: (DynFlags -> Literal) -> RuleM CoreExpr-retLitNoC l = do dflags <- getDynFlags-                 let lit = l dflags-                 let ty = literalType lit-                 return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi dflags)]--wordOp2 :: (Integral a, Integral b)-        => (a -> b -> Integer)-        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr-wordOp2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _)-    = wordResult dflags (fromInteger w1 `op` fromInteger w2)-wordOp2 _ _ _ _ = Nothing  -- Could find LitLit--wordOpC2 :: (Integral a, Integral b)-        => (a -> b -> Integer)-        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr-wordOpC2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) =-  wordCResult dflags (fromInteger w1 `op` fromInteger w2)-wordOpC2 _ _ _ _ = Nothing  -- Could find LitLit--shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr--- Shifts take an Int; hence third arg of op is Int--- Used for shift primops---    ISllOp, ISraOp, ISrlOp :: Word# -> Int# -> Word#---    SllOp, SrlOp           :: Word# -> Int# -> Word#-shiftRule shift_op-  = do { dflags <- getDynFlags-       ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs-       ; case e1 of-           _ | shift_len == 0-             -> return e1-             -- See Note [Guarding against silly shifts]-             | shift_len < 0 || shift_len > wordSizeInBits dflags-             -> return $ Lit $ mkLitNumberWrap dflags LitNumInt 0 (exprType e1)--           -- Do the shift at type Integer, but shift length is Int-           Lit (LitNumber nt x t)-             | 0 < shift_len-             , shift_len <= wordSizeInBits dflags-             -> let op = shift_op dflags-                    y  = x `op` fromInteger shift_len-                in  liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t))--           _ -> mzero }--wordSizeInBits :: DynFlags -> Integer-wordSizeInBits dflags = toInteger (platformWordSizeInBits (targetPlatform dflags))-----------------------------floatOp2 :: (Rational -> Rational -> Rational)-         -> DynFlags -> Literal -> Literal-         -> Maybe (Expr CoreBndr)-floatOp2 op dflags (LitFloat f1) (LitFloat f2)-  = Just (mkFloatVal dflags (f1 `op` f2))-floatOp2 _ _ _ _ = Nothing-----------------------------doubleOp2 :: (Rational -> Rational -> Rational)-          -> DynFlags -> Literal -> Literal-          -> Maybe (Expr CoreBndr)-doubleOp2 op dflags (LitDouble f1) (LitDouble f2)-  = Just (mkDoubleVal dflags (f1 `op` f2))-doubleOp2 _ _ _ _ = Nothing-----------------------------{- Note [The litEq rule: converting equality to case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This stuff turns-     n ==# 3#-into-     case n of-       3# -> True-       m  -> False--This is a Good Thing, because it allows case-of case things-to happen, and case-default absorption to happen.  For-example:--     if (n ==# 3#) || (n ==# 4#) then e1 else e2-will transform to-     case n of-       3# -> e1-       4# -> e1-       m  -> e2-(modulo the usual precautions to avoid duplicating e1)--}--litEq :: Bool  -- True <=> equality, False <=> inequality-      -> RuleM CoreExpr-litEq is_eq = msum-  [ do [Lit lit, expr] <- getArgs-       dflags <- getDynFlags-       do_lit_eq dflags lit expr-  , do [expr, Lit lit] <- getArgs-       dflags <- getDynFlags-       do_lit_eq dflags lit expr ]-  where-    do_lit_eq dflags lit expr = do-      guard (not (litIsLifted lit))-      return (mkWildCase expr (literalType lit) intPrimTy-                    [(DEFAULT,    [], val_if_neq),-                     (LitAlt lit, [], val_if_eq)])-      where-        val_if_eq  | is_eq     = trueValInt  dflags-                   | otherwise = falseValInt dflags-        val_if_neq | is_eq     = falseValInt dflags-                   | otherwise = trueValInt  dflags----- | Check if there is comparison with minBound or maxBound, that is--- always true or false. For instance, an Int cannot be smaller than its--- minBound, so we can replace such comparison with False.-boundsCmp :: Comparison -> RuleM CoreExpr-boundsCmp op = do-  dflags <- getDynFlags-  [a, b] <- getArgs-  liftMaybe $ mkRuleFn dflags op a b--data Comparison = Gt | Ge | Lt | Le--mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr-mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags-mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt  dflags-mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt  dflags-mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags-mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt  dflags-mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags-mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags-mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt  dflags-mkRuleFn _ _ _ _                                       = Nothing--isMinBound :: DynFlags -> Literal -> Bool-isMinBound _      (LitChar c)        = c == minBound-isMinBound dflags (LitNumber nt i _) = case nt of-   LitNumInt     -> i == tARGET_MIN_INT dflags-   LitNumInt64   -> i == toInteger (minBound :: Int64)-   LitNumWord    -> i == 0-   LitNumWord64  -> i == 0-   LitNumNatural -> i == 0-   LitNumInteger -> False-isMinBound _      _                  = False--isMaxBound :: DynFlags -> Literal -> Bool-isMaxBound _      (LitChar c)       = c == maxBound-isMaxBound dflags (LitNumber nt i _) = case nt of-   LitNumInt     -> i == tARGET_MAX_INT dflags-   LitNumInt64   -> i == toInteger (maxBound :: Int64)-   LitNumWord    -> i == tARGET_MAX_WORD dflags-   LitNumWord64  -> i == toInteger (maxBound :: Word64)-   LitNumNatural -> False-   LitNumInteger -> False-isMaxBound _      _                  = False---- | Create an Int literal expression while ensuring the given Integer is in the--- target Int range-intResult :: DynFlags -> Integer -> Maybe CoreExpr-intResult dflags result = Just (intResult' dflags result)--intResult' :: DynFlags -> Integer -> CoreExpr-intResult' dflags result = Lit (mkLitIntWrap dflags result)---- | Create an unboxed pair of an Int literal expression, ensuring the given--- Integer is in the target Int range and the corresponding overflow flag--- (@0#@/@1#@) if it wasn't.-intCResult :: DynFlags -> Integer -> Maybe CoreExpr-intCResult dflags result = Just (mkPair [Lit lit, Lit c])-  where-    mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]-    (lit, b) = mkLitIntWrapC dflags result-    c = if b then onei dflags else zeroi dflags---- | Create a Word literal expression while ensuring the given Integer is in the--- target Word range-wordResult :: DynFlags -> Integer -> Maybe CoreExpr-wordResult dflags result = Just (wordResult' dflags result)--wordResult' :: DynFlags -> Integer -> CoreExpr-wordResult' dflags result = Lit (mkLitWordWrap dflags result)---- | Create an unboxed pair of a Word literal expression, ensuring the given--- Integer is in the target Word range and the corresponding carry flag--- (@0#@/@1#@) if it wasn't.-wordCResult :: DynFlags -> Integer -> Maybe CoreExpr-wordCResult dflags result = Just (mkPair [Lit lit, Lit c])-  where-    mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]-    (lit, b) = mkLitWordWrapC dflags result-    c = if b then onei dflags else zeroi dflags--inversePrimOp :: PrimOp -> RuleM CoreExpr-inversePrimOp primop = do-  [Var primop_id `App` e] <- getArgs-  matchPrimOpId primop primop_id-  return e--subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr-this `subsumesPrimOp` that = do-  [Var primop_id `App` e] <- getArgs-  matchPrimOpId that primop_id-  return (Var (mkPrimOpId this) `App` e)--subsumedByPrimOp :: PrimOp -> RuleM CoreExpr-subsumedByPrimOp primop = do-  [e@(Var primop_id `App` _)] <- getArgs-  matchPrimOpId primop primop_id-  return e---- | narrow subsumes bitwise `and` with full mask (cf #16402):------       narrowN (x .&. m)---       m .&. (2^N-1) = 2^N-1---       ==> narrowN x------ e.g.  narrow16 (x .&. 0xFFFF)---       ==> narrow16 x----narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr-narrowSubsumesAnd and_primop narrw n = do-  [Var primop_id `App` x `App` y] <- getArgs-  matchPrimOpId and_primop primop_id-  let mask = bit n -1-      g v (Lit (LitNumber _ m _)) = do-         guard (m .&. mask == mask)-         return (Var (mkPrimOpId narrw) `App` v)-      g _ _ = mzero-  g x y <|> g y x--idempotent :: RuleM CoreExpr-idempotent = do [e1, e2] <- getArgs-                guard $ cheapEqExpr e1 e2-                return e1--{--Note [Guarding against silly shifts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this code:--  import Data.Bits( (.|.), shiftL )-  chunkToBitmap :: [Bool] -> Word32-  chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]--This optimises to:-Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->-    case w1_sCT of _ {-      [] -> 0##;-      : x_aAW xs_aAX ->-        case x_aAW of _ {-          GHC.Types.False ->-            case w_sCS of wild2_Xh {-              __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;-              9223372036854775807 -> 0## };-          GHC.Types.True ->-            case GHC.Prim.>=# w_sCS 64 of _ {-              GHC.Types.False ->-                case w_sCS of wild3_Xh {-                  __DEFAULT ->-                    case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->-                      GHC.Prim.or# (GHC.Prim.narrow32Word#-                                      (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))-                                   ww_sCW-                     };-                  9223372036854775807 ->-                    GHC.Prim.narrow32Word#-!!!!-->                  (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)-                };-              GHC.Types.True ->-                case w_sCS of wild3_Xh {-                  __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;-                  9223372036854775807 -> 0##-                } } } }--Note the massive shift on line "!!!!".  It can't happen, because we've checked-that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this!-Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we-can't constant fold it, but if it gets to the assembler we get-     Error: operand type mismatch for `shl'--So the best thing to do is to rewrite the shift with a call to error,-when the second arg is large. However, in general we cannot do this; consider-this case--    let x = I# (uncheckedIShiftL# n 80)-    in ...--Here x contains an invalid shift and consequently we would like to rewrite it-as follows:--    let x = I# (error "invalid shift)-    in ...--This was originally done in the fix to #16449 but this breaks the let/app-invariant (see Note [Core let/app invariant] in GHC.Core) as noted in #16742.-For the reasons discussed in Note [Checking versus non-checking primops] (in-the PrimOp module) there is no safe way rewrite the argument of I# such that-it bottoms.--Consequently we instead take advantage of the fact that large shifts are-undefined behavior (see associated documentation in primops.txt.pp) and-transform the invalid shift into an "obviously incorrect" value.--There are two cases:--- Shifting fixed-width things: the primops ISll, Sll, etc-  These are handled by shiftRule.--  We are happy to shift by any amount up to wordSize but no more.--- Shifting Integers: the function shiftLInteger, shiftRInteger-  from the 'integer' library.   These are handled by rule_shift_op,-  and match_Integer_shift_op.--  Here we could in principle shift by any amount, but we arbitrary-  limit the shift to 4 bits; in particular we do not want shift by a-  huge amount, which can happen in code like that above.--The two cases are more different in their code paths that is comfortable,-but that is only a historical accident.---************************************************************************-*                                                                      *-\subsection{Vaguely generic functions}-*                                                                      *-************************************************************************--}--mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule--- Gives the Rule the same name as the primop itself-mkBasicRule op_name n_args rm-  = BuiltinRule { ru_name  = occNameFS (nameOccName op_name),-                  ru_fn    = op_name,-                  ru_nargs = n_args,-                  ru_try   = runRuleM rm }--newtype RuleM r = RuleM-  { runRuleM :: DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r }-  deriving (Functor)--instance Applicative RuleM where-    pure x = RuleM $ \_ _ _ _ -> Just x-    (<*>) = ap--instance Monad RuleM where-  RuleM f >>= g-    = RuleM $ \dflags iu fn args ->-              case f dflags iu fn args of-                Nothing -> Nothing-                Just r  -> runRuleM (g r) dflags iu fn args--#if !MIN_VERSION_base(4,13,0)-  fail = MonadFail.fail-#endif--instance MonadFail.MonadFail RuleM where-    fail _ = mzero--instance Alternative RuleM where-  empty = RuleM $ \_ _ _ _ -> Nothing-  RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu fn args ->-    f1 dflags iu fn args <|> f2 dflags iu fn args--instance MonadPlus RuleM--instance HasDynFlags RuleM where-    getDynFlags = RuleM $ \dflags _ _ _ -> Just dflags--liftMaybe :: Maybe a -> RuleM a-liftMaybe Nothing = mzero-liftMaybe (Just x) = return x--liftLit :: (Literal -> Literal) -> RuleM CoreExpr-liftLit f = liftLitDynFlags (const f)--liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr-liftLitDynFlags f = do-  dflags <- getDynFlags-  [Lit lit] <- getArgs-  return $ Lit (f dflags lit)--removeOp32 :: RuleM CoreExpr-removeOp32 = do-  dflags <- getDynFlags-  case platformWordSize (targetPlatform dflags) of-    PW4 -> do-      [e] <- getArgs-      return e-    PW8 ->-      mzero--getArgs :: RuleM [CoreExpr]-getArgs = RuleM $ \_ _ _ args -> Just args--getInScopeEnv :: RuleM InScopeEnv-getInScopeEnv = RuleM $ \_ iu _ _ -> Just iu--getFunction :: RuleM Id-getFunction = RuleM $ \_ _ fn _ -> Just fn---- return the n-th argument of this rule, if it is a literal--- argument indices start from 0-getLiteral :: Int -> RuleM Literal-getLiteral n = RuleM $ \_ _ _ exprs -> case drop n exprs of-  (Lit l:_) -> Just l-  _ -> Nothing--unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr-unaryLit op = do-  dflags <- getDynFlags-  [Lit l] <- getArgs-  liftMaybe $ op dflags (convFloating dflags l)--binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr-binaryLit op = do-  dflags <- getDynFlags-  [Lit l1, Lit l2] <- getArgs-  liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)--binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr-binaryCmpLit op = do-  dflags <- getDynFlags-  binaryLit (\_ -> cmpOp dflags op)--leftIdentity :: Literal -> RuleM CoreExpr-leftIdentity id_lit = leftIdentityDynFlags (const id_lit)--rightIdentity :: Literal -> RuleM CoreExpr-rightIdentity id_lit = rightIdentityDynFlags (const id_lit)--identity :: Literal -> RuleM CoreExpr-identity lit = leftIdentity lit `mplus` rightIdentity lit--leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr-leftIdentityDynFlags id_lit = do-  dflags <- getDynFlags-  [Lit l1, e2] <- getArgs-  guard $ l1 == id_lit dflags-  return e2---- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in--- addition to the result, we have to indicate that no carry/overflow occurred.-leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr-leftIdentityCDynFlags id_lit = do-  dflags <- getDynFlags-  [Lit l1, e2] <- getArgs-  guard $ l1 == id_lit dflags-  let no_c = Lit (zeroi dflags)-  return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c])--rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr-rightIdentityDynFlags id_lit = do-  dflags <- getDynFlags-  [e1, Lit l2] <- getArgs-  guard $ l2 == id_lit dflags-  return e1---- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in--- addition to the result, we have to indicate that no carry/overflow occurred.-rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr-rightIdentityCDynFlags id_lit = do-  dflags <- getDynFlags-  [e1, Lit l2] <- getArgs-  guard $ l2 == id_lit dflags-  let no_c = Lit (zeroi dflags)-  return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c])--identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr-identityDynFlags lit =-  leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit---- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition--- to the result, we have to indicate that no carry/overflow occurred.-identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr-identityCDynFlags lit =-  leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit--leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr-leftZero zero = do-  dflags <- getDynFlags-  [Lit l1, _] <- getArgs-  guard $ l1 == zero dflags-  return $ Lit l1--rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr-rightZero zero = do-  dflags <- getDynFlags-  [_, Lit l2] <- getArgs-  guard $ l2 == zero dflags-  return $ Lit l2--zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr-zeroElem lit = leftZero lit `mplus` rightZero lit--equalArgs :: RuleM ()-equalArgs = do-  [e1, e2] <- getArgs-  guard $ e1 `cheapEqExpr` e2--nonZeroLit :: Int -> RuleM ()-nonZeroLit n = getLiteral n >>= guard . not . isZeroLit---- When excess precision is not requested, cut down the precision of the--- Rational value to that of Float/Double. We confuse host architecture--- and target architecture here, but it's convenient (and wrong :-).-convFloating :: DynFlags -> Literal -> Literal-convFloating dflags (LitFloat  f) | not (gopt Opt_ExcessPrecision dflags) =-   LitFloat  (toRational (fromRational f :: Float ))-convFloating dflags (LitDouble d) | not (gopt Opt_ExcessPrecision dflags) =-   LitDouble (toRational (fromRational d :: Double))-convFloating _ l = l--guardFloatDiv :: RuleM ()-guardFloatDiv = do-  [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs-  guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]-       && f2 /= 0            -- avoid NaN and Infinity/-Infinity--guardDoubleDiv :: RuleM ()-guardDoubleDiv = do-  [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs-  guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]-       && d2 /= 0            -- avoid NaN and Infinity/-Infinity--- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to--- zero, but we might want to preserve the negative zero here which--- is representable in Float/Double but not in (normalised)--- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?--strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr-strengthReduction two_lit add_op = do -- Note [Strength reduction]-  arg <- msum [ do [arg, Lit mult_lit] <- getArgs-                   guard (mult_lit == two_lit)-                   return arg-              , do [Lit mult_lit, arg] <- getArgs-                   guard (mult_lit == two_lit)-                   return arg ]-  return $ Var (mkPrimOpId add_op) `App` arg `App` arg---- Note [Strength reduction]--- ~~~~~~~~~~~~~~~~~~~~~~~~~------ This rule turns floating point multiplications of the form 2.0 * x and--- x * 2.0 into x + x addition, because addition costs less than multiplication.--- See #7116---- Note [What's true and false]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ trueValInt and falseValInt represent true and false values returned by--- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.--- True is represented as an unboxed 1# literal, while false is represented--- as 0# literal.--- We still need Bool data constructors (True and False) to use in a rule--- for constant folding of equal Strings--trueValInt, falseValInt :: DynFlags -> Expr CoreBndr-trueValInt  dflags = Lit $ onei  dflags -- see Note [What's true and false]-falseValInt dflags = Lit $ zeroi dflags--trueValBool, falseValBool :: Expr CoreBndr-trueValBool   = Var trueDataConId -- see Note [What's true and false]-falseValBool  = Var falseDataConId--ltVal, eqVal, gtVal :: Expr CoreBndr-ltVal = Var ordLTDataConId-eqVal = Var ordEQDataConId-gtVal = Var ordGTDataConId--mkIntVal :: DynFlags -> Integer -> Expr CoreBndr-mkIntVal dflags i = Lit (mkLitInt dflags i)-mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr-mkFloatVal dflags f = Lit (convFloating dflags (LitFloat  f))-mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr-mkDoubleVal dflags d = Lit (convFloating dflags (LitDouble d))--matchPrimOpId :: PrimOp -> Id -> RuleM ()-matchPrimOpId op id = do-  op' <- liftMaybe $ isPrimOpId_maybe id-  guard $ op == op'--{--************************************************************************-*                                                                      *-\subsection{Special rules for seq, tagToEnum, dataToTag}-*                                                                      *-************************************************************************--Note [tagToEnum#]-~~~~~~~~~~~~~~~~~-Nasty check to ensure that tagToEnum# is applied to a type that is an-enumeration TyCon.  Unification may refine the type later, but this-check won't see that, alas.  It's crude but it works.--Here's are two cases that should fail-        f :: forall a. a-        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable--        g :: Int-        g = tagToEnum# 0        -- Int is not an enumeration--We used to make this check in the type inference engine, but it's quite-ugly to do so, because the delayed constraint solving means that we don't-really know what's going on until the end. It's very much a corner case-because we don't expect the user to call tagToEnum# at all; we merely-generate calls in derived instances of Enum.  So we compromise: a-rewrite rule rewrites a bad instance of tagToEnum# to an error call,-and emits a warning.--}--tagToEnumRule :: RuleM CoreExpr--- If     data T a = A | B | C--- then   tag2Enum# (T ty) 2# -->  B ty-tagToEnumRule = do-  [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs-  case splitTyConApp_maybe ty of-    Just (tycon, tc_args) | isEnumerationTyCon tycon -> do-      let tag = fromInteger i-          correct_tag dc = (dataConTagZ dc) == tag-      (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])-      ASSERT(null rest) return ()-      return $ mkTyApps (Var (dataConWorkId dc)) tc_args--    -- See Note [tagToEnum#]-    _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )-         return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"---------------------------------dataToTagRule :: RuleM CoreExpr--- See Note [dataToTag#] in primops.txt.pp-dataToTagRule = a `mplus` b-  where-    -- dataToTag (tagToEnum x)   ==>   x-    a = do-      [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs-      guard $ tag_to_enum `hasKey` tagToEnumKey-      guard $ ty1 `eqType` ty2-      return tag--    -- dataToTag (K e1 e2)  ==>   tag-of K-    -- This also works (via exprIsConApp_maybe) for-    --   dataToTag x-    -- where x's unfolding is a constructor application-    b = do-      dflags <- getDynFlags-      [_, val_arg] <- getArgs-      in_scope <- getInScopeEnv-      (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg-      ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()-      return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc)))--{- Note [dataToTag# magic]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The primop dataToTag# is unusual because it evaluates its argument.-Only `SeqOp` shares that property.  (Other primops do not do anything-as fancy as argument evaluation.)  The special handling for dataToTag#-is:--* GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp,-  (actually in app_ok).  Most primops with lifted arguments do not-  evaluate those arguments, but DataToTagOp and SeqOp are two-  exceptions.  We say that they are /never/ ok-for-speculation,-  regardless of the evaluated-ness of their argument.-  See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp]--* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr,-  that evaluates its argument and then extracts the tag from-  the returned value.--* An application like (dataToTag# (Just x)) is optimised by-  dataToTagRule in PrelRules.--* A case expression like-     case (dataToTag# e) of <alts>-  gets transformed t-     case e of <transformed alts>-  by PrelRules.caseRules; see Note [caseRules for dataToTag]--See #15696 for a long saga.--}--{- *********************************************************************-*                                                                      *-             unsafeEqualityProof-*                                                                      *-********************************************************************* -}---- unsafeEqualityProof k t t  ==>  UnsafeRefl (Refl t)--- That is, if the two types are equal, it's not unsafe!--unsafeEqualityProofRule :: RuleM CoreExpr-unsafeEqualityProofRule-  = do { [Type rep, Type t1, Type t2] <- getArgs-       ; guard (t1 `eqType` t2)-       ; fn <- getFunction-       ; let (_, ue) = splitForAllTys (idType fn)-             tc      = tyConAppTyCon ue  -- tycon:    UnsafeEquality-             (dc:_)  = tyConDataCons tc  -- data con: UnsafeRefl-             -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r).-             --               UnsafeEquality r a a-       ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) }---{- *********************************************************************-*                                                                      *-             Rules for seq# and spark#-*                                                                      *-********************************************************************* -}--{- Note [seq# magic]-~~~~~~~~~~~~~~~~~~~~-The primop-   seq# :: forall a s . a -> State# s -> (# State# s, a #)--is /not/ the same as the Prelude function seq :: a -> b -> b-as you can see from its type.  In fact, seq# is the implementation-mechanism for 'evaluate'--   evaluate :: a -> IO a-   evaluate a = IO $ \s -> seq# a s--The semantics of seq# is-  * evaluate its first argument-  * and return it--Things to note--* Why do we need a primop at all?  That is, instead of-      case seq# x s of (# x, s #) -> blah-  why not instead say this?-      case x of { DEFAULT -> blah)--  Reason (see #5129): if we saw-    catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler--  then we'd drop the 'case x' because the body of the case is bottom-  anyway. But we don't want to do that; the whole /point/ of-  seq#/evaluate is to evaluate 'x' first in the IO monad.--  In short, we /always/ evaluate the first argument and never-  just discard it.--* Why return the value?  So that we can control sharing of seq'd-  values: in-     let x = e in x `seq` ... x ...-  We don't want to inline x, so better to represent it as-       let x = e in case seq# x RW of (# _, x' #) -> ... x' ...-  also it matches the type of rseq in the Eval monad.--Implementing seq#.  The compiler has magic for SeqOp in--- PrelRules.seqRule: eliminate (seq# <whnf> s)--- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#--- GHC.Core.Utils.exprOkForSpeculation;-  see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils--- Simplify.addEvals records evaluated-ness for the result; see-  Note [Adding evaluatedness info to pattern-bound variables]-  in Simplify--}--seqRule :: RuleM CoreExpr-seqRule = do-  [Type ty_a, Type _ty_s, a, s] <- getArgs-  guard $ exprIsHNF a-  return $ mkCoreUbxTup [exprType s, ty_a] [s, a]---- spark# :: forall a s . a -> State# s -> (# State# s, a #)-sparkRule :: RuleM CoreExpr-sparkRule = seqRule -- reduce on HNF, just the same-  -- XXX perhaps we shouldn't do this, because a spark eliminated by-  -- this rule won't be counted as a dud at runtime?--{--************************************************************************-*                                                                      *-\subsection{Built in rules}-*                                                                      *-************************************************************************--Note [Scoping for Builtin rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When compiling a (base-package) module that defines one of the-functions mentioned in the RHS of a built-in rule, there's a danger-that we'll see--        f = ...(eq String x)....--        ....and lower down...--        eqString = ...--Then a rewrite would give--        f = ...(eqString x)...-        ....and lower down...-        eqString = ...--and lo, eqString is not in scope.  This only really matters when we-get to code generation.  But the occurrence analyser does a GlomBinds-step when necessary, that does a new SCC analysis on the whole set of-bindings (see occurAnalysePgm), which sorts out the dependency, so all-is fine.--}--builtinRules :: [CoreRule]--- Rules for non-primops that can't be expressed using a RULE pragma-builtinRules-  = [BuiltinRule { ru_name = fsLit "AppendLitString",-                   ru_fn = unpackCStringFoldrName,-                   ru_nargs = 4, ru_try = match_append_lit },-     BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,-                   ru_nargs = 2, ru_try = match_eq_string },-     BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,-                   ru_nargs = 2, ru_try = \_ _ _ -> match_inline },-     BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,-                   ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict },--     mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule,--     mkBasicRule divIntName 2 $ msum-        [ nonZeroLit 1 >> binaryLit (intOp2 div)-        , leftZero zeroi-        , do-          [arg, Lit (LitNumber LitNumInt d _)] <- getArgs-          Just n <- return $ exactLog2 d-          dflags <- getDynFlags-          return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n-        ],--     mkBasicRule modIntName 2 $ msum-        [ nonZeroLit 1 >> binaryLit (intOp2 mod)-        , leftZero zeroi-        , do-          [arg, Lit (LitNumber LitNumInt d _)] <- getArgs-          Just _ <- return $ exactLog2 d-          dflags <- getDynFlags-          return $ Var (mkPrimOpId AndIOp)-            `App` arg `App` mkIntVal dflags (d - 1)-        ]-     ]- ++ builtinIntegerRules- ++ builtinNaturalRules-{-# NOINLINE builtinRules #-}--- there is no benefit to inlining these yet, despite this, GHC produces--- unfoldings for this regardless since the floated list entries look small.--builtinIntegerRules :: [CoreRule]-builtinIntegerRules =- [rule_IntToInteger   "smallInteger"        smallIntegerName,-  rule_WordToInteger  "wordToInteger"       wordToIntegerName,-  rule_Int64ToInteger  "int64ToInteger"     int64ToIntegerName,-  rule_Word64ToInteger "word64ToInteger"    word64ToIntegerName,-  rule_convert        "integerToWord"       integerToWordName       mkWordLitWord,-  rule_convert        "integerToInt"        integerToIntName        mkIntLitInt,-  rule_convert        "integerToWord64"     integerToWord64Name     (\_ -> mkWord64LitWord64),-  rule_convert        "integerToInt64"      integerToInt64Name      (\_ -> mkInt64LitInt64),-  rule_binop          "plusInteger"         plusIntegerName         (+),-  rule_binop          "minusInteger"        minusIntegerName        (-),-  rule_binop          "timesInteger"        timesIntegerName        (*),-  rule_unop           "negateInteger"       negateIntegerName       negate,-  rule_binop_Prim     "eqInteger#"          eqIntegerPrimName       (==),-  rule_binop_Prim     "neqInteger#"         neqIntegerPrimName      (/=),-  rule_unop           "absInteger"          absIntegerName          abs,-  rule_unop           "signumInteger"       signumIntegerName       signum,-  rule_binop_Prim     "leInteger#"          leIntegerPrimName       (<=),-  rule_binop_Prim     "gtInteger#"          gtIntegerPrimName       (>),-  rule_binop_Prim     "ltInteger#"          ltIntegerPrimName       (<),-  rule_binop_Prim     "geInteger#"          geIntegerPrimName       (>=),-  rule_binop_Ordering "compareInteger"      compareIntegerName      compare,-  rule_encodeFloat    "encodeFloatInteger"  encodeFloatIntegerName  mkFloatLitFloat,-  rule_convert        "floatFromInteger"    floatFromIntegerName    (\_ -> mkFloatLitFloat),-  rule_encodeFloat    "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,-  rule_decodeDouble   "decodeDoubleInteger" decodeDoubleIntegerName,-  rule_convert        "doubleFromInteger"   doubleFromIntegerName   (\_ -> mkDoubleLitDouble),-  rule_rationalTo     "rationalToFloat"     rationalToFloatName     mkFloatExpr,-  rule_rationalTo     "rationalToDouble"    rationalToDoubleName    mkDoubleExpr,-  rule_binop          "gcdInteger"          gcdIntegerName          gcd,-  rule_binop          "lcmInteger"          lcmIntegerName          lcm,-  rule_binop          "andInteger"          andIntegerName          (.&.),-  rule_binop          "orInteger"           orIntegerName           (.|.),-  rule_binop          "xorInteger"          xorIntegerName          xor,-  rule_unop           "complementInteger"   complementIntegerName   complement,-  rule_shift_op       "shiftLInteger"       shiftLIntegerName       shiftL,-  rule_shift_op       "shiftRInteger"       shiftRIntegerName       shiftR,-  rule_bitInteger     "bitInteger"          bitIntegerName,-  -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs-  rule_divop_one      "quotInteger"         quotIntegerName         quot,-  rule_divop_one      "remInteger"          remIntegerName          rem,-  rule_divop_one      "divInteger"          divIntegerName          div,-  rule_divop_one      "modInteger"          modIntegerName          mod,-  rule_divop_both     "divModInteger"       divModIntegerName       divMod,-  rule_divop_both     "quotRemInteger"      quotRemIntegerName      quotRem,-  -- These rules below don't actually have to be built in, but if we-  -- put them in the Haskell source then we'd have to duplicate them-  -- between all Integer implementations-  rule_XToIntegerToX "smallIntegerToInt"       integerToIntName    smallIntegerName,-  rule_XToIntegerToX "wordToIntegerToWord"     integerToWordName   wordToIntegerName,-  rule_XToIntegerToX "int64ToIntegerToInt64"   integerToInt64Name  int64ToIntegerName,-  rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName,-  rule_smallIntegerTo "smallIntegerToWord"   integerToWordName     Int2WordOp,-  rule_smallIntegerTo "smallIntegerToFloat"  floatFromIntegerName  Int2FloatOp,-  rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp-  ]-    where rule_convert str name convert-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,-                           ru_try = match_Integer_convert convert }-          rule_IntToInteger str name-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,-                           ru_try = match_IntToInteger }-          rule_WordToInteger str name-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,-                           ru_try = match_WordToInteger }-          rule_Int64ToInteger str name-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,-                           ru_try = match_Int64ToInteger }-          rule_Word64ToInteger str name-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,-                           ru_try = match_Word64ToInteger }-          rule_unop str name op-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,-                           ru_try = match_Integer_unop op }-          rule_bitInteger str name-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,-                           ru_try = match_bitInteger }-          rule_binop str name op-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,-                           ru_try = match_Integer_binop op }-          rule_divop_both str name op-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,-                           ru_try = match_Integer_divop_both op }-          rule_divop_one str name op-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,-                           ru_try = match_Integer_divop_one op }-          rule_shift_op str name op-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,-                           ru_try = match_Integer_shift_op op }-          rule_binop_Prim str name op-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,-                           ru_try = match_Integer_binop_Prim op }-          rule_binop_Ordering str name op-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,-                           ru_try = match_Integer_binop_Ordering op }-          rule_encodeFloat str name op-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,-                           ru_try = match_Integer_Int_encodeFloat op }-          rule_decodeDouble str name-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,-                           ru_try = match_decodeDouble }-          rule_XToIntegerToX str name toIntegerName-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,-                           ru_try = match_XToIntegerToX toIntegerName }-          rule_smallIntegerTo str name primOp-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,-                           ru_try = match_smallIntegerTo primOp }-          rule_rationalTo str name mkLit-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,-                           ru_try = match_rationalTo mkLit }--builtinNaturalRules :: [CoreRule]-builtinNaturalRules =- [rule_binop              "plusNatural"        plusNaturalName         (+)- ,rule_partial_binop      "minusNatural"       minusNaturalName        (\a b -> if a >= b then Just (a - b) else Nothing)- ,rule_binop              "timesNatural"       timesNaturalName        (*)- ,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName- ,rule_NaturalToInteger   "naturalToInteger"   naturalToIntegerName- ,rule_WordToNatural      "wordToNatural"      wordToNaturalName- ]-    where rule_binop str name op-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,-                           ru_try = match_Natural_binop op }-          rule_partial_binop str name op-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,-                           ru_try = match_Natural_partial_binop op }-          rule_NaturalToInteger str name-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,-                           ru_try = match_NaturalToInteger }-          rule_NaturalFromInteger str name-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,-                           ru_try = match_NaturalFromInteger }-          rule_WordToNatural str name-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,-                           ru_try = match_WordToNatural }-------------------------------------------------------- The rule is this:---      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)---      =  unpackFoldrCString# "foobaz" c n--match_append_lit :: RuleFun-match_append_lit _ id_unf _-        [ Type ty1-        , lit1-        , c1-        , e2-        ]-  -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the-  -- `lit` and `c` arguments, lest this may fail to fire when building with-  -- -g3. See #16740.-  | (strTicks, Var unpk `App` Type ty2-                        `App` lit2-                        `App` c2-                        `App` n) <- stripTicksTop tickishFloatable e2-  , unpk `hasKey` unpackCStringFoldrIdKey-  , cheapEqExpr' tickishFloatable c1 c2-  , (c1Ticks, c1') <- stripTicksTop tickishFloatable c1-  , c2Ticks <- stripTicksTopT tickishFloatable c2-  , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1-  , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2-  = ASSERT( ty1 `eqType` ty2 )-    Just $ mkTicks strTicks-         $ Var unpk `App` Type ty1-                    `App` Lit (LitString (s1 `BS.append` s2))-                    `App` mkTicks (c1Ticks ++ c2Ticks) c1'-                    `App` n--match_append_lit _ _ _ _ = Nothing-------------------------------------------------------- The rule is this:---      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2--match_eq_string :: RuleFun-match_eq_string _ id_unf _-        [Var unpk1 `App` lit1, Var unpk2 `App` lit2]-  | unpk1 `hasKey` unpackCStringIdKey-  , unpk2 `hasKey` unpackCStringIdKey-  , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1-  , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2-  = Just (if s1 == s2 then trueValBool else falseValBool)--match_eq_string _ _ _ _ = Nothing--------------------------------------------------------- The rule is this:---      inline f_ty (f a b c) = <f's unfolding> a b c--- (if f has an unfolding, EVEN if it's a loop breaker)------ It's important to allow the argument to 'inline' to have args itself--- (a) because its more forgiving to allow the programmer to write---       inline f a b c---   or  inline (f a b c)--- (b) because a polymorphic f wll get a type argument that the---     programmer can't avoid------ Also, don't forget about 'inline's type argument!-match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)-match_inline (Type _ : e : _)-  | (Var f, args1) <- collectArgs e,-    Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)-             -- Ignore the IdUnfoldingFun here!-  = Just (mkApps unf args1)--match_inline _ = Nothing----- See Note [magicDictId magic] in `basicTypes/MkId.hs`--- for a description of what is going on here.-match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)-match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ]-  | Just (fieldTy, _)   <- splitFunTy_maybe $ dropForAlls $ idType wrap-  , Just (dictTy, _)    <- splitFunTy_maybe fieldTy-  , Just dictTc         <- tyConAppTyCon_maybe dictTy-  , Just (_,_,co)       <- unwrapNewTyCon_maybe dictTc-  = Just-  $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] []))-      `App` y--match_magicDict _ = Nothing------------------------------------------------------ Integer rules---   smallInteger  (79::Int#)  = 79::Integer---   wordToInteger (79::Word#) = 79::Integer--- Similarly Int64, Word64--match_IntToInteger :: RuleFun-match_IntToInteger = match_IntToInteger_unop id--match_WordToInteger :: RuleFun-match_WordToInteger _ id_unf id [xl]-  | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl-  = case splitFunTy_maybe (idType id) of-    Just (_, integerTy) ->-        Just (Lit (mkLitInteger x integerTy))-    _ ->-        panic "match_WordToInteger: Id has the wrong type"-match_WordToInteger _ _ _ _ = Nothing--match_Int64ToInteger :: RuleFun-match_Int64ToInteger _ id_unf id [xl]-  | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl-  = case splitFunTy_maybe (idType id) of-    Just (_, integerTy) ->-        Just (Lit (mkLitInteger x integerTy))-    _ ->-        panic "match_Int64ToInteger: Id has the wrong type"-match_Int64ToInteger _ _ _ _ = Nothing--match_Word64ToInteger :: RuleFun-match_Word64ToInteger _ id_unf id [xl]-  | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl-  = case splitFunTy_maybe (idType id) of-    Just (_, integerTy) ->-        Just (Lit (mkLitInteger x integerTy))-    _ ->-        panic "match_Word64ToInteger: Id has the wrong type"-match_Word64ToInteger _ _ _ _ = Nothing--match_NaturalToInteger :: RuleFun-match_NaturalToInteger _ id_unf id [xl]-  | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl-  = case splitFunTy_maybe (idType id) of-    Just (_, naturalTy) ->-        Just (Lit (LitNumber LitNumInteger x naturalTy))-    _ ->-        panic "match_NaturalToInteger: Id has the wrong type"-match_NaturalToInteger _ _ _ _ = Nothing--match_NaturalFromInteger :: RuleFun-match_NaturalFromInteger _ id_unf id [xl]-  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl-  , x >= 0-  = case splitFunTy_maybe (idType id) of-    Just (_, naturalTy) ->-        Just (Lit (LitNumber LitNumNatural x naturalTy))-    _ ->-        panic "match_NaturalFromInteger: Id has the wrong type"-match_NaturalFromInteger _ _ _ _ = Nothing--match_WordToNatural :: RuleFun-match_WordToNatural _ id_unf id [xl]-  | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl-  = case splitFunTy_maybe (idType id) of-    Just (_, naturalTy) ->-        Just (Lit (LitNumber LitNumNatural x naturalTy))-    _ ->-        panic "match_WordToNatural: Id has the wrong type"-match_WordToNatural _ _ _ _ = Nothing----------------------------------------------------{- Note [Rewriting bitInteger]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For most types the bitInteger operation can be implemented in terms of shifts.-The integer-gmp package, however, can do substantially better than this if-allowed to provide its own implementation. However, in so doing it previously lost-constant-folding (see #8832). The bitInteger rule above provides constant folding-specifically for this function.--There is, however, a bit of trickiness here when it comes to ranges. While the-AST encodes all integers as Integers, `bit` expects the bit-index to be given as an Int. Hence we coerce to an Int in the rule definition.-This will behave a bit funny for constants larger than the word size, but the user-should expect some funniness given that they will have at very least ignored a-warning in this case.--}--match_bitInteger :: RuleFun--- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer-match_bitInteger dflags id_unf fn [arg]-  | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg-  , x >= 0-  , x <= (wordSizeInBits dflags - 1)-    -- Make sure x is small enough to yield a decently small integer-    -- Attempting to construct the Integer for-    --    (bitInteger 9223372036854775807#)-    -- would be a bad idea (#14959)-  , let x_int = fromIntegral x :: Int-  = case splitFunTy_maybe (idType fn) of-    Just (_, integerTy)-      -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy))-    _ -> panic "match_IntToInteger_unop: Id has the wrong type"--match_bitInteger _ _ _ _ = Nothing-----------------------------------------------------match_Integer_convert :: Num a-                      => (DynFlags -> a -> Expr CoreBndr)-                      -> RuleFun-match_Integer_convert convert dflags id_unf _ [xl]-  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl-  = Just (convert dflags (fromInteger x))-match_Integer_convert _ _ _ _ _ = Nothing--match_Integer_unop :: (Integer -> Integer) -> RuleFun-match_Integer_unop unop _ id_unf _ [xl]-  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl-  = Just (Lit (LitNumber LitNumInteger (unop x) i))-match_Integer_unop _ _ _ _ _ = Nothing--match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun-match_IntToInteger_unop unop _ id_unf fn [xl]-  | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl-  = case splitFunTy_maybe (idType fn) of-    Just (_, integerTy) ->-        Just (Lit (LitNumber LitNumInteger (unop x) integerTy))-    _ ->-        panic "match_IntToInteger_unop: Id has the wrong type"-match_IntToInteger_unop _ _ _ _ _ = Nothing--match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun-match_Integer_binop binop _ id_unf _ [xl,yl]-  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl-  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl-  = Just (Lit (mkLitInteger (x `binop` y) i))-match_Integer_binop _ _ _ _ _ = Nothing--match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun-match_Natural_binop binop _ id_unf _ [xl,yl]-  | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl-  , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl-  = Just (Lit (mkLitNatural (x `binop` y) i))-match_Natural_binop _ _ _ _ _ = Nothing--match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun-match_Natural_partial_binop binop _ id_unf _ [xl,yl]-  | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl-  , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl-  , Just z <- x `binop` y-  = Just (Lit (mkLitNatural z i))-match_Natural_partial_binop _ _ _ _ _ = Nothing---- This helper is used for the quotRem and divMod functions-match_Integer_divop_both-   :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun-match_Integer_divop_both divop _ id_unf _ [xl,yl]-  | Just (LitNumber LitNumInteger x t) <- exprIsLiteral_maybe id_unf xl-  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl-  , y /= 0-  , (r,s) <- x `divop` y-  = Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)]-match_Integer_divop_both _ _ _ _ _ = Nothing---- This helper is used for the quot and rem functions-match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun-match_Integer_divop_one divop _ id_unf _ [xl,yl]-  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl-  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl-  , y /= 0-  = Just (Lit (mkLitInteger (x `divop` y) i))-match_Integer_divop_one _ _ _ _ _ = Nothing--match_Integer_shift_op :: (Integer -> Int -> Integer) -> RuleFun--- Used for shiftLInteger, shiftRInteger :: Integer -> Int# -> Integer--- See Note [Guarding against silly shifts]-match_Integer_shift_op binop _ id_unf _ [xl,yl]-  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl-  , Just (LitNumber LitNumInt y _)     <- exprIsLiteral_maybe id_unf yl-  , y >= 0-  , y <= 4   -- Restrict constant-folding of shifts on Integers, somewhat-             -- arbitrary.  We can get huge shifts in inaccessible code-             -- (#15673)-  = Just (Lit (mkLitInteger (x `binop` fromIntegral y) i))-match_Integer_shift_op _ _ _ _ _ = Nothing--match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun-match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]-  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl-  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl-  = Just (if x `binop` y then trueValInt dflags else falseValInt dflags)-match_Integer_binop_Prim _ _ _ _ _ = Nothing--match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun-match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]-  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl-  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl-  = Just $ case x `binop` y of-             LT -> ltVal-             EQ -> eqVal-             GT -> gtVal-match_Integer_binop_Ordering _ _ _ _ _ = Nothing--match_Integer_Int_encodeFloat :: RealFloat a-                              => (a -> Expr CoreBndr)-                              -> RuleFun-match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]-  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl-  , Just (LitNumber LitNumInt y _)     <- exprIsLiteral_maybe id_unf yl-  = Just (mkLit $ encodeFloat x (fromInteger y))-match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing-------------------------------------------------------- constant folding for Float/Double------ This turns---      rationalToFloat n d--- into a literal Float, and similarly for Doubles.------ it's important to not match d == 0, because that may represent a--- literal "0/0" or similar, and we can't produce a literal value for--- NaN or +-Inf-match_rationalTo :: RealFloat a-                 => (a -> Expr CoreBndr)-                 -> RuleFun-match_rationalTo mkLit _ id_unf _ [xl, yl]-  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl-  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl-  , y /= 0-  = Just (mkLit (fromRational (x % y)))-match_rationalTo _ _ _ _ _ = Nothing--match_decodeDouble :: RuleFun-match_decodeDouble dflags id_unf fn [xl]-  | Just (LitDouble x) <- exprIsLiteral_maybe id_unf xl-  = case splitFunTy_maybe (idType fn) of-    Just (_, res)-      | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res-      -> case decodeFloat (fromRational x :: Double) of-           (y, z) ->-             Just $ mkCoreUbxTup [integerTy, intHashTy]-                                 [Lit (mkLitInteger y integerTy),-                                  Lit (mkLitInt dflags (toInteger z))]-    _ ->-        pprPanic "match_decodeDouble: Id has the wrong type"-          (ppr fn <+> dcolon <+> ppr (idType fn))-match_decodeDouble _ _ _ _ = Nothing--match_XToIntegerToX :: Name -> RuleFun-match_XToIntegerToX n _ _ _ [App (Var x) y]-  | idName x == n-  = Just y-match_XToIntegerToX _ _ _ _ _ = Nothing--match_smallIntegerTo :: PrimOp -> RuleFun-match_smallIntegerTo primOp _ _ _ [App (Var x) y]-  | idName x == smallIntegerName-  = Just $ App (Var (mkPrimOpId primOp)) y-match_smallIntegerTo _ _ _ _ _ = Nothing--------------------------------------------------------------- Note [Constant folding through nested expressions]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ We use rewrites rules to perform constant folding. It means that we don't--- have a global view of the expression we are trying to optimise. As a--- consequence we only perform local (small-step) transformations that either:---    1) reduce the number of operations---    2) rearrange the expression to increase the odds that other rules will---    match------ We don't try to handle more complex expression optimisation cases that would--- require a global view. For example, rewriting expressions to increase--- sharing (e.g., Horner's method); optimisations that require local--- transformations increasing the number of operations; rearrangements to--- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0).------ We already have rules to perform constant folding on expressions with the--- following shape (where a and/or b are literals):------          D)    op---                /\---               /  \---              /    \---             a      b------ To support nested expressions, we match three other shapes of expression--- trees:------ A)   op1          B)       op1       C)       op1---      /\                    /\                 /\---     /  \                  /  \               /  \---    /    \                /    \             /    \---   a     op2            op2     c          op2    op3---          /\            /\                 /\      /\---         /  \          /  \               /  \    /  \---        b    c        a    b             a    b  c    d--------- R1) +/- simplification:---    ops = + or -, two literals (not siblings)------    Examples:---       A: 5 + (10-x)  ==> 15-x---       B: (10+x) + 5  ==> 15+x---       C: (5+a)-(5-b) ==> 0+(a+b)------ R2) * simplification---    ops = *, two literals (not siblings)------    Examples:---       A: 5 * (10*x)  ==> 50*x---       B: (10*x) * 5  ==> 50*x---       C: (5*a)*(5*b) ==> 25*(a*b)------ R3) * distribution over +/----    op1 = *, op2 = + or -, two literals (not siblings)------    This transformation doesn't reduce the number of operations but switches---    the outer and the inner operations so that the outer is (+) or (-) instead---    of (*). It increases the odds that other rules will match after this one.------    Examples:---       A: 5 * (10-x)  ==> 50 - (5*x)---       B: (10+x) * 5  ==> 50 + (5*x)---       C: Not supported as it would increase the number of operations:---          (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b------ R4) Simple factorization------    op1 = + or -, op2/op3 = *,---    one literal for each innermost * operation (except in the D case),---    the two other terms are equals------    Examples:---       A: x - (10*x)  ==> (-9)*x---       B: (10*x) + x  ==> 11*x---       C: (5*x)-(x*3) ==> 2*x---       D: x+x         ==> 2*x------ R5) +/- propagation------    ops = + or -, one literal------    This transformation doesn't reduce the number of operations but propagates---    the constant to the outer level. It increases the odds that other rules---    will match after this one.------    Examples:---       A: x - (10-y)  ==> (x+y) - 10---       B: (10+x) - y  ==> 10 + (x-y)---       C: N/A (caught by the A and B cases)---------------------------------------------------------------- | Rules to perform constant folding into nested expressions------See Note [Constant folding through nested expressions]-numFoldingRules :: PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr-numFoldingRules op dict = do-  [e1,e2] <- getArgs-  dflags <- getDynFlags-  let PrimOps{..} = dict dflags-  if not (gopt Opt_NumConstantFolding dflags)-    then mzero-    else case BinOpApp e1 op e2 of-     -- R1) +/- simplification-     x    :++: (y :++: v)          -> return $ mkL (x+y)   `add` v-     x    :++: (L y :-: v)         -> return $ mkL (x+y)   `sub` v-     x    :++: (v   :-: L y)       -> return $ mkL (x-y)   `add` v-     L x  :-:  (y :++: v)          -> return $ mkL (x-y)   `sub` v-     L x  :-:  (L y :-: v)         -> return $ mkL (x-y)   `add` v-     L x  :-:  (v   :-: L y)       -> return $ mkL (x+y)   `sub` v--     (y :++: v)    :-: L x         -> return $ mkL (y-x)   `add` v-     (L y :-: v)   :-: L x         -> return $ mkL (y-x)   `sub` v-     (v   :-: L y) :-: L x         -> return $ mkL (0-y-x) `add` v--     (x :++: w)  :+: (y :++: v)    -> return $ mkL (x+y)   `add` (w `add` v)-     (w :-: L x) :+: (L y :-: v)   -> return $ mkL (y-x)   `add` (w `sub` v)-     (w :-: L x) :+: (v   :-: L y) -> return $ mkL (0-x-y) `add` (w `add` v)-     (L x :-: w) :+: (L y :-: v)   -> return $ mkL (x+y)   `sub` (w `add` v)-     (L x :-: w) :+: (v   :-: L y) -> return $ mkL (x-y)   `add` (v `sub` w)-     (w :-: L x) :+: (y :++: v)    -> return $ mkL (y-x)   `add` (w `add` v)-     (L x :-: w) :+: (y :++: v)    -> return $ mkL (x+y)   `add` (v `sub` w)-     (y :++: v)  :+: (w :-: L x)   -> return $ mkL (y-x)   `add` (w `add` v)-     (y :++: v)  :+: (L x :-: w)   -> return $ mkL (x+y)   `add` (v `sub` w)--     (v   :-: L y) :-: (w :-: L x) -> return $ mkL (x-y)   `add` (v `sub` w)-     (v   :-: L y) :-: (L x :-: w) -> return $ mkL (0-x-y) `add` (v `add` w)-     (L y :-:   v) :-: (w :-: L x) -> return $ mkL (x+y)   `sub` (v `add` w)-     (L y :-:   v) :-: (L x :-: w) -> return $ mkL (y-x)   `add` (w `sub` v)-     (x :++: w)    :-: (y :++: v)  -> return $ mkL (x-y)   `add` (w `sub` v)-     (w :-: L x)   :-: (y :++: v)  -> return $ mkL (0-y-x) `add` (w `sub` v)-     (L x :-: w)   :-: (y :++: v)  -> return $ mkL (x-y)   `sub` (v `add` w)-     (y :++: v)    :-: (w :-: L x) -> return $ mkL (y+x)   `add` (v `sub` w)-     (y :++: v)    :-: (L x :-: w) -> return $ mkL (y-x)   `add` (v `add` w)--     -- R2) * simplification-     x :**: (y :**: v)             -> return $ mkL (x*y)   `mul` v-     (x :**: w) :*: (y :**: v)     -> return $ mkL (x*y)   `mul` (w `mul` v)--     -- R3) * distribution over +/--     x :**: (y :++: v)             -> return $ mkL (x*y)   `add` (mkL x `mul` v)-     x :**: (L y :-: v)            -> return $ mkL (x*y)   `sub` (mkL x `mul` v)-     x :**: (v   :-: L y)          -> return $ (mkL x `mul` v) `sub` mkL (x*y)--     -- R4) Simple factorization-     v :+: w-      | w `cheapEqExpr` v          -> return $ mkL 2       `mul` v-     w :+: (y :**: v)-      | w `cheapEqExpr` v          -> return $ mkL (1+y)   `mul` v-     w :-: (y :**: v)-      | w `cheapEqExpr` v          -> return $ mkL (1-y)   `mul` v-     (y :**: v) :+: w-      | w `cheapEqExpr` v          -> return $ mkL (y+1)   `mul` v-     (y :**: v) :-: w-      | w `cheapEqExpr` v          -> return $ mkL (y-1)   `mul` v-     (x :**: w) :+: (y :**: v)-      | w `cheapEqExpr` v          -> return $ mkL (x+y)   `mul` v-     (x :**: w) :-: (y :**: v)-      | w `cheapEqExpr` v          -> return $ mkL (x-y)   `mul` v--     -- R5) +/- propagation-     w  :+: (y :++: v)             -> return $ mkL y `add` (w `add` v)-     (y :++: v) :+: w              -> return $ mkL y       `add` (w `add` v)-     w  :-: (y :++: v)             -> return $ (w `sub` v) `sub` mkL y-     (y :++: v) :-: w              -> return $ mkL y       `add` (v `sub` w)-     w    :-: (L y :-: v)          -> return $ (w `add` v) `sub` mkL y-     (L y :-: v) :-: w             -> return $ mkL y       `sub` (w `add` v)-     w    :+: (L y :-: v)          -> return $ mkL y       `add` (w `sub` v)-     w    :+: (v :-: L y)          -> return $ (w `add` v) `sub` mkL y-     (L y :-: v) :+: w             -> return $ mkL y       `add` (w `sub` v)-     (v :-: L y) :+: w             -> return $ (w `add` v) `sub` mkL y--     _                             -> mzero------ | Match the application of a binary primop-pattern BinOpApp  :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr-pattern BinOpApp  x op y =  OpVal op `App` x `App` y---- | Match a primop-pattern OpVal   :: PrimOp  -> Arg CoreBndr-pattern OpVal   op     <- Var (isPrimOpId_maybe -> Just op) where-   OpVal op = Var (mkPrimOpId op)------ | Match a literal-pattern L :: Integer -> Arg CoreBndr-pattern L l <- Lit (isLitValue_maybe -> Just l)---- | Match an addition-pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr-pattern x :+: y <- BinOpApp x (isAddOp -> True) y---- | Match an addition with a literal (handle commutativity)-pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr-pattern l :++: x <- (isAdd -> Just (l,x))--isAdd :: CoreExpr -> Maybe (Integer,CoreExpr)-isAdd e = case e of-   L l :+: x   -> Just (l,x)-   x   :+: L l -> Just (l,x)-   _           -> Nothing---- | Match a multiplication-pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr-pattern x :*: y <- BinOpApp x (isMulOp -> True) y---- | Match a multiplication with a literal (handle commutativity)-pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr-pattern l :**: x <- (isMul -> Just (l,x))--isMul :: CoreExpr -> Maybe (Integer,CoreExpr)-isMul e = case e of-   L l :*: x   -> Just (l,x)-   x   :*: L l -> Just (l,x)-   _           -> Nothing----- | Match a subtraction-pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr-pattern x :-: y <- BinOpApp x (isSubOp -> True) y--isSubOp :: PrimOp -> Bool-isSubOp IntSubOp  = True-isSubOp WordSubOp = True-isSubOp _         = False--isAddOp :: PrimOp -> Bool-isAddOp IntAddOp  = True-isAddOp WordAddOp = True-isAddOp _         = False--isMulOp :: PrimOp -> Bool-isMulOp IntMulOp  = True-isMulOp WordMulOp = True-isMulOp _         = False---- | Explicit "type-class"-like dictionary for numeric primops------ Depends on DynFlags because creating a literal value depends on DynFlags-data PrimOps = PrimOps-   { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers-   , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers-   , mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers-   , mkL :: Integer -> CoreExpr              -- ^ Create a literal value-   }--intPrimOps :: DynFlags -> PrimOps-intPrimOps dflags = PrimOps-   { add = \x y -> BinOpApp x IntAddOp y-   , sub = \x y -> BinOpApp x IntSubOp y-   , mul = \x y -> BinOpApp x IntMulOp y-   , mkL = intResult' dflags-   }--wordPrimOps :: DynFlags -> PrimOps-wordPrimOps dflags = PrimOps-   { add = \x y -> BinOpApp x WordAddOp y-   , sub = \x y -> BinOpApp x WordSubOp y-   , mul = \x y -> BinOpApp x WordMulOp y-   , mkL = wordResult' dflags-   }-------------------------------------------------------------- Constant folding through case-expressions------ cf Scrutinee Constant Folding in simplCore/SimplUtils------------------------------------------------------------- | Match the scrutinee of a case and potentially return a new scrutinee and a--- function to apply to each literal alternative.-caseRules :: DynFlags-          -> CoreExpr                       -- Scrutinee-          -> Maybe ( CoreExpr               -- New scrutinee-                   , AltCon -> Maybe AltCon -- How to fix up the alt pattern-                                            --   Nothing <=> Unreachable-                                            -- See Note [Unreachable caseRules alternatives]-                   , Id -> CoreExpr)        -- How to reconstruct the original scrutinee-                                            -- from the new case-binder--- e.g  case e of b {---         ...;---         con bs -> rhs;---         ... }---  ==>---      case e' of b' {---         ...;---         fixup_altcon[con] bs -> let b = mk_orig[b] in rhs;---         ... }--caseRules dflags (App (App (Var f) v) (Lit l))   -- v `op` x#-  | Just op <- isPrimOpId_maybe f-  , Just x  <- isLitValue_maybe l-  , Just adjust_lit <- adjustDyadicRight op x-  = Just (v, tx_lit_con dflags adjust_lit-           , \v -> (App (App (Var f) (Var v)) (Lit l)))--caseRules dflags (App (App (Var f) (Lit l)) v)   -- x# `op` v-  | Just op <- isPrimOpId_maybe f-  , Just x  <- isLitValue_maybe l-  , Just adjust_lit <- adjustDyadicLeft x op-  = Just (v, tx_lit_con dflags adjust_lit-           , \v -> (App (App (Var f) (Lit l)) (Var v)))---caseRules dflags (App (Var f) v              )   -- op v-  | Just op <- isPrimOpId_maybe f-  , Just adjust_lit <- adjustUnary op-  = Just (v, tx_lit_con dflags adjust_lit-           , \v -> App (Var f) (Var v))---- See Note [caseRules for tagToEnum]-caseRules dflags (App (App (Var f) type_arg) v)-  | Just TagToEnumOp <- isPrimOpId_maybe f-  = Just (v, tx_con_tte dflags-           , \v -> (App (App (Var f) type_arg) (Var v)))---- See Note [caseRules for dataToTag]-caseRules _ (App (App (Var f) (Type ty)) v)       -- dataToTag x-  | Just DataToTagOp <- isPrimOpId_maybe f-  , Just (tc, _) <- tcSplitTyConApp_maybe ty-  , isAlgTyCon tc-  = Just (v, tx_con_dtt ty-           , \v -> App (App (Var f) (Type ty)) (Var v))--caseRules _ _ = Nothing---tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon-tx_lit_con _      _      DEFAULT    = Just DEFAULT-tx_lit_con dflags adjust (LitAlt l) = Just $ LitAlt (mapLitValue dflags adjust l)-tx_lit_con _      _      alt        = pprPanic "caseRules" (ppr alt)-   -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the-   -- literal alternatives remain in Word/Int target ranges-   -- (See Note [Word/Int underflow/overflow] in Literal and #13172).--adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)--- Given (x `op` lit) return a function 'f' s.t.  f (x `op` lit) = x-adjustDyadicRight op lit-  = case op of-         WordAddOp -> Just (\y -> y-lit      )-         IntAddOp  -> Just (\y -> y-lit      )-         WordSubOp -> Just (\y -> y+lit      )-         IntSubOp  -> Just (\y -> y+lit      )-         XorOp     -> Just (\y -> y `xor` lit)-         XorIOp    -> Just (\y -> y `xor` lit)-         _         -> Nothing--adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer)--- Given (lit `op` x) return a function 'f' s.t.  f (lit `op` x) = x-adjustDyadicLeft lit op-  = case op of-         WordAddOp -> Just (\y -> y-lit      )-         IntAddOp  -> Just (\y -> y-lit      )-         WordSubOp -> Just (\y -> lit-y      )-         IntSubOp  -> Just (\y -> lit-y      )-         XorOp     -> Just (\y -> y `xor` lit)-         XorIOp    -> Just (\y -> y `xor` lit)-         _         -> Nothing---adjustUnary :: PrimOp -> Maybe (Integer -> Integer)--- Given (op x) return a function 'f' s.t.  f (op x) = x-adjustUnary op-  = case op of-         NotOp     -> Just (\y -> complement y)-         NotIOp    -> Just (\y -> complement y)-         IntNegOp  -> Just (\y -> negate y    )-         _         -> Nothing--tx_con_tte :: DynFlags -> AltCon -> Maybe AltCon-tx_con_tte _      DEFAULT         = Just DEFAULT-tx_con_tte _      alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt)-tx_con_tte dflags (DataAlt dc)  -- See Note [caseRules for tagToEnum]-  = Just $ LitAlt $ mkLitInt dflags $ toInteger $ dataConTagZ dc--tx_con_dtt :: Type -> AltCon -> Maybe AltCon-tx_con_dtt _  DEFAULT = Just DEFAULT-tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _))-   | tag >= 0-   , tag < n_data_cons-   = Just (DataAlt (data_cons !! tag))   -- tag is zero-indexed, as is (!!)-   | otherwise-   = Nothing-   where-     tag         = fromInteger i :: ConTagZ-     tc          = tyConAppTyCon ty-     n_data_cons = tyConFamilySize tc-     data_cons   = tyConDataCons tc--tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)---{- Note [caseRules for tagToEnum]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to transform-   case tagToEnum x of-     False -> e1-     True  -> e2-into-   case x of-     0# -> e1-     1# -> e2--This rule eliminates a lot of boilerplate. For-  if (x>y) then e2 else e1-we generate-  case tagToEnum (x ># y) of-    False -> e1-    True  -> e2-and it is nice to then get rid of the tagToEnum.--Beware (#14768): avoid the temptation to map constructor 0 to-DEFAULT, in the hope of getting this-  case (x ># y) of-    DEFAULT -> e1-    1#      -> e2-That fails utterly in the case of-   data Colour = Red | Green | Blue-   case tagToEnum x of-      DEFAULT -> e1-      Red     -> e2--We don't want to get this!-   case x of-      DEFAULT -> e1-      DEFAULT -> e2--Instead, we deal with turning one branch into DEFAULT in SimplUtils-(add_default in mkCase3).--Note [caseRules for dataToTag]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [dataToTag#] in primpops.txt.pp--We want to transform-  case dataToTag x of-    DEFAULT -> e1-    1# -> e2-into-  case x of-    DEFAULT -> e1-    (:) _ _ -> e2--Note the need for some wildcard binders in-the 'cons' case.--For the time, we only apply this transformation when the type of `x` is a type-headed by a normal tycon. In particular, we do not apply this in the case of a-data family tycon, since that would require carefully applying coercion(s)-between the data family and the data family instance's representation type,-which caseRules isn't currently engineered to handle (#14680).--Note [Unreachable caseRules alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Take care if we see something like-  case dataToTag x of-    DEFAULT -> e1-    -1# -> e2-    100 -> e3-because there isn't a data constructor with tag -1 or 100. In this case the-out-of-range alternative is dead code -- we know the range of tags for x.--Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating-an alternative that is unreachable.--You may wonder how this can happen: check out #15436.--}
compiler/prelude/PrimOp.hs view
@@ -31,22 +31,22 @@ import TysWiredIn  import GHC.Cmm.Type-import Demand-import Id               ( Id, mkVanillaGlobalWithInfo )-import IdInfo           ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) )-import Name-import PrelNames        ( gHC_PRIMOPWRAPPERS )-import TyCon            ( TyCon, isPrimTyCon, PrimRep(..) )-import Type-import GHC.Types.RepType          ( typePrimRep1, tyConPrimRep1 )-import BasicTypes       ( Arity, Fixity(..), FixityDirection(..), Boxity(..),-                          SourceText(..) )-import SrcLoc           ( wiredInSrcSpan )-import ForeignCall      ( CLabelString )-import Unique           ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique )+import GHC.Types.Demand+import GHC.Types.Id      ( Id, mkVanillaGlobalWithInfo )+import GHC.Types.Id.Info ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) )+import GHC.Types.Name+import PrelNames         ( gHC_PRIMOPWRAPPERS )+import GHC.Core.TyCon    ( TyCon, isPrimTyCon, PrimRep(..) )+import GHC.Core.Type+import GHC.Types.RepType ( typePrimRep1, tyConPrimRep1 )+import GHC.Types.Basic   ( Arity, Fixity(..), FixityDirection(..), Boxity(..),+                           SourceText(..) )+import GHC.Types.SrcLoc  ( wiredInSrcSpan )+import GHC.Types.ForeignCall ( CLabelString )+import GHC.Types.Unique  ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique )+import GHC.Types.Module  ( UnitId ) import Outputable import FastString-import Module           ( UnitId )  {- ************************************************************************@@ -498,7 +498,8 @@ {- Note [primOpIsCheap] ~~~~~~~~~~~~~~~~~~~~-@primOpIsCheap@, as used in \tr{SimplUtils.hs}.  For now (HACK++@primOpIsCheap@, as used in GHC.Core.Op.Simplify.Utils.  For now (HACK WARNING), we just borrow some other predicates for a what-should-be-good-enough test.  "Cheap" means willing to call it more than once, and/or push it inside a lambda.  The latter could change the
compiler/prelude/TysPrim.hs view
@@ -110,16 +110,16 @@   , doubleElemRepDataConTy   , mkPromotedListTy ) -import Var              ( TyVar, mkTyVar )-import Name-import TyCon-import SrcLoc-import Unique+import GHC.Types.Var    ( TyVar, mkTyVar )+import GHC.Types.Name+import GHC.Core.TyCon+import GHC.Types.SrcLoc+import GHC.Types.Unique import PrelNames import FastString import Outputable-import TyCoRep   -- Doesn't need special access, but this is easier to avoid-                 -- import loops which show up if you import Type instead+import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid+                         -- import loops which show up if you import Type instead  import Data.Char @@ -475,14 +475,14 @@  Note [PrimRep and kindPrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As part of its source code, in TyCon, GHC has+As part of its source code, in GHC.Core.TyCon, GHC has   data PrimRep = LiftedRep | UnliftedRep | IntRep | FloatRep | ...etc...  Notice that  * RuntimeRep is part of the syntax tree of the program being compiled      (defined in a library: ghc-prim:GHC.Types)  * PrimRep is part of GHC's source code.-     (defined in TyCon)+     (defined in GHC.Core.TyCon)  We need to get from one to the other; that is what kindPrimRep does. Suppose we have a value@@ -707,7 +707,7 @@ Type.classifyPredType.  All wanted constraints of this type are built with coercion holes.-(See Note [Coercion holes] in TyCoRep.) But see also+(See Note [Coercion holes] in GHC.Core.TyCo.Rep.) But see also Note [Deferred errors for coercion holes] in TcErrors to see how equality constraints are deferred.
compiler/prelude/TysWiredIn.hs view
@@ -16,7 +16,7 @@         mkWiredInTyConName, -- This is used in TcTypeNats to define the                             -- built-in functions for evaluation. -        mkWiredInIdName,    -- used in MkId+        mkWiredInIdName,    -- used in GHC.Types.Id.Make          -- * All wired in things         wiredInTyCons, isBuiltInOcc_maybe,@@ -132,7 +132,7 @@  import GhcPrelude -import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId )+import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId )  -- friends: import PrelNames@@ -140,24 +140,24 @@ import {-# SOURCE #-} KnownUniques  -- others:-import CoAxiom-import Id+import GHC.Core.Coercion.Axiom+import GHC.Types.Id import Constants        ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )-import Module           ( Module )-import Type+import GHC.Types.Module ( Module )+import GHC.Core.Type import GHC.Types.RepType-import DataCon-import {-# SOURCE #-} ConLike-import TyCon-import Class            ( Class, mkClass )-import RdrName-import Name-import NameEnv          ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF )-import NameSet          ( NameSet, mkNameSet, elemNameSet )-import BasicTypes-import ForeignCall-import SrcLoc           ( noSrcSpan )-import Unique+import GHC.Core.DataCon+import {-# SOURCE #-} GHC.Core.ConLike+import GHC.Core.TyCon+import GHC.Core.Class     ( Class, mkClass )+import GHC.Types.Name.Reader+import GHC.Types.Name as Name+import GHC.Types.Name.Env ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF )+import GHC.Types.Name.Set ( NameSet, mkNameSet, elemNameSet )+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.SrcLoc   ( noSrcSpan )+import GHC.Types.Unique import Data.Array import FastString import Outputable@@ -933,7 +933,7 @@     tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con                          UnboxedTuple flavour -    -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+    -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon     -- Kind:  forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> #     tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)                                         (\ks -> map tYPE ks)
compiler/prelude/TysWiredIn.hs-boot view
@@ -1,10 +1,10 @@ module TysWiredIn where -import {-# SOURCE #-} TyCon      ( TyCon )-import {-# SOURCE #-} TyCoRep    (Type, Kind)+import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon )+import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind) -import BasicTypes (Arity, TupleSort)-import Name (Name)+import GHC.Types.Basic (Arity, TupleSort)+import GHC.Types.Name (Name)  listTyCon :: TyCon typeNatKind, typeSymbolKind :: Type
− compiler/profiling/CostCentre.hs 
@@ -1,359 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-module CostCentre (-        CostCentre(..), CcName, CCFlavour(..),-                -- All abstract except to friend: ParseIface.y--        CostCentreStack,-        CollectedCCs, emptyCollectedCCs, collectCC,-        currentCCS, dontCareCCS,-        isCurrentCCS,-        maybeSingletonCCS,--        mkUserCC, mkAutoCC, mkAllCafsCC,-        mkSingletonCCS,-        isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule,--        pprCostCentreCore,-        costCentreUserName, costCentreUserNameFS,-        costCentreSrcSpan,--        cmpCostCentre   -- used for removing dups in a list-    ) where--import GhcPrelude--import Binary-import Var-import Name-import Module-import Unique-import Outputable-import SrcLoc-import FastString-import Util-import CostCentreState--import Data.Data---------------------------------------------------------------------------------- Cost Centres---- | A Cost Centre is a single @{-# SCC #-}@ annotation.--data CostCentre-  = NormalCC {-                cc_flavour  :: CCFlavour,-                 -- ^ Two cost centres may have the same name and-                 -- module but different SrcSpans, so we need a way to-                 -- distinguish them easily and give them different-                 -- object-code labels.  So every CostCentre has an-                 -- associated flavour that indicates how it was-                 -- generated, and flavours that allow multiple instances-                 -- of the same name and module have a deterministic 0-based-                 -- index.-                cc_name :: CcName,      -- ^ Name of the cost centre itself-                cc_mod  :: Module,      -- ^ Name of module defining this CC.-                cc_loc  :: SrcSpan-    }--  | AllCafsCC {-                cc_mod  :: Module,      -- Name of module defining this CC.-                cc_loc  :: SrcSpan-    }-  deriving Data--type CcName = FastString---- | The flavour of a cost centre.------ Index fields represent 0-based indices giving source-code ordering of--- centres with the same module, name, and flavour.-data CCFlavour = CafCC -- ^ Auto-generated top-level thunk-               | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression-               | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration-               | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage-               deriving (Eq, Ord, Data)---- | Extract the index from a flavour-flavourIndex :: CCFlavour -> Int-flavourIndex CafCC = 0-flavourIndex (ExprCC x) = unCostCentreIndex x-flavourIndex (DeclCC x) = unCostCentreIndex x-flavourIndex (HpcCC x) = unCostCentreIndex x--instance Eq CostCentre where-        c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }--instance Ord CostCentre where-        compare = cmpCostCentre--cmpCostCentre :: CostCentre -> CostCentre -> Ordering--cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2})-  = m1 `compare` m2--cmpCostCentre NormalCC {cc_flavour = f1, cc_mod =  m1, cc_name = n1}-              NormalCC {cc_flavour = f2, cc_mod =  m2, cc_name = n2}-    -- first key is module name, then centre name, then flavour-  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2)--cmpCostCentre other_1 other_2-  = let-        tag1 = tag_CC other_1-        tag2 = tag_CC other_2-    in-    if tag1 < tag2 then LT else GT-  where-    tag_CC :: CostCentre -> Int-    tag_CC (NormalCC   {}) = 0-    tag_CC (AllCafsCC  {}) = 1----------------------------------------------------------------------------------- Predicates on CostCentre--isCafCC :: CostCentre -> Bool-isCafCC (AllCafsCC {})                  = True-isCafCC (NormalCC {cc_flavour = CafCC}) = True-isCafCC _                               = False---- | Is this a cost-centre which records scc counts-isSccCountCC :: CostCentre -> Bool-isSccCountCC cc | isCafCC cc  = False-                | otherwise   = True---- | Is this a cost-centre which can be sccd ?-sccAbleCC :: CostCentre -> Bool-sccAbleCC cc | isCafCC cc = False-             | otherwise  = True--ccFromThisModule :: CostCentre -> Module -> Bool-ccFromThisModule cc m = cc_mod cc == m----------------------------------------------------------------------------------- Building cost centres--mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre-mkUserCC cc_name mod loc flavour-  = NormalCC { cc_name = cc_name, cc_mod =  mod, cc_loc = loc,-               cc_flavour = flavour-    }--mkAutoCC :: Id -> Module -> CostCentre-mkAutoCC id mod-  = NormalCC { cc_name = str, cc_mod =  mod,-               cc_loc = nameSrcSpan (getName id),-               cc_flavour = CafCC-    }-  where-        name = getName id-        -- beware: only external names are guaranteed to have unique-        -- Occnames.  If the name is not external, we must append its-        -- Unique.-        -- See bug #249, tests prof001, prof002,  also #2411-        str | isExternalName name = occNameFS (getOccName id)-            | otherwise           = occNameFS (getOccName id)-                                    `appendFS`-                                    mkFastString ('_' : show (getUnique name))-mkAllCafsCC :: Module -> SrcSpan -> CostCentre-mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc }---------------------------------------------------------------------------------- Cost Centre Stacks---- | A Cost Centre Stack is something that can be attached to a closure.--- This is either:------      * the current cost centre stack (CCCS)---      * a pre-defined cost centre stack (there are several---        pre-defined CCSs, see below).--data CostCentreStack-  = CurrentCCS          -- Pinned on a let(rec)-bound-                        -- thunk/function/constructor, this says that the-                        -- cost centre to be attached to the object, when it-                        -- is allocated, is whatever is in the-                        -- current-cost-centre-stack register.--  | DontCareCCS         -- We need a CCS to stick in static closures-                        -- (for data), but we *don't* expect them to-                        -- accumulate any costs.  But we still need-                        -- the placeholder.  This CCS is it.--  | SingletonCCS CostCentre--  deriving (Eq, Ord)    -- needed for Ord on CLabel----- synonym for triple which describes the cost centre info in the generated--- code for a module.-type CollectedCCs-  = ( [CostCentre]       -- local cost-centres that need to be decl'd-    , [CostCentreStack]  -- pre-defined "singleton" cost centre stacks-    )--emptyCollectedCCs :: CollectedCCs-emptyCollectedCCs = ([], [])--collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs-collectCC cc ccs (c, cs) = (cc : c, ccs : cs)--currentCCS, dontCareCCS :: CostCentreStack--currentCCS              = CurrentCCS-dontCareCCS             = DontCareCCS---------------------------------------------------------------------------------- Predicates on Cost-Centre Stacks--isCurrentCCS :: CostCentreStack -> Bool-isCurrentCCS CurrentCCS                 = True-isCurrentCCS _                          = False--isCafCCS :: CostCentreStack -> Bool-isCafCCS (SingletonCCS cc)              = isCafCC cc-isCafCCS _                              = False--maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre-maybeSingletonCCS (SingletonCCS cc)     = Just cc-maybeSingletonCCS _                     = Nothing--mkSingletonCCS :: CostCentre -> CostCentreStack-mkSingletonCCS cc = SingletonCCS cc----------------------------------------------------------------------------------- Printing Cost Centre Stacks.---- The outputable instance for CostCentreStack prints the CCS as a C--- expression.--instance Outputable CostCentreStack where-  ppr CurrentCCS        = text "CCCS"-  ppr DontCareCCS       = text "CCS_DONT_CARE"-  ppr (SingletonCCS cc) = ppr cc <> text "_ccs"----------------------------------------------------------------------------------- Printing Cost Centres------ There are several different ways in which we might want to print a--- cost centre:------      - the name of the cost centre, for profiling output (a C string)---      - the label, i.e. C label for cost centre in .hc file.---      - the debugging name, for output in -ddump things---      - the interface name, for printing in _scc_ exprs in iface files.------ The last 3 are derived from costCentreStr below.  The first is given--- by costCentreName.--instance Outputable CostCentre where-  ppr cc = getPprStyle $ \ sty ->-           if codeStyle sty-           then ppCostCentreLbl cc-           else text (costCentreUserName cc)---- Printing in Core-pprCostCentreCore :: CostCentre -> SDoc-pprCostCentreCore (AllCafsCC {cc_mod = m})-  = text "__sccC" <+> braces (ppr m)-pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n,-                             cc_mod = m, cc_loc = loc})-  = text "__scc" <+> braces (hsep [-        ppr m <> char '.' <> ftext n,-        pprFlavourCore flavour,-        whenPprDebug (ppr loc)-    ])---- ^ Print a flavour in Core-pprFlavourCore :: CCFlavour -> SDoc-pprFlavourCore CafCC = text "__C"-pprFlavourCore f     = pprIdxCore $ flavourIndex f---- ^ Print a flavour's index in Core-pprIdxCore :: Int -> SDoc-pprIdxCore 0 = empty-pprIdxCore idx = whenPprDebug $ ppr idx---- Printing as a C label-ppCostCentreLbl :: CostCentre -> SDoc-ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = ppr m <> text "_CAFs_cc"-ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m})-  = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>-        ppFlavourLblComponent f <> text "_cc"---- ^ Print the flavour component of a C label-ppFlavourLblComponent :: CCFlavour -> SDoc-ppFlavourLblComponent CafCC = text "CAF"-ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i-ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i-ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i---- ^ Print the flavour index component of a C label-ppIdxLblComponent :: CostCentreIndex -> SDoc-ppIdxLblComponent n =-  case unCostCentreIndex n of-    0 -> empty-    n -> ppr n---- This is the name to go in the user-displayed string,--- recorded in the cost centre declaration-costCentreUserName :: CostCentre -> String-costCentreUserName = unpackFS . costCentreUserNameFS--costCentreUserNameFS :: CostCentre -> FastString-costCentreUserNameFS (AllCafsCC {})  = mkFastString "CAF"-costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf})-  =  case is_caf of-      CafCC -> mkFastString "CAF:" `appendFS` name-      _     -> name--costCentreSrcSpan :: CostCentre -> SrcSpan-costCentreSrcSpan = cc_loc--instance Binary CCFlavour where-    put_ bh CafCC = do-            putByte bh 0-    put_ bh (ExprCC i) = do-            putByte bh 1-            put_ bh i-    put_ bh (DeclCC i) = do-            putByte bh 2-            put_ bh i-    put_ bh (HpcCC i) = do-            putByte bh 3-            put_ bh i-    get bh = do-            h <- getByte bh-            case h of-              0 -> do return CafCC-              1 -> ExprCC <$> get bh-              2 -> DeclCC <$> get bh-              _ -> HpcCC <$> get bh--instance Binary CostCentre where-    put_ bh (NormalCC aa ab ac _ad) = do-            putByte bh 0-            put_ bh aa-            put_ bh ab-            put_ bh ac-    put_ bh (AllCafsCC ae _af) = do-            putByte bh 1-            put_ bh ae-    get bh = do-            h <- getByte bh-            case h of-              0 -> do aa <- get bh-                      ab <- get bh-                      ac <- get bh-                      return (NormalCC aa ab ac noSrcSpan)-              _ -> do ae <- get bh-                      return (AllCafsCC ae noSrcSpan)--    -- We ignore the SrcSpans in CostCentres when we serialise them,-    -- and set the SrcSpans to noSrcSpan when deserialising.  This is-    -- ok, because we only need the SrcSpan when declaring the-    -- CostCentre in the original module, it is not used by importing-    -- modules.
− compiler/profiling/CostCentreState.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module CostCentreState ( CostCentreState, newCostCentreState-                       , CostCentreIndex, unCostCentreIndex, getCCIndex-                       ) where--import GhcPrelude-import FastString-import FastStringEnv--import Data.Data-import Binary---- | Per-module state for tracking cost centre indices.------ See documentation of 'CostCentre.cc_flavour' for more details.-newtype CostCentreState = CostCentreState (FastStringEnv Int)---- | Initialize cost centre state.-newCostCentreState :: CostCentreState-newCostCentreState = CostCentreState emptyFsEnv---- | An index into a given cost centre module,name,flavour set-newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int }-  deriving (Eq, Ord, Data, Binary)---- | Get a new index for a given cost centre name.-getCCIndex :: FastString-           -> CostCentreState-           -> (CostCentreIndex, CostCentreState)-getCCIndex nm (CostCentreState m) =-    (CostCentreIndex idx, CostCentreState m')-  where-    m_idx = lookupFsEnv m nm-    idx = maybe 0 id m_idx-    m' = extendFsEnv m nm (idx + 1)
− compiler/simplCore/CoreMonad.hs 
@@ -1,838 +0,0 @@-{--(c) The AQUA Project, Glasgow University, 1993-1998--\section[CoreMonad]{The core pipeline monad}--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--module CoreMonad (-    -- * Configuration of the core-to-core passes-    CoreToDo(..), runWhen, runMaybe,-    SimplMode(..),-    FloatOutSwitches(..),-    pprPassDetails,--    -- * Plugins-    CorePluginPass, bindsOnlyPass,--    -- * Counting-    SimplCount, doSimplTick, doFreeSimplTick, simplCountN,-    pprSimplCount, plusSimplCount, zeroSimplCount,-    isZeroSimplCount, hasDetailedCounts, Tick(..),--    -- * The monad-    CoreM, runCoreM,--    -- ** Reading from the monad-    getHscEnv, getRuleBase, getModule,-    getDynFlags, getOrigNameCache, getPackageFamInstEnv,-    getVisibleOrphanMods, getUniqMask,-    getPrintUnqualified, getSrcSpanM,--    -- ** Writing to the monad-    addSimplCount,--    -- ** Lifting into the monad-    liftIO, liftIOWithCount,--    -- ** Dealing with annotations-    getAnnotations, getFirstAnnotations,--    -- ** Screen output-    putMsg, putMsgS, errorMsg, errorMsgS, warnMsg,-    fatalErrorMsg, fatalErrorMsgS,-    debugTraceMsg, debugTraceMsgS,-    dumpIfSet_dyn-  ) where--import GhcPrelude hiding ( read )--import GHC.Core-import GHC.Driver.Types-import Module-import GHC.Driver.Session-import BasicTypes       ( CompilerPhase(..) )-import Annotations--import IOEnv hiding     ( liftIO, failM, failWithM )-import qualified IOEnv  ( liftIO )-import Var-import Outputable-import FastString-import ErrUtils( Severity(..), DumpFormat (..), dumpOptionsFromFlag )-import UniqSupply-import MonadUtils-import NameCache-import NameEnv-import SrcLoc-import Data.Bifunctor ( bimap )-import ErrUtils (dumpAction)-import Data.List (intersperse, groupBy, sortBy)-import Data.Ord-import Data.Dynamic-import Data.IORef-import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.Map.Strict as MapStrict-import Data.Word-import Control.Monad-import Control.Applicative ( Alternative(..) )-import Panic (throwGhcException, GhcException(..))--{--************************************************************************-*                                                                      *-              The CoreToDo type and related types-          Abstraction of core-to-core passes to run.-*                                                                      *-************************************************************************--}--data CoreToDo           -- These are diff core-to-core passes,-                        -- which may be invoked in any order,-                        -- as many times as you like.--  = CoreDoSimplify      -- The core-to-core simplifier.-        Int                    -- Max iterations-        SimplMode-  | CoreDoPluginPass String CorePluginPass-  | CoreDoFloatInwards-  | CoreDoFloatOutwards FloatOutSwitches-  | CoreLiberateCase-  | CoreDoPrintCore-  | CoreDoStaticArgs-  | CoreDoCallArity-  | CoreDoExitify-  | CoreDoDemand-  | CoreDoCpr-  | CoreDoWorkerWrapper-  | CoreDoSpecialising-  | CoreDoSpecConstr-  | CoreCSE-  | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules-                                           -- matching this string-  | CoreDoNothing                -- Useful when building up-  | CoreDoPasses [CoreToDo]      -- lists of these things--  | CoreDesugar    -- Right after desugaring, no simple optimisation yet!-  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces-                       --                 Core output, and hence useful to pass to endPass--  | CoreTidy-  | CorePrep-  | CoreOccurAnal--instance Outputable CoreToDo where-  ppr (CoreDoSimplify _ _)     = text "Simplifier"-  ppr (CoreDoPluginPass s _)   = text "Core plugin: " <+> text s-  ppr CoreDoFloatInwards       = text "Float inwards"-  ppr (CoreDoFloatOutwards f)  = text "Float out" <> parens (ppr f)-  ppr CoreLiberateCase         = text "Liberate case"-  ppr CoreDoStaticArgs         = text "Static argument"-  ppr CoreDoCallArity          = text "Called arity analysis"-  ppr CoreDoExitify            = text "Exitification transformation"-  ppr CoreDoDemand             = text "Demand analysis"-  ppr CoreDoCpr                = text "Constructed Product Result analysis"-  ppr CoreDoWorkerWrapper      = text "Worker Wrapper binds"-  ppr CoreDoSpecialising       = text "Specialise"-  ppr CoreDoSpecConstr         = text "SpecConstr"-  ppr CoreCSE                  = text "Common sub-expression"-  ppr CoreDesugar              = text "Desugar (before optimization)"-  ppr CoreDesugarOpt           = text "Desugar (after optimization)"-  ppr CoreTidy                 = text "Tidy Core"-  ppr CorePrep                 = text "CorePrep"-  ppr CoreOccurAnal            = text "Occurrence analysis"-  ppr CoreDoPrintCore          = text "Print core"-  ppr (CoreDoRuleCheck {})     = text "Rule check"-  ppr CoreDoNothing            = text "CoreDoNothing"-  ppr (CoreDoPasses passes)    = text "CoreDoPasses" <+> ppr passes--pprPassDetails :: CoreToDo -> SDoc-pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n-                                            , ppr md ]-pprPassDetails _ = Outputable.empty--data SimplMode             -- See comments in SimplMonad-  = SimplMode-        { sm_names      :: [String] -- Name(s) of the phase-        , sm_phase      :: CompilerPhase-        , sm_dflags     :: DynFlags -- Just for convenient non-monadic-                                    -- access; we don't override these-        , sm_rules      :: Bool     -- Whether RULES are enabled-        , sm_inline     :: Bool     -- Whether inlining is enabled-        , sm_case_case  :: Bool     -- Whether case-of-case is enabled-        , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled-        }--instance Outputable SimplMode where-    ppr (SimplMode { sm_phase = p, sm_names = ss-                   , sm_rules = r, sm_inline = i-                   , sm_eta_expand = eta, sm_case_case = cc })-       = text "SimplMode" <+> braces (-         sep [ text "Phase =" <+> ppr p <+>-               brackets (text (concat $ intersperse "," ss)) <> comma-             , pp_flag i   (sLit "inline") <> comma-             , pp_flag r   (sLit "rules") <> comma-             , pp_flag eta (sLit "eta-expand") <> comma-             , pp_flag cc  (sLit "case-of-case") ])-         where-           pp_flag f s = ppUnless f (text "no") <+> ptext s--data FloatOutSwitches = FloatOutSwitches {-  floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if-                                   -- doing so will abstract over n or fewer-                                   -- value variables-                                   -- Nothing <=> float all lambdas to top level,-                                   --             regardless of how many free variables-                                   -- Just 0 is the vanilla case: float a lambda-                                   --    iff it has no free vars--  floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,-                                   --            even if they do not escape a lambda-  floatOutOverSatApps :: Bool,-                             -- ^ True <=> float out over-saturated applications-                             --            based on arity information.-                             -- See Note [Floating over-saturated applications]-                             -- in SetLevels-  floatToTopLevelOnly :: Bool      -- ^ Allow floating to the top level only.-  }-instance Outputable FloatOutSwitches where-    ppr = pprFloatOutSwitches--pprFloatOutSwitches :: FloatOutSwitches -> SDoc-pprFloatOutSwitches sw-  = text "FOS" <+> (braces $-     sep $ punctuate comma $-     [ text "Lam ="    <+> ppr (floatOutLambdas sw)-     , text "Consts =" <+> ppr (floatOutConstants sw)-     , text "OverSatApps ="   <+> ppr (floatOutOverSatApps sw) ])---- The core-to-core pass ordering is derived from the DynFlags:-runWhen :: Bool -> CoreToDo -> CoreToDo-runWhen True  do_this = do_this-runWhen False _       = CoreDoNothing--runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo-runMaybe (Just x) f = f x-runMaybe Nothing  _ = CoreDoNothing--{---************************************************************************-*                                                                      *-             Types for Plugins-*                                                                      *-************************************************************************--}---- | A description of the plugin pass itself-type CorePluginPass = ModGuts -> CoreM ModGuts--bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts-bindsOnlyPass pass guts-  = do { binds' <- pass (mg_binds guts)-       ; return (guts { mg_binds = binds' }) }--{--************************************************************************-*                                                                      *-             Counting and logging-*                                                                      *-************************************************************************--}--getVerboseSimplStats :: (Bool -> SDoc) -> SDoc-getVerboseSimplStats = getPprDebug          -- For now, anyway--zeroSimplCount     :: DynFlags -> SimplCount-isZeroSimplCount   :: SimplCount -> Bool-hasDetailedCounts  :: SimplCount -> Bool-pprSimplCount      :: SimplCount -> SDoc-doSimplTick        :: DynFlags -> Tick -> SimplCount -> SimplCount-doFreeSimplTick    ::             Tick -> SimplCount -> SimplCount-plusSimplCount     :: SimplCount -> SimplCount -> SimplCount--data SimplCount-   = VerySimplCount !Int        -- Used when don't want detailed stats--   | SimplCount {-        ticks   :: !Int,        -- Total ticks-        details :: !TickCounts, -- How many of each type--        n_log   :: !Int,        -- N-        log1    :: [Tick],      -- Last N events; <= opt_HistorySize,-                                --   most recent first-        log2    :: [Tick]       -- Last opt_HistorySize events before that-                                -- Having log1, log2 lets us accumulate the-                                -- recent history reasonably efficiently-     }--type TickCounts = Map Tick Int--simplCountN :: SimplCount -> Int-simplCountN (VerySimplCount n)         = n-simplCountN (SimplCount { ticks = n }) = n--zeroSimplCount dflags-                -- This is where we decide whether to do-                -- the VerySimpl version or the full-stats version-  | dopt Opt_D_dump_simpl_stats dflags-  = SimplCount {ticks = 0, details = Map.empty,-                n_log = 0, log1 = [], log2 = []}-  | otherwise-  = VerySimplCount 0--isZeroSimplCount (VerySimplCount n)         = n==0-isZeroSimplCount (SimplCount { ticks = n }) = n==0--hasDetailedCounts (VerySimplCount {}) = False-hasDetailedCounts (SimplCount {})     = True--doFreeSimplTick tick sc@SimplCount { details = dts }-  = sc { details = dts `addTick` tick }-doFreeSimplTick _ sc = sc--doSimplTick dflags tick-    sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })-  | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 }-  | otherwise                = sc1 { n_log = nl+1, log1 = tick : l1 }-  where-    sc1 = sc { ticks = tks+1, details = dts `addTick` tick }--doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)---addTick :: TickCounts -> Tick -> TickCounts-addTick fm tick = MapStrict.insertWith (+) tick 1 fm--plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })-               sc2@(SimplCount { ticks = tks2, details = dts2 })-  = log_base { ticks = tks1 + tks2-             , details = MapStrict.unionWith (+) dts1 dts2 }-  where-        -- A hackish way of getting recent log info-    log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2-             | null (log2 sc2) = sc2 { log2 = log1 sc1 }-             | otherwise       = sc2--plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)-plusSimplCount lhs                rhs                =-  throwGhcException . PprProgramError "plusSimplCount" $ vcat-    [ text "lhs"-    , pprSimplCount lhs-    , text "rhs"-    , pprSimplCount rhs-    ]-       -- We use one or the other consistently--pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n-pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })-  = vcat [text "Total ticks:    " <+> int tks,-          blankLine,-          pprTickCounts dts,-          getVerboseSimplStats $ \dbg -> if dbg-          then-                vcat [blankLine,-                      text "Log (most recent first)",-                      nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]-          else Outputable.empty-    ]--{- Note [Which transformations are innocuous]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-At one point (Jun 18) I wondered if some transformations (ticks)-might be  "innocuous", in the sense that they do not unlock a later-transformation that does not occur in the same pass.  If so, we could-refrain from bumping the overall tick-count for such innocuous-transformations, and perhaps terminate the simplifier one pass-earlier.--BUt alas I found that virtually nothing was innocuous!  This Note-just records what I learned, in case anyone wants to try again.--These transformations are not innocuous:--*** NB: I think these ones could be made innocuous-          EtaExpansion-          LetFloatFromLet--LetFloatFromLet-    x = K (let z = e2 in Just z)-  prepareRhs transforms to-    x2 = let z=e2 in Just z-    x  = K xs-  And now more let-floating can happen in the-  next pass, on x2--PreInlineUnconditionally-  Example in spectral/cichelli/Auxil-     hinsert = ...let lo = e in-                  let j = ...lo... in-                  case x of-                    False -> ()-                    True -> case lo of I# lo' ->-                              ...j...-  When we PreInlineUnconditionally j, lo's occ-info changes to once,-  so it can be PreInlineUnconditionally in the next pass, and a-  cascade of further things can happen.--PostInlineUnconditionally-  let x = e in-  let y = ...x.. in-  case .. of { A -> ...x...y...-               B -> ...x...y... }-  Current postinlineUnconditinaly will inline y, and then x; sigh.--  But PostInlineUnconditionally might also unlock subsequent-  transformations for the same reason as PreInlineUnconditionally,-  so it's probably not innocuous anyway.--KnownBranch, BetaReduction:-  May drop chunks of code, and thereby enable PreInlineUnconditionally-  for some let-binding which now occurs once--EtaExpansion:-  Example in imaginary/digits-of-e1-    fail = \void. e          where e :: IO ()-  --> etaExpandRhs-    fail = \void. (\s. (e |> g) s) |> sym g      where g :: IO () ~ S -> (S,())-  --> Next iteration of simplify-    fail1 = \void. \s. (e |> g) s-    fail = fail1 |> Void#->sym g-  And now inline 'fail'--CaseMerge:-  case x of y {-    DEFAULT -> case y of z { pi -> ei }-    alts2 }-  ---> CaseMerge-    case x of { pi -> let z = y in ei-              ; alts2 }-  The "let z=y" case-binder-swap gets dealt with in the next pass--}--pprTickCounts :: Map Tick Int -> SDoc-pprTickCounts counts-  = vcat (map pprTickGroup groups)-  where-    groups :: [[(Tick,Int)]]    -- Each group shares a common tag-                                -- toList returns common tags adjacent-    groups = groupBy same_tag (Map.toList counts)-    same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2--pprTickGroup :: [(Tick, Int)] -> SDoc-pprTickGroup group@((tick1,_):_)-  = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))-       2 (vcat [ int n <+> pprTickCts tick-                                    -- flip as we want largest first-               | (tick,n) <- sortBy (flip (comparing snd)) group])-pprTickGroup [] = panic "pprTickGroup"--data Tick  -- See Note [Which transformations are innocuous]-  = PreInlineUnconditionally    Id-  | PostInlineUnconditionally   Id--  | UnfoldingDone               Id-  | RuleFired                   FastString      -- Rule name--  | LetFloatFromLet-  | EtaExpansion                Id      -- LHS binder-  | EtaReduction                Id      -- Binder on outer lambda-  | BetaReduction               Id      -- Lambda binder---  | CaseOfCase                  Id      -- Bndr on *inner* case-  | KnownBranch                 Id      -- Case binder-  | CaseMerge                   Id      -- Binder on outer case-  | AltMerge                    Id      -- Case binder-  | CaseElim                    Id      -- Case binder-  | CaseIdentity                Id      -- Case binder-  | FillInCaseDefault           Id      -- Case binder--  | SimplifierDone              -- Ticked at each iteration of the simplifier--instance Outputable Tick where-  ppr tick = text (tickString tick) <+> pprTickCts tick--instance Eq Tick where-  a == b = case a `cmpTick` b of-           EQ -> True-           _ -> False--instance Ord Tick where-  compare = cmpTick--tickToTag :: Tick -> Int-tickToTag (PreInlineUnconditionally _)  = 0-tickToTag (PostInlineUnconditionally _) = 1-tickToTag (UnfoldingDone _)             = 2-tickToTag (RuleFired _)                 = 3-tickToTag LetFloatFromLet               = 4-tickToTag (EtaExpansion _)              = 5-tickToTag (EtaReduction _)              = 6-tickToTag (BetaReduction _)             = 7-tickToTag (CaseOfCase _)                = 8-tickToTag (KnownBranch _)               = 9-tickToTag (CaseMerge _)                 = 10-tickToTag (CaseElim _)                  = 11-tickToTag (CaseIdentity _)              = 12-tickToTag (FillInCaseDefault _)         = 13-tickToTag SimplifierDone                = 16-tickToTag (AltMerge _)                  = 17--tickString :: Tick -> String-tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"-tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"-tickString (UnfoldingDone _)            = "UnfoldingDone"-tickString (RuleFired _)                = "RuleFired"-tickString LetFloatFromLet              = "LetFloatFromLet"-tickString (EtaExpansion _)             = "EtaExpansion"-tickString (EtaReduction _)             = "EtaReduction"-tickString (BetaReduction _)            = "BetaReduction"-tickString (CaseOfCase _)               = "CaseOfCase"-tickString (KnownBranch _)              = "KnownBranch"-tickString (CaseMerge _)                = "CaseMerge"-tickString (AltMerge _)                 = "AltMerge"-tickString (CaseElim _)                 = "CaseElim"-tickString (CaseIdentity _)             = "CaseIdentity"-tickString (FillInCaseDefault _)        = "FillInCaseDefault"-tickString SimplifierDone               = "SimplifierDone"--pprTickCts :: Tick -> SDoc-pprTickCts (PreInlineUnconditionally v) = ppr v-pprTickCts (PostInlineUnconditionally v)= ppr v-pprTickCts (UnfoldingDone v)            = ppr v-pprTickCts (RuleFired v)                = ppr v-pprTickCts LetFloatFromLet              = Outputable.empty-pprTickCts (EtaExpansion v)             = ppr v-pprTickCts (EtaReduction v)             = ppr v-pprTickCts (BetaReduction v)            = ppr v-pprTickCts (CaseOfCase v)               = ppr v-pprTickCts (KnownBranch v)              = ppr v-pprTickCts (CaseMerge v)                = ppr v-pprTickCts (AltMerge v)                 = ppr v-pprTickCts (CaseElim v)                 = ppr v-pprTickCts (CaseIdentity v)             = ppr v-pprTickCts (FillInCaseDefault v)        = ppr v-pprTickCts _                            = Outputable.empty--cmpTick :: Tick -> Tick -> Ordering-cmpTick a b = case (tickToTag a `compare` tickToTag b) of-                GT -> GT-                EQ -> cmpEqTick a b-                LT -> LT--cmpEqTick :: Tick -> Tick -> Ordering-cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b-cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b-cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b-cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b-cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b-cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b-cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b-cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b-cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b-cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b-cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b-cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b-cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b-cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b-cmpEqTick _                             _                               = EQ--{--************************************************************************-*                                                                      *-             Monad and carried data structure definitions-*                                                                      *-************************************************************************--}--data CoreReader = CoreReader {-        cr_hsc_env             :: HscEnv,-        cr_rule_base           :: RuleBase,-        cr_module              :: Module,-        cr_print_unqual        :: PrintUnqualified,-        cr_loc                 :: SrcSpan,   -- Use this for log/error messages so they-                                             -- are at least tagged with the right source file-        cr_visible_orphan_mods :: !ModuleSet,-        cr_uniq_mask           :: !Char      -- Mask for creating unique values-}---- Note: CoreWriter used to be defined with data, rather than newtype.  If it--- is defined that way again, the cw_simpl_count field, at least, must be--- strict to avoid a space leak (#7702).-newtype CoreWriter = CoreWriter {-        cw_simpl_count :: SimplCount-}--emptyWriter :: DynFlags -> CoreWriter-emptyWriter dflags = CoreWriter {-        cw_simpl_count = zeroSimplCount dflags-    }--plusWriter :: CoreWriter -> CoreWriter -> CoreWriter-plusWriter w1 w2 = CoreWriter {-        cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)-    }--type CoreIOEnv = IOEnv CoreReader---- | The monad used by Core-to-Core passes to register simplification statistics.---  Also used to have common state (in the form of UniqueSupply) for generating Uniques.-newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) }-    deriving (Functor)--instance Monad CoreM where-    mx >>= f = CoreM $ do-            (x, w1) <- unCoreM mx-            (y, w2) <- unCoreM (f x)-            let w = w1 `plusWriter` w2-            return $ seq w (y, w)-            -- forcing w before building the tuple avoids a space leak-            -- (#7702)--instance Applicative CoreM where-    pure x = CoreM $ nop x-    (<*>) = ap-    m *> k = m >>= \_ -> k--instance Alternative CoreM where-    empty   = CoreM Control.Applicative.empty-    m <|> n = CoreM (unCoreM m <|> unCoreM n)--instance MonadPlus CoreM--instance MonadUnique CoreM where-    getUniqueSupplyM = do-        mask <- read cr_uniq_mask-        liftIO $! mkSplitUniqSupply mask--    getUniqueM = do-        mask <- read cr_uniq_mask-        liftIO $! uniqFromMask mask--runCoreM :: HscEnv-         -> RuleBase-         -> Char -- ^ Mask-         -> Module-         -> ModuleSet-         -> PrintUnqualified-         -> SrcSpan-         -> CoreM a-         -> IO (a, SimplCount)-runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m-  = liftM extract $ runIOEnv reader $ unCoreM m-  where-    reader = CoreReader {-            cr_hsc_env = hsc_env,-            cr_rule_base = rule_base,-            cr_module = mod,-            cr_visible_orphan_mods = orph_imps,-            cr_print_unqual = print_unqual,-            cr_loc = loc,-            cr_uniq_mask = mask-        }--    extract :: (a, CoreWriter) -> (a, SimplCount)-    extract (value, writer) = (value, cw_simpl_count writer)--{--************************************************************************-*                                                                      *-             Core combinators, not exported-*                                                                      *-************************************************************************--}--nop :: a -> CoreIOEnv (a, CoreWriter)-nop x = do-    r <- getEnv-    return (x, emptyWriter $ (hsc_dflags . cr_hsc_env) r)--read :: (CoreReader -> a) -> CoreM a-read f = CoreM $ getEnv >>= (\r -> nop (f r))--write :: CoreWriter -> CoreM ()-write w = CoreM $ return ((), w)---- \subsection{Lifting IO into the monad}---- | Lift an 'IOEnv' operation into 'CoreM'-liftIOEnv :: CoreIOEnv a -> CoreM a-liftIOEnv mx = CoreM (mx >>= (\x -> nop x))--instance MonadIO CoreM where-    liftIO = liftIOEnv . IOEnv.liftIO---- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'-liftIOWithCount :: IO (SimplCount, a) -> CoreM a-liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)--{--************************************************************************-*                                                                      *-             Reader, writer and state accessors-*                                                                      *-************************************************************************--}--getHscEnv :: CoreM HscEnv-getHscEnv = read cr_hsc_env--getRuleBase :: CoreM RuleBase-getRuleBase = read cr_rule_base--getVisibleOrphanMods :: CoreM ModuleSet-getVisibleOrphanMods = read cr_visible_orphan_mods--getPrintUnqualified :: CoreM PrintUnqualified-getPrintUnqualified = read cr_print_unqual--getSrcSpanM :: CoreM SrcSpan-getSrcSpanM = read cr_loc--addSimplCount :: SimplCount -> CoreM ()-addSimplCount count = write (CoreWriter { cw_simpl_count = count })--getUniqMask :: CoreM Char-getUniqMask = read cr_uniq_mask---- Convenience accessors for useful fields of HscEnv--instance HasDynFlags CoreM where-    getDynFlags = fmap hsc_dflags getHscEnv--instance HasModule CoreM where-    getModule = read cr_module---- | The original name cache is the current mapping from 'Module' and--- 'OccName' to a compiler-wide unique 'Name'-getOrigNameCache :: CoreM OrigNameCache-getOrigNameCache = do-    nameCacheRef <- fmap hsc_NC getHscEnv-    liftIO $ fmap nsNames $ readIORef nameCacheRef--getPackageFamInstEnv :: CoreM PackageFamInstEnv-getPackageFamInstEnv = do-    hsc_env <- getHscEnv-    eps <- liftIO $ hscEPS hsc_env-    return $ eps_fam_inst_env eps--{--************************************************************************-*                                                                      *-             Dealing with annotations-*                                                                      *-************************************************************************--}---- | Get all annotations of a given type. This happens lazily, that is--- no deserialization will take place until the [a] is actually demanded and--- the [a] can also be empty (the UniqFM is not filtered).------ This should be done once at the start of a Core-to-Core pass that uses--- annotations.------ See Note [Annotations]-getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])-getAnnotations deserialize guts = do-     hsc_env <- getHscEnv-     ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)-     return (deserializeAnns deserialize ann_env)---- | Get at most one annotation of a given type per annotatable item.-getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a)-getFirstAnnotations deserialize guts-  = bimap mod name <$> getAnnotations deserialize guts-  where-    mod = mapModuleEnv head . filterModuleEnv (const $ not . null)-    name = mapNameEnv head . filterNameEnv (not . null)--{--Note [Annotations]-~~~~~~~~~~~~~~~~~~-A Core-to-Core pass that wants to make use of annotations calls-getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with-annotations of a specific type. This produces all annotations from interface-files read so far. However, annotations from interface files read during the-pass will not be visible until getAnnotations is called again. This is similar-to how rules work and probably isn't too bad.--The current implementation could be optimised a bit: when looking up-annotations for a thing from the HomePackageTable, we could search directly in-the module where the thing is defined rather than building one UniqFM which-contains all annotations we know of. This would work because annotations can-only be given to things defined in the same module. However, since we would-only want to deserialise every annotation once, we would have to build a cache-for every module in the HTP. In the end, it's probably not worth it as long as-we aren't using annotations heavily.--************************************************************************-*                                                                      *-                Direct screen output-*                                                                      *-************************************************************************--}--msg :: Severity -> WarnReason -> SDoc -> CoreM ()-msg sev reason doc-  = do { dflags <- getDynFlags-       ; loc    <- getSrcSpanM-       ; unqual <- getPrintUnqualified-       ; let sty = case sev of-                     SevError   -> err_sty-                     SevWarning -> err_sty-                     SevDump    -> dump_sty-                     _          -> user_sty-             err_sty  = mkErrStyle dflags unqual-             user_sty = mkUserStyle dflags unqual AllTheWay-             dump_sty = mkDumpStyle dflags unqual-       ; liftIO $ putLogMsg dflags reason sev loc sty doc }---- | Output a String message to the screen-putMsgS :: String -> CoreM ()-putMsgS = putMsg . text---- | Output a message to the screen-putMsg :: SDoc -> CoreM ()-putMsg = msg SevInfo NoReason---- | Output an error to the screen. Does not cause the compiler to die.-errorMsgS :: String -> CoreM ()-errorMsgS = errorMsg . text---- | Output an error to the screen. Does not cause the compiler to die.-errorMsg :: SDoc -> CoreM ()-errorMsg = msg SevError NoReason--warnMsg :: WarnReason -> SDoc -> CoreM ()-warnMsg = msg SevWarning---- | Output a fatal error to the screen. Does not cause the compiler to die.-fatalErrorMsgS :: String -> CoreM ()-fatalErrorMsgS = fatalErrorMsg . text---- | Output a fatal error to the screen. Does not cause the compiler to die.-fatalErrorMsg :: SDoc -> CoreM ()-fatalErrorMsg = msg SevFatal NoReason---- | Output a string debugging message at verbosity level of @-v@ or higher-debugTraceMsgS :: String -> CoreM ()-debugTraceMsgS = debugTraceMsg . text---- | Outputs a debugging message at verbosity level of @-v@ or higher-debugTraceMsg :: SDoc -> CoreM ()-debugTraceMsg = msg SevDump NoReason---- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher-dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM ()-dumpIfSet_dyn flag str fmt doc-  = do { dflags <- getDynFlags-       ; unqual <- getPrintUnqualified-       ; when (dopt flag dflags) $ liftIO $ do-         let sty = mkDumpStyle dflags unqual-         dumpAction dflags sty (dumpOptionsFromFlag flag) str fmt doc }
− compiler/simplCore/CoreMonad.hs-boot 
@@ -1,30 +0,0 @@--- Created this hs-boot file to remove circular dependencies from the use of--- Plugins. Plugins needs CoreToDo and CoreM types to define core-to-core--- transformations.--- However CoreMonad does much more than defining these, and because Plugins are--- activated in various modules, the imports become circular. To solve this I--- extracted CoreToDo and CoreM into this file.--- I needed to write the whole definition of these types, otherwise it created--- a data-newtype conflict.--module CoreMonad ( CoreToDo, CoreM ) where--import GhcPrelude--import IOEnv ( IOEnv )--type CoreIOEnv = IOEnv CoreReader--data CoreReader--newtype CoreWriter = CoreWriter {-        cw_simpl_count :: SimplCount-}--data SimplCount--newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) }--instance Monad CoreM--data CoreToDo
− compiler/simplCore/OccurAnal.hs 
@@ -1,2898 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--************************************************************************-*                                                                      *-\section[OccurAnal]{Occurrence analysis pass}-*                                                                      *-************************************************************************--The occurrence analyser re-typechecks a core expression, returning a new-core expression with (hopefully) improved usage information.--}--{-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns  #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--module OccurAnal (-        occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap-    ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Core-import GHC.Core.FVs-import GHC.Core.Utils   ( exprIsTrivial, isDefaultAlt, isExpandableApp,-                          stripTicksTopE, mkTicks )-import GHC.Core.Arity   ( joinRhsArity )-import Id-import IdInfo-import Name( localiseName )-import BasicTypes-import Module( Module )-import Coercion-import Type--import VarSet-import VarEnv-import Var-import Demand           ( argOneShots, argsOneShots )-import Digraph          ( SCC(..), Node(..)-                        , stronglyConnCompFromEdgedVerticesUniq-                        , stronglyConnCompFromEdgedVerticesUniqR )-import Unique-import UniqFM-import UniqSet-import Util-import Outputable-import Data.List-import Control.Arrow    ( second )--{--************************************************************************-*                                                                      *-    occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap-*                                                                      *-************************************************************************--Here's the externally-callable interface:--}--occurAnalysePgm :: Module         -- Used only in debug output-                -> (Id -> Bool)         -- Active unfoldings-                -> (Activation -> Bool) -- Active rules-                -> [CoreRule]-                -> CoreProgram -> CoreProgram-occurAnalysePgm this_mod active_unf active_rule imp_rules binds-  | isEmptyDetails final_usage-  = occ_anald_binds--  | otherwise   -- See Note [Glomming]-  = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon)-                   2 (ppr final_usage ) )-    occ_anald_glommed_binds-  where-    init_env = initOccEnv { occ_rule_act = active_rule-                          , occ_unf_act  = active_unf }--    (final_usage, occ_anald_binds) = go init_env binds-    (_, occ_anald_glommed_binds)   = occAnalRecBind init_env TopLevel-                                                    imp_rule_edges-                                                    (flattenBinds binds)-                                                    initial_uds-          -- It's crucial to re-analyse the glommed-together bindings-          -- so that we establish the right loop breakers. Otherwise-          -- we can easily create an infinite loop (#9583 is an example)-          ---          -- Also crucial to re-analyse the /original/ bindings-          -- in case the first pass accidentally discarded as dead code-          -- a binding that was actually needed (albeit before its-          -- definition site).  #17724 threw this up.--    initial_uds = addManyOccsSet emptyDetails-                            (rulesFreeVars imp_rules)-    -- The RULES declarations keep things alive!--    -- Note [Preventing loops due to imported functions rules]-    imp_rule_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv-                            [ mapVarEnv (const maps_to) $-                                getUniqSet (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule)-                            | imp_rule <- imp_rules-                            , not (isBuiltinRule imp_rule)  -- See Note [Plugin rules]-                            , let maps_to = exprFreeIds (ru_rhs imp_rule)-                                             `delVarSetList` ru_bndrs imp_rule-                            , arg <- ru_args imp_rule ]--    go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])-    go _ []-        = (initial_uds, [])-    go env (bind:binds)-        = (final_usage, bind' ++ binds')-        where-           (bs_usage, binds')   = go env binds-           (final_usage, bind') = occAnalBind env TopLevel imp_rule_edges bind-                                              bs_usage--occurAnalyseExpr :: CoreExpr -> CoreExpr-        -- Do occurrence analysis, and discard occurrence info returned-occurAnalyseExpr = occurAnalyseExpr' True -- do binder swap--occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr-occurAnalyseExpr_NoBinderSwap = occurAnalyseExpr' False -- do not do binder swap--occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr-occurAnalyseExpr' enable_binder_swap expr-  = snd (occAnal env expr)-  where-    env = initOccEnv { occ_binder_swap = enable_binder_swap }--{- Note [Plugin rules]-~~~~~~~~~~~~~~~~~~~~~~-Conal Elliott (#11651) built a GHC plugin that added some-BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to-do some domain-specific transformations that could not be expressed-with an ordinary pattern-matching CoreRule.  But then we can't extract-the dependencies (in imp_rule_edges) from ru_rhs etc, because a-BuiltinRule doesn't have any of that stuff.--So we simply assume that BuiltinRules have no dependencies, and filter-them out from the imp_rule_edges comprehension.--}--{--************************************************************************-*                                                                      *-                Bindings-*                                                                      *-************************************************************************--Note [Recursive bindings: the grand plan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we come across a binding group-  Rec { x1 = r1; ...; xn = rn }-we treat it like this (occAnalRecBind):--1. Occurrence-analyse each right hand side, and build a-   "Details" for each binding to capture the results.--   Wrap the details in a Node (details, node-id, dep-node-ids),-   where node-id is just the unique of the binder, and-   dep-node-ids lists all binders on which this binding depends.-   We'll call these the "scope edges".-   See Note [Forming the Rec groups].--   All this is done by makeNode.--2. Do SCC-analysis on these Nodes.  Each SCC will become a new Rec or-   NonRec.  The key property is that every free variable of a binding-   is accounted for by the scope edges, so that when we are done-   everything is still in scope.--3. For each Cyclic SCC of the scope-edge SCC-analysis in (2), we-   identify suitable loop-breakers to ensure that inlining terminates.-   This is done by occAnalRec.--4. To do so we form a new set of Nodes, with the same details, but-   different edges, the "loop-breaker nodes". The loop-breaker nodes-   have both more and fewer dependencies than the scope edges-   (see Note [Choosing loop breakers])--   More edges: if f calls g, and g has an active rule that mentions h-               then we add an edge from f -> h--   Fewer edges: we only include dependencies on active rules, on rule-                RHSs (not LHSs) and if there is an INLINE pragma only-                on the stable unfolding (and vice versa).  The scope-                edges must be much more inclusive.--5.  The "weak fvs" of a node are, by definition:-       the scope fvs - the loop-breaker fvs-    See Note [Weak loop breakers], and the nd_weak field of Details--6.  Having formed the loop-breaker nodes--Note [Dead code]-~~~~~~~~~~~~~~~~-Dropping dead code for a cyclic Strongly Connected Component is done-in a very simple way:--        the entire SCC is dropped if none of its binders are mentioned-        in the body; otherwise the whole thing is kept.--The key observation is that dead code elimination happens after-dependency analysis: so 'occAnalBind' processes SCCs instead of the-original term's binding groups.--Thus 'occAnalBind' does indeed drop 'f' in an example like--        letrec f = ...g...-               g = ...(...g...)...-        in-           ...g...--when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in-'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes-'AcyclicSCC f', where 'body_usage' won't contain 'f'.---------------------------------------------------------------Note [Forming Rec groups]-~~~~~~~~~~~~~~~~~~~~~~~~~-We put bindings {f = ef; g = eg } in a Rec group if "f uses g"-and "g uses f", no matter how indirectly.  We do a SCC analysis-with an edge f -> g if "f uses g".--More precisely, "f uses g" iff g should be in scope wherever f is.-That is, g is free in:-  a) the rhs 'ef'-  b) or the RHS of a rule for f (Note [Rules are extra RHSs])-  c) or the LHS or a rule for f (Note [Rule dependency info])--These conditions apply regardless of the activation of the RULE (eg it might be-inactive in this phase but become active later).  Once a Rec is broken up-it can never be put back together, so we must be conservative.--The principle is that, regardless of rule firings, every variable is-always in scope.--  * Note [Rules are extra RHSs]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~-    A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"-    keeps the specialised "children" alive.  If the parent dies-    (because it isn't referenced any more), then the children will die-    too (unless they are already referenced directly).--    To that end, we build a Rec group for each cyclic strongly-    connected component,-        *treating f's rules as extra RHSs for 'f'*.-    More concretely, the SCC analysis runs on a graph with an edge-    from f -> g iff g is mentioned in-        (a) f's rhs-        (b) f's RULES-    These are rec_edges.--    Under (b) we include variables free in *either* LHS *or* RHS of-    the rule.  The former might seems silly, but see Note [Rule-    dependency info].  So in Example [eftInt], eftInt and eftIntFB-    will be put in the same Rec, even though their 'main' RHSs are-    both non-recursive.--  * Note [Rule dependency info]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~-    The VarSet in a RuleInfo is used for dependency analysis in the-    occurrence analyser.  We must track free vars in *both* lhs and rhs.-    Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.-    Why both? Consider-        x = y-        RULE f x = v+4-    Then if we substitute y for x, we'd better do so in the-    rule's LHS too, so we'd better ensure the RULE appears to mention 'x'-    as well as 'v'--  * Note [Rules are visible in their own rec group]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    We want the rules for 'f' to be visible in f's right-hand side.-    And we'd like them to be visible in other functions in f's Rec-    group.  E.g. in Note [Specialisation rules] we want f' rule-    to be visible in both f's RHS, and fs's RHS.--    This means that we must simplify the RULEs first, before looking-    at any of the definitions.  This is done by Simplify.simplRecBind,-    when it calls addLetIdInfo.---------------------------------------------------------------Note [Choosing loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Loop breaking is surprisingly subtle.  First read the section 4 of-"Secrets of the GHC inliner".  This describes our basic plan.-We avoid infinite inlinings by choosing loop breakers, and-ensuring that a loop breaker cuts each loop.--See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which-deals with a closely related source of infinite loops.--Fundamentally, we do SCC analysis on a graph.  For each recursive-group we choose a loop breaker, delete all edges to that node,-re-analyse the SCC, and iterate.--But what is the graph?  NOT the same graph as was used for Note-[Forming Rec groups]!  In particular, a RULE is like an equation for-'f' that is *always* inlined if it is applicable.  We do *not* disable-rules for loop-breakers.  It's up to whoever makes the rules to make-sure that the rules themselves always terminate.  See Note [Rules for-recursive functions] in Simplify.hs--Hence, if-    f's RHS (or its INLINE template if it has one) mentions g, and-    g has a RULE that mentions h, and-    h has a RULE that mentions f--then we *must* choose f to be a loop breaker.  Example: see Note-[Specialisation rules].--In general, take the free variables of f's RHS, and augment it with-all the variables reachable by RULES from those starting points.  That-is the whole reason for computing rule_fv_env in occAnalBind.  (Of-course we only consider free vars that are also binders in this Rec-group.)  See also Note [Finding rule RHS free vars]--Note that when we compute this rule_fv_env, we only consider variables-free in the *RHS* of the rule, in contrast to the way we build the-Rec group in the first place (Note [Rule dependency info])--Note that if 'g' has RHS that mentions 'w', we should add w to-g's loop-breaker edges.  More concretely there is an edge from f -> g-iff-        (a) g is mentioned in f's RHS `xor` f's INLINE rhs-            (see Note [Inline rules])-        (b) or h is mentioned in f's RHS, and-            g appears in the RHS of an active RULE of h-            or a transitive sequence of active rules starting with h--Why "active rules"?  See Note [Finding rule RHS free vars]--Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is-chosen as a loop breaker, because their RHSs don't mention each other.-And indeed both can be inlined safely.--Note again that the edges of the graph we use for computing loop breakers-are not the same as the edges we use for computing the Rec blocks.-That's why we compute--- rec_edges          for the Rec block analysis-- loop_breaker_nodes for the loop breaker analysis--  * Note [Finding rule RHS free vars]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    Consider this real example from Data Parallel Haskell-         tagZero :: Array Int -> Array Tag-         {-# INLINE [1] tagZeroes #-}-         tagZero xs = pmap (\x -> fromBool (x==0)) xs--         {-# RULES "tagZero" [~1] forall xs n.-             pmap fromBool <blah blah> = tagZero xs #-}-    So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.-    However, tagZero can only be inlined in phase 1 and later, while-    the RULE is only active *before* phase 1.  So there's no problem.--    To make this work, we look for the RHS free vars only for-    *active* rules. That's the reason for the occ_rule_act field-    of the OccEnv.--  * Note [Weak loop breakers]-    ~~~~~~~~~~~~~~~~~~~~~~~~~-    There is a last nasty wrinkle.  Suppose we have--        Rec { f = f_rhs-              RULE f [] = g--              h = h_rhs-              g = h-              ...more...-        }--    Remember that we simplify the RULES before any RHS (see Note-    [Rules are visible in their own rec group] above).--    So we must *not* postInlineUnconditionally 'g', even though-    its RHS turns out to be trivial.  (I'm assuming that 'g' is-    not chosen as a loop breaker.)  Why not?  Because then we-    drop the binding for 'g', which leaves it out of scope in the-    RULE!--    Here's a somewhat different example of the same thing-        Rec { g = h-            ; h = ...f...-            ; f = f_rhs-              RULE f [] = g }-    Here the RULE is "below" g, but we *still* can't postInlineUnconditionally-    g, because the RULE for f is active throughout.  So the RHS of h-    might rewrite to     h = ...g...-    So g must remain in scope in the output program!--    We "solve" this by:--        Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True)-        iff g is a "missing free variable" of the Rec group--    A "missing free variable" x is one that is mentioned in an RHS or-    INLINE or RULE of a binding in the Rec group, but where the-    dependency on x may not show up in the loop_breaker_nodes (see-    note [Choosing loop breakers} above).--    A normal "strong" loop breaker has IAmLoopBreaker False.  So--                                    Inline  postInlineUnconditionally-   strong   IAmLoopBreaker False    no      no-   weak     IAmLoopBreaker True     yes     no-            other                   yes     yes--    The **sole** reason for this kind of loop breaker is so that-    postInlineUnconditionally does not fire.  Ugh.  (Typically it'll-    inline via the usual callSiteInline stuff, so it'll be dead in the-    next pass, so the main Ugh is the tiresome complication.)--Note [Rules for imported functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this-   f = /\a. B.g a-   RULE B.g Int = 1 + f Int-Note that-  * The RULE is for an imported function.-  * f is non-recursive-Now we-can get-   f Int --> B.g Int      Inlining f-         --> 1 + f Int    Firing RULE-and so the simplifier goes into an infinite loop. This-would not happen if the RULE was for a local function,-because we keep track of dependencies through rules.  But-that is pretty much impossible to do for imported Ids.  Suppose-f's definition had been-   f = /\a. C.h a-where (by some long and devious process), C.h eventually inlines to-B.g.  We could only spot such loops by exhaustively following-unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE)-f.--Note that RULES for imported functions are important in practice; they-occur a lot in the libraries.--We regard this potential infinite loop as a *programmer* error.-It's up the programmer not to write silly rules like-     RULE f x = f x-and the example above is just a more complicated version.--Note [Preventing loops due to imported functions rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:-  import GHC.Base (foldr)--  {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-}-  filter p xs = build (\c n -> foldr (filterFB c p) n xs)-  filterFB c p = ...--  f = filter p xs--Note that filter is not a loop-breaker, so what happens is:-  f =          filter p xs-    = {inline} build (\c n -> foldr (filterFB c p) n xs)-    = {inline} foldr (filterFB (:) p) [] xs-    = {RULE}   filter p xs--We are in an infinite loop.--A more elaborate example (that I actually saw in practice when I went to-mark GHC.List.filter as INLINABLE) is as follows. Say I have this module:-  {-# LANGUAGE RankNTypes #-}-  module GHCList where--  import Prelude hiding (filter)-  import GHC.Base (build)--  {-# INLINABLE filter #-}-  filter :: (a -> Bool) -> [a] -> [a]-  filter p [] = []-  filter p (x:xs) = if p x then x : filter p xs else filter p xs--  {-# NOINLINE [0] filterFB #-}-  filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b-  filterFB c p x r | p x       = x `c` r-                   | otherwise = r--  {-# RULES-  "filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr-  (filterFB c p) n xs)-  "filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p-   #-}--Then (because RULES are applied inside INLINABLE unfoldings, but inlinings-are not), the unfolding given to "filter" in the interface file will be:-  filter p []     = []-  filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs)-                           else     build (\c n -> foldr (filterFB c p) n xs--Note that because this unfolding does not mention "filter", filter is not-marked as a strong loop breaker. Therefore at a use site in another module:-  filter p xs-    = {inline}-      case xs of []     -> []-                 (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs)-                                  else     build (\c n -> foldr (filterFB c p) n xs)--  build (\c n -> foldr (filterFB c p) n xs)-    = {inline} foldr (filterFB (:) p) [] xs-    = {RULE}   filter p xs--And we are in an infinite loop again, except that this time the loop is producing an-infinitely large *term* (an unrolling of filter) and so the simplifier finally-dies with "ticks exhausted"--Because of this problem, we make a small change in the occurrence analyser-designed to mark functions like "filter" as strong loop breakers on the basis that:-  1. The RHS of filter mentions the local function "filterFB"-  2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS--So for each RULE for an *imported* function we are going to add-dependency edges between the *local* FVS of the rule LHS and the-*local* FVS of the rule RHS. We don't do anything special for RULES on-local functions because the standard occurrence analysis stuff is-pretty good at getting loop-breakerness correct there.--It is important to note that even with this extra hack we aren't always going to get-things right. For example, it might be that the rule LHS mentions an imported Id,-and another module has a RULE that can rewrite that imported Id to one of our local-Ids.--Note [Specialising imported functions] (referred to from Specialise)-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-BUT for *automatically-generated* rules, the programmer can't be-responsible for the "programmer error" in Note [Rules for imported-functions].  In particular, consider specialising a recursive function-defined in another module.  If we specialise a recursive function B.g,-we get-         g_spec = .....(B.g Int).....-         RULE B.g Int = g_spec-Here, g_spec doesn't look recursive, but when the rule fires, it-becomes so.  And if B.g was mutually recursive, the loop might-not be as obvious as it is here.--To avoid this,- * When specialising a function that is a loop breaker,-   give a NOINLINE pragma to the specialised function--Note [Glomming]-~~~~~~~~~~~~~~~-RULES for imported Ids can make something at the top refer to something at the bottom:-        f = \x -> B.g (q x)-        h = \y -> 3--        RULE:  B.g (q x) = h x--Applying this rule makes f refer to h, although f doesn't appear to-depend on h.  (And, as in Note [Rules for imported functions], the-dependency might be more indirect. For example, f might mention C.t-rather than B.g, where C.t eventually inlines to B.g.)--NOTICE that this cannot happen for rules whose head is a-locally-defined function, because we accurately track dependencies-through RULES.  It only happens for rules whose head is an imported-function (B.g in the example above).--Solution:-  - When simplifying, bring all top level identifiers into-    scope at the start, ignoring the Rec/NonRec structure, so-    that when 'h' pops up in f's rhs, we find it in the in-scope set-    (as the simplifier generally expects). This happens in simplTopBinds.--  - In the occurrence analyser, if there are any out-of-scope-    occurrences that pop out of the top, which will happen after-    firing the rule:      f = \x -> h x-                          h = \y -> 3-    then just glom all the bindings into a single Rec, so that-    the *next* iteration of the occurrence analyser will sort-    them all out.   This part happens in occurAnalysePgm.---------------------------------------------------------------Note [Inline rules]-~~~~~~~~~~~~~~~~~~~-None of the above stuff about RULES applies to Inline Rules,-stored in a CoreUnfolding.  The unfolding, if any, is simplified-at the same time as the regular RHS of the function (ie *not* like-Note [Rules are visible in their own rec group]), so it should be-treated *exactly* like an extra RHS.--Or, rather, when computing loop-breaker edges,-  * If f has an INLINE pragma, and it is active, we treat the-    INLINE rhs as f's rhs-  * If it's inactive, we treat f as having no rhs-  * If it has no INLINE pragma, we look at f's actual rhs---There is a danger that we'll be sub-optimal if we see this-     f = ...f...-     [INLINE f = ..no f...]-where f is recursive, but the INLINE is not. This can just about-happen with a sufficiently odd set of rules; eg--        foo :: Int -> Int-        {-# INLINE [1] foo #-}-        foo x = x+1--        bar :: Int -> Int-        {-# INLINE [1] bar #-}-        bar x = foo x + 1--        {-# RULES "foo" [~1] forall x. foo x = bar x #-}--Here the RULE makes bar recursive; but it's INLINE pragma remains-non-recursive. It's tempting to then say that 'bar' should not be-a loop breaker, but an attempt to do so goes wrong in two ways:-   a) We may get-         $df = ...$cfoo...-         $cfoo = ...$df....-         [INLINE $cfoo = ...no-$df...]-      But we want $cfoo to depend on $df explicitly so that we-      put the bindings in the right order to inline $df in $cfoo-      and perhaps break the loop altogether.  (Maybe this-   b)---Example [eftInt]-~~~~~~~~~~~~~~~-Example (from GHC.Enum):--  eftInt :: Int# -> Int# -> [Int]-  eftInt x y = ...(non-recursive)...--  {-# INLINE [0] eftIntFB #-}-  eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r-  eftIntFB c n x y = ...(non-recursive)...--  {-# RULES-  "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)-  "eftIntList"  [1] eftIntFB  (:) [] = eftInt-   #-}--Note [Specialisation rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this group, which is typical of what SpecConstr builds:--   fs a = ....f (C a)....-   f  x = ....f (C a)....-   {-# RULE f (C a) = fs a #-}--So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).--But watch out!  If 'fs' is not chosen as a loop breaker, we may get an infinite loop:-  - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify-  - fs is inlined (say it's small)-  - now there's another opportunity to apply the RULE--This showed up when compiling Control.Concurrent.Chan.getChanContents.---------------------------------------------------------------Note [Finding join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~-It's the occurrence analyser's job to find bindings that we can turn into join-points, but it doesn't perform that transformation right away. Rather, it marks-the eligible bindings as part of their occurrence data, leaving it to the-simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'.-The simplifier then eta-expands the RHS if needed and then updates the-occurrence sites. Dividing the work this way means that the occurrence analyser-still only takes one pass, yet one can always tell the difference between a-function call and a jump by looking at the occurrence (because the same pass-changes the 'IdDetails' and propagates the binders to their occurrence sites).--To track potential join points, we use the 'occ_tail' field of OccInfo. A value-of `AlwaysTailCalled n` indicates that every occurrence of the variable is a-tail call with `n` arguments (counting both value and type arguments). Otherwise-'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the-rest of 'OccInfo' until it goes on the binder.--Note [Rules and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Things get fiddly with rules. Suppose we have:--  let j :: Int -> Int-      j y = 2 * y-      k :: Int -> Int -> Int-      {-# RULES "SPEC k 0" k 0 = j #-}-      k x y = x + 2 * y-  in ...--Now suppose that both j and k appear only as saturated tail calls in the body.-Thus we would like to make them both join points. The rule complicates matters,-though, as its RHS has an unapplied occurrence of j. *However*, if we were to-eta-expand the rule, all would be well:--  {-# RULES "SPEC k 0" forall a. k 0 a = j a #-}--So conceivably we could notice that a potential join point would have an-"undersaturated" rule and account for it. This would mean we could make-something that's been specialised a join point, for instance. But local bindings-are rarely specialised, and being overly cautious about rules only-costs us anything when, for some `j`:--  * Before specialisation, `j` has non-tail calls, so it can't be a join point.-  * During specialisation, `j` gets specialised and thus acquires rules.-  * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say),-    and so now `j` *could* become a join point.--This appears to be very rare in practice. TODO Perhaps we should gather-statistics to be sure.---------------------------------------------------------------Note [Adjusting right-hand sides]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There's a bit of a dance we need to do after analysing a lambda expression or-a right-hand side. In particular, we need to--  a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot-     lambda, or a non-recursive join point; and-  b) call 'markAllNonTailCalled' *unless* the binding is for a join point.--Some examples, with how the free occurrences in e (assumed not to be a value-lambda) get marked:--                             inside lam    non-tail-called-  -------------------------------------------------------------  let x = e                  No            Yes-  let f = \x -> e            Yes           Yes-  let f = \x{OneShot} -> e   No            Yes-  \x -> e                    Yes           Yes-  join j x = e               No            No-  joinrec j x = e            Yes           No--There are a few other caveats; most importantly, if we're marking a binding as-'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so-that the effect cascades properly. Consequently, at the time the RHS is-analysed, we won't know what adjustments to make; thus 'occAnalLamOrRhs' must-return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once-join-point-hood has been decided.--Thus the overall sequence taking place in 'occAnalNonRecBind' and-'occAnalRecBind' is as follows:--  1. Call 'occAnalLamOrRhs' to find usage information for the RHS.-  2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make-     the binding a join point.-  3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when-     recursive.)--(In the recursive case, this logic is spread between 'makeNode' and-'occAnalRec'.)--}-----------------------------------------------------------------------                 occAnalBind---------------------------------------------------------------------occAnalBind :: OccEnv           -- The incoming OccEnv-            -> TopLevelFlag-            -> ImpRuleEdges-            -> CoreBind-            -> UsageDetails             -- Usage details of scope-            -> (UsageDetails,           -- Of the whole let(rec)-                [CoreBind])--occAnalBind env lvl top_env (NonRec binder rhs) body_usage-  = occAnalNonRecBind env lvl top_env binder rhs body_usage-occAnalBind env lvl top_env (Rec pairs) body_usage-  = occAnalRecBind env lvl top_env pairs body_usage--------------------occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr-                  -> UsageDetails -> (UsageDetails, [CoreBind])-occAnalNonRecBind env lvl imp_rule_edges binder rhs body_usage-  | isTyVar binder      -- A type let; we don't gather usage info-  = (body_usage, [NonRec binder rhs])--  | not (binder `usedIn` body_usage)    -- It's not mentioned-  = (body_usage, [])--  | otherwise                   -- It's mentioned in the body-  = (body_usage' `andUDs` rhs_usage', [NonRec tagged_binder rhs'])-  where-    (body_usage', tagged_binder) = tagNonRecBinder lvl body_usage binder-    mb_join_arity = willBeJoinId_maybe tagged_binder--    (bndrs, body) = collectBinders rhs--    (rhs_usage1, bndrs', body') = occAnalNonRecRhs env tagged_binder bndrs body-    rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body'-           -- For a /non-recursive/ join point we can mark all-           -- its join-lambda as one-shot; and it's a good idea to do so--    -- Unfoldings-    -- See Note [Unfoldings and join points]-    rhs_usage2 = case occAnalUnfolding env NonRecursive binder of-                   Just unf_usage -> rhs_usage1 `andUDs` unf_usage-                   Nothing        -> rhs_usage1--    -- Rules-    -- See Note [Rules are extra RHSs] and Note [Rule dependency info]-    rules_w_uds = occAnalRules env mb_join_arity NonRecursive tagged_binder-    rule_uds    = map (\(_, l, r) -> l `andUDs` r) rules_w_uds-    rhs_usage3 = foldr andUDs rhs_usage2 rule_uds-    rhs_usage4 = case lookupVarEnv imp_rule_edges binder of-                   Nothing -> rhs_usage3-                   Just vs -> addManyOccsSet rhs_usage3 vs-       -- See Note [Preventing loops due to imported functions rules]--    -- Final adjustment-    rhs_usage' = adjustRhsUsage mb_join_arity NonRecursive bndrs' rhs_usage4--------------------occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]-               -> UsageDetails -> (UsageDetails, [CoreBind])-occAnalRecBind env lvl imp_rule_edges pairs body_usage-  = foldr (occAnalRec env lvl) (body_usage, []) sccs-        -- For a recursive group, we-        --      * occ-analyse all the RHSs-        --      * compute strongly-connected components-        --      * feed those components to occAnalRec-        -- See Note [Recursive bindings: the grand plan]-  where-    sccs :: [SCC Details]-    sccs = {-# SCC "occAnalBind.scc" #-}-           stronglyConnCompFromEdgedVerticesUniq nodes--    nodes :: [LetrecNode]-    nodes = {-# SCC "occAnalBind.assoc" #-}-            map (makeNode env imp_rule_edges bndr_set) pairs--    bndr_set = mkVarSet (map fst pairs)--{--Note [Unfoldings and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--We assume that anything in an unfolding occurs multiple times, since unfoldings-are often copied (that's the whole point!). But we still need to track tail-calls for the purpose of finding join points.--}--------------------------------occAnalRec :: OccEnv -> TopLevelFlag-           -> SCC Details-           -> (UsageDetails, [CoreBind])-           -> (UsageDetails, [CoreBind])--        -- The NonRec case is just like a Let (NonRec ...) above-occAnalRec _ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs-                                 , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs }))-           (body_uds, binds)-  | not (bndr `usedIn` body_uds)-  = (body_uds, binds)           -- See Note [Dead code]--  | otherwise                   -- It's mentioned in the body-  = (body_uds' `andUDs` rhs_uds',-     NonRec tagged_bndr rhs : binds)-  where-    (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr-    rhs_uds' = adjustRhsUsage (willBeJoinId_maybe tagged_bndr) NonRecursive-                              rhs_bndrs rhs_uds--        -- The Rec case is the interesting one-        -- See Note [Recursive bindings: the grand plan]-        -- See Note [Loop breaking]-occAnalRec env lvl (CyclicSCC details_s) (body_uds, binds)-  | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds-  = (body_uds, binds)                   -- See Note [Dead code]--  | otherwise   -- At this point we always build a single Rec-  = -- pprTrace "occAnalRec" (vcat-    --  [ text "weak_fvs" <+> ppr weak_fvs-    --  , text "lb nodes" <+> ppr loop_breaker_nodes])-    (final_uds, Rec pairs : binds)--  where-    bndrs    = map nd_bndr details_s-    bndr_set = mkVarSet bndrs--    -------------------------------        -- See Note [Choosing loop breakers] for loop_breaker_nodes-    final_uds :: UsageDetails-    loop_breaker_nodes :: [LetrecNode]-    (final_uds, loop_breaker_nodes)-      = mkLoopBreakerNodes env lvl bndr_set body_uds details_s--    -------------------------------    weak_fvs :: VarSet-    weak_fvs = mapUnionVarSet nd_weak details_s--    ----------------------------    -- Now reconstruct the cycle-    pairs :: [(Id,CoreExpr)]-    pairs | isEmptyVarSet weak_fvs = reOrderNodes   0 bndr_set weak_fvs loop_breaker_nodes []-          | otherwise              = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_nodes []-          -- If weak_fvs is empty, the loop_breaker_nodes will include-          -- all the edges in the original scope edges [remember,-          -- weak_fvs is the difference between scope edges and-          -- lb-edges], so a fresh SCC computation would yield a-          -- single CyclicSCC result; and reOrderNodes deals with-          -- exactly that case------------------------------------------------------------------------                 Loop breaking---------------------------------------------------------------------type Binding = (Id,CoreExpr)--loopBreakNodes :: Int-               -> VarSet        -- All binders-               -> VarSet        -- Binders whose dependencies may be "missing"-                                -- See Note [Weak loop breakers]-               -> [LetrecNode]-               -> [Binding]             -- Append these to the end-               -> [Binding]-{--loopBreakNodes is applied to the list of nodes for a cyclic strongly-connected component (there's guaranteed to be a cycle).  It returns-the same nodes, but-        a) in a better order,-        b) with some of the Ids having a IAmALoopBreaker pragma--The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means-that the simplifier can guarantee not to loop provided it never records an inlining-for these no-inline guys.--Furthermore, the order of the binds is such that if we neglect dependencies-on the no-inline Ids then the binds are topologically sorted.  This means-that the simplifier will generally do a good job if it works from top bottom,-recording inlinings for any Ids which aren't marked as "no-inline" as it goes.--}---- Return the bindings sorted into a plausible order, and marked with loop breakers.-loopBreakNodes depth bndr_set weak_fvs nodes binds-  = -- pprTrace "loopBreakNodes" (ppr nodes) $-    go (stronglyConnCompFromEdgedVerticesUniqR nodes) binds-  where-    go []         binds = binds-    go (scc:sccs) binds = loop_break_scc scc (go sccs binds)--    loop_break_scc scc binds-      = case scc of-          AcyclicSCC node  -> mk_non_loop_breaker weak_fvs node : binds-          CyclicSCC nodes  -> reOrderNodes depth bndr_set weak_fvs nodes binds-------------------------------------reOrderNodes :: Int -> VarSet -> VarSet -> [LetrecNode] -> [Binding] -> [Binding]-    -- Choose a loop breaker, mark it no-inline,-    -- and call loopBreakNodes on the rest-reOrderNodes _ _ _ []     _     = panic "reOrderNodes"-reOrderNodes _ _ _ [node] binds = mk_loop_breaker node : binds-reOrderNodes depth bndr_set weak_fvs (node : nodes) binds-  = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen-    --                              , text "chosen" <+> ppr chosen_nodes ]) $-    loopBreakNodes new_depth bndr_set weak_fvs unchosen $-    (map mk_loop_breaker chosen_nodes ++ binds)-  where-    (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb-                                                 (nd_score (node_payload node))-                                                 [node] [] nodes--    approximate_lb = depth >= 2-    new_depth | approximate_lb = 0-              | otherwise      = depth+1-        -- After two iterations (d=0, d=1) give up-        -- and approximate, returning to d=0--mk_loop_breaker :: LetrecNode -> Binding-mk_loop_breaker (node_payload -> ND { nd_bndr = bndr, nd_rhs = rhs})-  = (bndr `setIdOccInfo` strongLoopBreaker { occ_tail = tail_info }, rhs)-  where-    tail_info = tailCallInfo (idOccInfo bndr)--mk_non_loop_breaker :: VarSet -> LetrecNode -> Binding--- See Note [Weak loop breakers]-mk_non_loop_breaker weak_fvs (node_payload -> ND { nd_bndr = bndr-                                                 , nd_rhs = rhs})-  | bndr `elemVarSet` weak_fvs = (setIdOccInfo bndr occ', rhs)-  | otherwise                  = (bndr, rhs)-  where-    occ' = weakLoopBreaker { occ_tail = tail_info }-    tail_info = tailCallInfo (idOccInfo bndr)-------------------------------------chooseLoopBreaker :: Bool             -- True <=> Too many iterations,-                                      --          so approximate-                  -> NodeScore            -- Best score so far-                  -> [LetrecNode]       -- Nodes with this score-                  -> [LetrecNode]       -- Nodes with higher scores-                  -> [LetrecNode]       -- Unprocessed nodes-                  -> ([LetrecNode], [LetrecNode])-    -- This loop looks for the bind with the lowest score-    -- to pick as the loop  breaker.  The rest accumulate in-chooseLoopBreaker _ _ loop_nodes acc []-  = (loop_nodes, acc)        -- Done--    -- If approximate_loop_breaker is True, we pick *all*-    -- nodes with lowest score, else just one-    -- See Note [Complexity of loop breaking]-chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes)-  | approx_lb-  , rank sc == rank loop_sc-  = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes--  | sc `betterLB` loop_sc  -- Better score so pick this new one-  = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes--  | otherwise              -- Worse score so don't pick it-  = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes-  where-    sc = nd_score (node_payload node)--{--Note [Complexity of loop breaking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The loop-breaking algorithm knocks out one binder at a time, and-performs a new SCC analysis on the remaining binders.  That can-behave very badly in tightly-coupled groups of bindings; in the-worst case it can be (N**2)*log N, because it does a full SCC-on N, then N-1, then N-2 and so on.--To avoid this, we switch plans after 2 (or whatever) attempts:-  Plan A: pick one binder with the lowest score, make it-          a loop breaker, and try again-  Plan B: pick *all* binders with the lowest score, make them-          all loop breakers, and try again-Since there are only a small finite number of scores, this will-terminate in a constant number of iterations, rather than O(N)-iterations.--You might thing that it's very unlikely, but RULES make it much-more likely.  Here's a real example from #1969:-  Rec { $dm = \d.\x. op d-        {-# RULES forall d. $dm Int d  = $s$dm1-                  forall d. $dm Bool d = $s$dm2 #-}--        dInt = MkD .... opInt ...-        dInt = MkD .... opBool ...-        opInt  = $dm dInt-        opBool = $dm dBool--        $s$dm1 = \x. op dInt-        $s$dm2 = \x. op dBool }-The RULES stuff means that we can't choose $dm as a loop breaker-(Note [Choosing loop breakers]), so we must choose at least (say)-opInt *and* opBool, and so on.  The number of loop breakders is-linear in the number of instance declarations.--Note [Loop breakers and INLINE/INLINABLE pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Avoid choosing a function with an INLINE pramga as the loop breaker!-If such a function is mutually-recursive with a non-INLINE thing,-then the latter should be the loop-breaker.--It's vital to distinguish between INLINE and INLINABLE (the-Bool returned by hasStableCoreUnfolding_maybe).  If we start with-   Rec { {-# INLINABLE f #-}-         f x = ...f... }-and then worker/wrapper it through strictness analysis, we'll get-   Rec { {-# INLINABLE $wf #-}-         $wf p q = let x = (p,q) in ...f...--         {-# INLINE f #-}-         f x = case x of (p,q) -> $wf p q }--Now it is vital that we choose $wf as the loop breaker, so we can-inline 'f' in '$wf'.--Note [DFuns should not be loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's particularly bad to make a DFun into a loop breaker.  See-Note [How instance declarations are translated] in TcInstDcls--We give DFuns a higher score than ordinary CONLIKE things because-if there's a choice we want the DFun to be the non-loop breaker. Eg--rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)--      $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)-      {-# DFUN #-}-      $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)-    }--Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it-if we can't unravel the DFun first.--Note [Constructor applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's really really important to inline dictionaries.  Real-example (the Enum Ordering instance from GHC.Base):--     rec     f = \ x -> case d of (p,q,r) -> p x-             g = \ x -> case d of (p,q,r) -> q x-             d = (v, f, g)--Here, f and g occur just once; but we can't inline them into d.-On the other hand we *could* simplify those case expressions if-we didn't stupidly choose d as the loop breaker.-But we won't because constructor args are marked "Many".-Inlining dictionaries is really essential to unravelling-the loops in static numeric dictionaries, see GHC.Float.--Note [Closure conversion]-~~~~~~~~~~~~~~~~~~~~~~~~~-We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.-The immediate motivation came from the result of a closure-conversion transformation-which generated code like this:--    data Clo a b = forall c. Clo (c -> a -> b) c--    ($:) :: Clo a b -> a -> b-    Clo f env $: x = f env x--    rec { plus = Clo plus1 ()--        ; plus1 _ n = Clo plus2 n--        ; plus2 Zero     n = n-        ; plus2 (Succ m) n = Succ (plus $: m $: n) }--If we inline 'plus' and 'plus1', everything unravels nicely.  But if-we choose 'plus1' as the loop breaker (which is entirely possible-otherwise), the loop does not unravel nicely.---@occAnalUnfolding@ deals with the question of bindings where the Id is marked-by an INLINE pragma.  For these we record that anything which occurs-in its RHS occurs many times.  This pessimistically assumes that this-inlined binder also occurs many times in its scope, but if it doesn't-we'll catch it next time round.  At worst this costs an extra simplifier pass.-ToDo: try using the occurrence info for the inline'd binder.--[March 97] We do the same for atomic RHSs.  Reason: see notes with loopBreakSCC.-[June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with loopBreakSCC.---************************************************************************-*                                                                      *-                   Making nodes-*                                                                      *-************************************************************************--}--type ImpRuleEdges = IdEnv IdSet     -- Mapping from FVs of imported RULE LHSs to RHS FVs--noImpRuleEdges :: ImpRuleEdges-noImpRuleEdges = emptyVarEnv--type LetrecNode = Node Unique Details  -- Node comes from Digraph-                                       -- The Unique key is gotten from the Id-data Details-  = ND { nd_bndr :: Id          -- Binder-       , nd_rhs  :: CoreExpr    -- RHS, already occ-analysed-       , nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS-                                    -- INVARIANT: (nd_rhs_bndrs nd, _) ==-                                    --              collectBinders (nd_rhs nd)--       , nd_uds  :: UsageDetails  -- Usage from RHS, and RULES, and stable unfoldings-                                  -- ignoring phase (ie assuming all are active)-                                  -- See Note [Forming Rec groups]--       , nd_inl  :: IdSet       -- Free variables of-                                --   the stable unfolding (if present and active)-                                --   or the RHS (if not)-                                -- but excluding any RULES-                                -- This is the IdSet that may be used if the Id is inlined--       , nd_weak :: IdSet       -- Binders of this Rec that are mentioned in nd_uds-                                -- but are *not* in nd_inl.  These are the ones whose-                                -- dependencies might not be respected by loop_breaker_nodes-                                -- See Note [Weak loop breakers]--       , nd_active_rule_fvs :: IdSet   -- Free variables of the RHS of active RULES--       , nd_score :: NodeScore-  }--instance Outputable Details where-   ppr nd = text "ND" <> braces-             (sep [ text "bndr =" <+> ppr (nd_bndr nd)-                  , text "uds =" <+> ppr (nd_uds nd)-                  , text "inl =" <+> ppr (nd_inl nd)-                  , text "weak =" <+> ppr (nd_weak nd)-                  , text "rule =" <+> ppr (nd_active_rule_fvs nd)-                  , text "score =" <+> ppr (nd_score nd)-             ])---- The NodeScore is compared lexicographically;---      e.g. lower rank wins regardless of size-type NodeScore = ( Int     -- Rank: lower => more likely to be picked as loop breaker-                 , Int     -- Size of rhs: higher => more likely to be picked as LB-                           -- Maxes out at maxExprSize; we just use it to prioritise-                           -- small functions-                 , Bool )  -- Was it a loop breaker before?-                           -- True => more likely to be picked-                           -- Note [Loop breakers, node scoring, and stability]--rank :: NodeScore -> Int-rank (r, _, _) = r--makeNode :: OccEnv -> ImpRuleEdges -> VarSet-         -> (Var, CoreExpr) -> LetrecNode--- See Note [Recursive bindings: the grand plan]-makeNode env imp_rule_edges bndr_set (bndr, rhs)-  = DigraphNode details (varUnique bndr) (nonDetKeysUniqSet node_fvs)-    -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR-    -- is still deterministic with edges in nondeterministic order as-    -- explained in Note [Deterministic SCC] in Digraph.-  where-    details = ND { nd_bndr            = bndr-                 , nd_rhs             = rhs'-                 , nd_rhs_bndrs       = bndrs'-                 , nd_uds             = rhs_usage3-                 , nd_inl             = inl_fvs-                 , nd_weak            = node_fvs `minusVarSet` inl_fvs-                 , nd_active_rule_fvs = active_rule_fvs-                 , nd_score           = pprPanic "makeNodeDetails" (ppr bndr) }--    -- Constructing the edges for the main Rec computation-    -- See Note [Forming Rec groups]-    (bndrs, body) = collectBinders rhs-    (rhs_usage1, bndrs', body') = occAnalRecRhs env bndrs body-    rhs' = mkLams bndrs' body'-    rhs_usage2 = foldr andUDs rhs_usage1 rule_uds-                   -- Note [Rules are extra RHSs]-                   -- Note [Rule dependency info]-    rhs_usage3 = case mb_unf_uds of-                   Just unf_uds -> rhs_usage2 `andUDs` unf_uds-                   Nothing      -> rhs_usage2-    node_fvs = udFreeVars bndr_set rhs_usage3--    -- Finding the free variables of the rules-    is_active = occ_rule_act env :: Activation -> Bool--    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]-    rules_w_uds = occAnalRules env (Just (length bndrs)) Recursive bndr--    rules_w_rhs_fvs :: [(Activation, VarSet)]    -- Find the RHS fvs-    rules_w_rhs_fvs = maybe id (\ids -> ((AlwaysActive, ids):))-                               (lookupVarEnv imp_rule_edges bndr)-      -- See Note [Preventing loops due to imported functions rules]-                      [ (ru_act rule, udFreeVars bndr_set rhs_uds)-                      | (rule, _, rhs_uds) <- rules_w_uds ]-    rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds-    active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_rhs_fvs-                                        , is_active a]--    -- Finding the usage details of the INLINE pragma (if any)-    mb_unf_uds = occAnalUnfolding env Recursive bndr--    -- Find the "nd_inl" free vars; for the loop-breaker phase-    inl_fvs = case mb_unf_uds of-                Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS-                Just unf_uds -> udFreeVars bndr_set unf_uds-                      -- We could check for an *active* INLINE (returning-                      -- emptyVarSet for an inactive one), but is_active-                      -- isn't the right thing (it tells about-                      -- RULE activation), so we'd need more plumbing--mkLoopBreakerNodes :: OccEnv -> TopLevelFlag-                   -> VarSet-                   -> UsageDetails   -- for BODY of let-                   -> [Details]-                   -> (UsageDetails, -- adjusted-                       [LetrecNode])--- Does four things---   a) tag each binder with its occurrence info---   b) add a NodeScore to each node---   c) make a Node with the right dependency edges for---      the loop-breaker SCC analysis---   d) adjust each RHS's usage details according to---      the binder's (new) shotness and join-point-hood-mkLoopBreakerNodes env lvl bndr_set body_uds details_s-  = (final_uds, zipWith mk_lb_node details_s bndrs')-  where-    (final_uds, bndrs') = tagRecBinders lvl body_uds-                            [ ((nd_bndr nd)-                               ,(nd_uds nd)-                               ,(nd_rhs_bndrs nd))-                            | nd <- details_s ]-    mk_lb_node nd@(ND { nd_bndr = bndr, nd_rhs = rhs, nd_inl = inl_fvs }) bndr'-      = DigraphNode nd' (varUnique bndr) (nonDetKeysUniqSet lb_deps)-              -- It's OK to use nonDetKeysUniqSet here as-              -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges-              -- in nondeterministic order as explained in-              -- Note [Deterministic SCC] in Digraph.-      where-        nd'     = nd { nd_bndr = bndr', nd_score = score }-        score   = nodeScore env bndr bndr' rhs lb_deps-        lb_deps = extendFvs_ rule_fv_env inl_fvs--    rule_fv_env :: IdEnv IdSet-        -- Maps a variable f to the variables from this group-        --      mentioned in RHS of active rules for f-        -- Domain is *subset* of bound vars (others have no rule fvs)-    rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs)-    init_rule_fvs   -- See Note [Finding rule RHS free vars]-      = [ (b, trimmed_rule_fvs)-        | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s-        , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set-        , not (isEmptyVarSet trimmed_rule_fvs) ]----------------------------------------------nodeScore :: OccEnv-          -> Id        -- Binder has old occ-info (just for loop-breaker-ness)-          -> Id        -- Binder with new occ-info-          -> CoreExpr  -- RHS-          -> VarSet    -- Loop-breaker dependencies-          -> NodeScore-nodeScore env old_bndr new_bndr bind_rhs lb_deps-  | not (isId old_bndr)     -- A type or coercion variable is never a loop breaker-  = (100, 0, False)--  | old_bndr `elemVarSet` lb_deps  -- Self-recursive things are great loop breakers-  = (0, 0, True)                   -- See Note [Self-recursion and loop breakers]--  | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has-  = (0, 0, True)                   -- a NOINLINE pragma) makes a great loop breaker--  | exprIsTrivial rhs-  = mk_score 10  -- Practically certain to be inlined-    -- Used to have also: && not (isExportedId bndr)-    -- But I found this sometimes cost an extra iteration when we have-    --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }-    -- where df is the exported dictionary. Then df makes a really-    -- bad choice for loop breaker--  | DFunUnfolding { df_args = args } <- id_unfolding-    -- Never choose a DFun as a loop breaker-    -- Note [DFuns should not be loop breakers]-  = (9, length args, is_lb)--    -- Data structures are more important than INLINE pragmas-    -- so that dictionary/method recursion unravels--  | CoreUnfolding { uf_guidance = UnfWhen {} } <- id_unfolding-  = mk_score 6--  | is_con_app rhs   -- Data types help with cases:-  = mk_score 5       -- Note [Constructor applications]--  | isStableUnfolding id_unfolding-  , can_unfold-  = mk_score 3--  | isOneOcc (idOccInfo new_bndr)-  = mk_score 2  -- Likely to be inlined--  | can_unfold  -- The Id has some kind of unfolding-  = mk_score 1--  | otherwise-  = (0, 0, is_lb)--  where-    mk_score :: Int -> NodeScore-    mk_score rank = (rank, rhs_size, is_lb)--    is_lb    = isStrongLoopBreaker (idOccInfo old_bndr)-    rhs      = case id_unfolding of-                 CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs }-                    | isStableSource src-                    -> unf_rhs-                 _  -> bind_rhs-       -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding-    rhs_size = case id_unfolding of-                 CoreUnfolding { uf_guidance = guidance }-                    | UnfIfGoodArgs { ug_size = size } <- guidance-                    -> size-                 _  -> cheapExprSize rhs--    can_unfold   = canUnfold id_unfolding-    id_unfolding = realIdUnfolding old_bndr-       -- realIdUnfolding: Ignore loop-breaker-ness here because-       -- that is what we are setting!--        -- Checking for a constructor application-        -- Cheap and cheerful; the simplifier moves casts out of the way-        -- The lambda case is important to spot x = /\a. C (f a)-        -- which comes up when C is a dictionary constructor and-        -- f is a default method.-        -- Example: the instance for Show (ST s a) in GHC.ST-        ---        -- However we *also* treat (\x. C p q) as a con-app-like thing,-        --      Note [Closure conversion]-    is_con_app (Var v)    = isConLikeId v-    is_con_app (App f _)  = is_con_app f-    is_con_app (Lam _ e)  = is_con_app e-    is_con_app (Tick _ e) = is_con_app e-    is_con_app _          = False--maxExprSize :: Int-maxExprSize = 20  -- Rather arbitrary--cheapExprSize :: CoreExpr -> Int--- Maxes out at maxExprSize-cheapExprSize e-  = go 0 e-  where-    go n e | n >= maxExprSize = n-           | otherwise        = go1 n e--    go1 n (Var {})        = n+1-    go1 n (Lit {})        = n+1-    go1 n (Type {})       = n-    go1 n (Coercion {})   = n-    go1 n (Tick _ e)      = go1 n e-    go1 n (Cast e _)      = go1 n e-    go1 n (App f a)       = go (go1 n f) a-    go1 n (Lam b e)-      | isTyVar b         = go1 n e-      | otherwise         = go (n+1) e-    go1 n (Let b e)       = gos (go1 n e) (rhssOfBind b)-    go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as)--    gos n [] = n-    gos n (e:es) | n >= maxExprSize = n-                 | otherwise        = gos (go1 n e) es--betterLB :: NodeScore -> NodeScore -> Bool--- If  n1 `betterLB` n2  then choose n1 as the loop breaker-betterLB (rank1, size1, lb1) (rank2, size2, _)-  | rank1 < rank2 = True-  | rank1 > rank2 = False-  | size1 < size2 = False   -- Make the bigger n2 into the loop breaker-  | size1 > size2 = True-  | lb1           = True    -- Tie-break: if n1 was a loop breaker before, choose it-  | otherwise     = False   -- See Note [Loop breakers, node scoring, and stability]--{- Note [Self-recursion and loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have-   rec { f = ...f...g...-       ; g = .....f...   }-then 'f' has to be a loop breaker anyway, so we may as well choose it-right away, so that g can inline freely.--This is really just a cheap hack. Consider-   rec { f = ...g...-       ; g = ..f..h...-      ;  h = ...f....}-Here f or g are better loop breakers than h; but we might accidentally-choose h.  Finding the minimal set of loop breakers is hard.--Note [Loop breakers, node scoring, and stability]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-To choose a loop breaker, we give a NodeScore to each node in the SCC,-and pick the one with the best score (according to 'betterLB').--We need to be jolly careful (#12425, #12234) about the stability-of this choice. Suppose we have--    let rec { f = ...g...g...-            ; g = ...f...f... }-    in-    case x of-      True  -> ...f..-      False -> ..f...--In each iteration of the simplifier the occurrence analyser OccAnal-chooses a loop breaker. Suppose in iteration 1 it choose g as the loop-breaker. That means it is free to inline f.--Suppose that GHC decides to inline f in the branches of the case, but-(for some reason; eg it is not saturated) in the rhs of g. So we get--    let rec { f = ...g...g...-            ; g = ...f...f... }-    in-    case x of-      True  -> ...g...g.....-      False -> ..g..g....--Now suppose that, for some reason, in the next iteration the occurrence-analyser chooses f as the loop breaker, so it can freely inline g. And-again for some reason the simplifier inlines g at its calls in the case-branches, but not in the RHS of f. Then we get--    let rec { f = ...g...g...-            ; g = ...f...f... }-    in-    case x of-      True  -> ...(...f...f...)...(...f..f..).....-      False -> ..(...f...f...)...(..f..f...)....--You can see where this is going! Each iteration of the simplifier-doubles the number of calls to f or g. No wonder GHC is slow!--(In the particular example in comment:3 of #12425, f and g are the two-mutually recursive fmap instances for CondT and Result. They are both-marked INLINE which, oddly, is why they don't inline in each other's-RHS, because the call there is not saturated.)--The root cause is that we flip-flop on our choice of loop breaker. I-always thought it didn't matter, and indeed for any single iteration-to terminate, it doesn't matter. But when we iterate, it matters a-lot!!--So The Plan is this:-   If there is a tie, choose the node that-   was a loop breaker last time round--Hence the is_lb field of NodeScore--************************************************************************-*                                                                      *-                   Right hand sides-*                                                                      *-************************************************************************--}--occAnalRhs :: OccEnv -> RecFlag -> Id -> [CoreBndr] -> CoreExpr-           -> (UsageDetails, [CoreBndr], CoreExpr)-              -- Returned usage details covers only the RHS,-              -- and *not* the RULE or INLINE template for the Id-occAnalRhs env Recursive _ bndrs body-  = occAnalRecRhs env bndrs body-occAnalRhs env NonRecursive id bndrs body-  = occAnalNonRecRhs env id bndrs body--occAnalRecRhs :: OccEnv -> [CoreBndr] -> CoreExpr    -- Rhs lambdas, body-           -> (UsageDetails, [CoreBndr], CoreExpr)-              -- Returned usage details covers only the RHS,-              -- and *not* the RULE or INLINE template for the Id-occAnalRecRhs env bndrs body = occAnalLamOrRhs (rhsCtxt env) bndrs body--occAnalNonRecRhs :: OccEnv-                 -> Id -> [CoreBndr] -> CoreExpr    -- Binder; rhs lams, body-                     -- Binder is already tagged with occurrence info-                 -> (UsageDetails, [CoreBndr], CoreExpr)-              -- Returned usage details covers only the RHS,-              -- and *not* the RULE or INLINE template for the Id-occAnalNonRecRhs env bndr bndrs body-  = occAnalLamOrRhs rhs_env bndrs body-  where-    env1 | is_join_point    = env  -- See Note [Join point RHSs]-         | certainly_inline = env  -- See Note [Cascading inlines]-         | otherwise        = rhsCtxt env--    -- See Note [Sources of one-shot information]-    rhs_env = env1 { occ_one_shots = argOneShots dmd }--    certainly_inline -- See Note [Cascading inlines]-      = case occ of-          OneOcc { occ_in_lam = NotInsideLam, occ_one_br = InOneBranch }-            -> active && not_stable-          _ -> False--    is_join_point = isAlwaysTailCalled occ-    -- Like (isJoinId bndr) but happens one step earlier-    --  c.f. willBeJoinId_maybe--    occ        = idOccInfo bndr-    dmd        = idDemandInfo bndr-    active     = isAlwaysActive (idInlineActivation bndr)-    not_stable = not (isStableUnfolding (idUnfolding bndr))--occAnalUnfolding :: OccEnv-                 -> RecFlag-                 -> Id-                 -> Maybe UsageDetails-                      -- Just the analysis, not a new unfolding. The unfolding-                      -- got analysed when it was created and we don't need to-                      -- update it.-occAnalUnfolding env rec_flag id-  = case realIdUnfolding id of -- ignore previous loop-breaker flag-      CoreUnfolding { uf_tmpl = rhs, uf_src = src }-        | not (isStableSource src)-        -> Nothing-        | otherwise-        -> Just $ markAllMany usage-        where-          (bndrs, body) = collectBinders rhs-          (usage, _, _) = occAnalRhs env rec_flag id bndrs body--      DFunUnfolding { df_bndrs = bndrs, df_args = args }-        -> Just $ zapDetails (delDetailsList usage bndrs)-        where-          usage = andUDsList (map (fst . occAnal env) args)--      _ -> Nothing--occAnalRules :: OccEnv-             -> Maybe JoinArity -- If the binder is (or MAY become) a join-                                -- point, what its join arity is (or WOULD-                                -- become). See Note [Rules and join points].-             -> RecFlag-             -> Id-             -> [(CoreRule,      -- Each (non-built-in) rule-                  UsageDetails,  -- Usage details for LHS-                  UsageDetails)] -- Usage details for RHS-occAnalRules env mb_expected_join_arity rec_flag id-  = [ (rule, lhs_uds, rhs_uds) | rule@Rule {} <- idCoreRules id-                               , let (lhs_uds, rhs_uds) = occ_anal_rule rule ]-  where-    occ_anal_rule (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })-      = (lhs_uds, final_rhs_uds)-      where-        lhs_uds = addManyOccsSet emptyDetails $-                    (exprsFreeVars args `delVarSetList` bndrs)-        (rhs_bndrs, rhs_body) = collectBinders rhs-        (rhs_uds, _, _) = occAnalRhs env rec_flag id rhs_bndrs rhs_body-                            -- Note [Rules are extra RHSs]-                            -- Note [Rule dependency info]-        final_rhs_uds = adjust_tail_info args $ markAllMany $-                          (rhs_uds `delDetailsList` bndrs)-    occ_anal_rule _-      = (emptyDetails, emptyDetails)--    adjust_tail_info args uds -- see Note [Rules and join points]-      = case mb_expected_join_arity of-          Just ar | args `lengthIs` ar -> uds-          _                            -> markAllNonTailCalled uds-{- Note [Join point RHSs]-~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   x = e-   join j = Just x--We want to inline x into j right away, so we don't want to give-the join point a RhsCtxt (#14137).  It's not a huge deal, because-the FloatIn pass knows to float into join point RHSs; and the simplifier-does not float things out of join point RHSs.  But it's a simple, cheap-thing to do.  See #14137.--Note [Cascading inlines]-~~~~~~~~~~~~~~~~~~~~~~~~-By default we use an rhsCtxt for the RHS of a binding.  This tells the-occ anal n that it's looking at an RHS, which has an effect in-occAnalApp.  In particular, for constructor applications, it makes-the arguments appear to have NoOccInfo, so that we don't inline into-them. Thus    x = f y-              k = Just x-we do not want to inline x.--But there's a problem.  Consider-     x1 = a0 : []-     x2 = a1 : x1-     x3 = a2 : x2-     g  = f x3-First time round, it looks as if x1 and x2 occur as an arg of a-let-bound constructor ==> give them a many-occurrence.-But then x3 is inlined (unconditionally as it happens) and-next time round, x2 will be, and the next time round x1 will be-Result: multiple simplifier iterations.  Sigh.--So, when analysing the RHS of x3 we notice that x3 will itself-definitely inline the next time round, and so we analyse x3's rhs in-an ordinary context, not rhsCtxt.  Hence the "certainly_inline" stuff.--Annoyingly, we have to approximate SimplUtils.preInlineUnconditionally.-If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and-   (b) certainly_inline says "yes" when preInlineUnconditionally says "no"-then the simplifier iterates indefinitely:-        x = f y-        k = Just x   -- We decide that k is 'certainly_inline'-        v = ...k...  -- but preInlineUnconditionally doesn't inline it-inline ==>-        k = Just (f y)-        v = ...k...-float ==>-        x1 = f y-        k = Just x1-        v = ...k...--This is worse than the slow cascade, so we only want to say "certainly_inline"-if it really is certain.  Look at the note with preInlineUnconditionally-for the various clauses.---************************************************************************-*                                                                      *-                Expressions-*                                                                      *-************************************************************************--}--occAnal :: OccEnv-        -> CoreExpr-        -> (UsageDetails,       -- Gives info only about the "interesting" Ids-            CoreExpr)--occAnal _   expr@(Type _) = (emptyDetails,         expr)-occAnal _   expr@(Lit _)  = (emptyDetails,         expr)-occAnal env expr@(Var _)  = occAnalApp env (expr, [], [])-    -- At one stage, I gathered the idRuleVars for the variable here too,-    -- which in a way is the right thing to do.-    -- But that went wrong right after specialisation, when-    -- the *occurrences* of the overloaded function didn't have any-    -- rules in them, so the *specialised* versions looked as if they-    -- weren't used at all.--occAnal _ (Coercion co)-  = (addManyOccsSet emptyDetails (coVarsOfCo co), Coercion co)-        -- See Note [Gather occurrences of coercion variables]--{--Note [Gather occurrences of coercion variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to gather info about what coercion variables appear, so that-we can sort them into the right place when doing dependency analysis.--}--occAnal env (Tick tickish body)-  | SourceNote{} <- tickish-  = (usage, Tick tickish body')-                  -- SourceNotes are best-effort; so we just proceed as usual.-                  -- If we drop a tick due to the issues described below it's-                  -- not the end of the world.--  | tickish `tickishScopesLike` SoftScope-  = (markAllNonTailCalled usage, Tick tickish body')--  | Breakpoint _ ids <- tickish-  = (usage_lam `andUDs` foldr addManyOccs emptyDetails ids, Tick tickish body')-    -- never substitute for any of the Ids in a Breakpoint--  | otherwise-  = (usage_lam, Tick tickish body')-  where-    !(usage,body') = occAnal env body-    -- for a non-soft tick scope, we can inline lambdas only-    usage_lam = markAllNonTailCalled (markAllInsideLam usage)-                  -- TODO There may be ways to make ticks and join points play-                  -- nicer together, but right now there are problems:-                  --   let j x = ... in tick<t> (j 1)-                  -- Making j a join point may cause the simplifier to drop t-                  -- (if the tick is put into the continuation). So we don't-                  -- count j 1 as a tail call.-                  -- See #14242.--occAnal env (Cast expr co)-  = case occAnal env expr of { (usage, expr') ->-    let usage1 = zapDetailsIf (isRhsEnv env) usage-          -- usage1: if we see let x = y `cast` co-          -- then mark y as 'Many' so that we don't-          -- immediately inline y again.-        usage2 = addManyOccsSet usage1 (coVarsOfCo co)-          -- usage2: see Note [Gather occurrences of coercion variables]-    in (markAllNonTailCalled usage2, Cast expr' co)-    }--occAnal env app@(App _ _)-  = occAnalApp env (collectArgsTicks tickishFloatable app)---- Ignore type variables altogether---   (a) occurrences inside type lambdas only not marked as InsideLam---   (b) type variables not in environment--occAnal env (Lam x body)-  | isTyVar x-  = case occAnal env body of { (body_usage, body') ->-    (markAllNonTailCalled body_usage, Lam x body')-    }---- For value lambdas we do a special hack.  Consider---      (\x. \y. ...x...)--- If we did nothing, x is used inside the \y, so would be marked--- as dangerous to dup.  But in the common case where the abstraction--- is applied to two arguments this is over-pessimistic.--- So instead, we just mark each binder with its occurrence--- info in the *body* of the multiple lambda.--- Then, the simplifier is careful when partially applying lambdas.--occAnal env expr@(Lam _ _)-  = case occAnalLamOrRhs env binders body of { (usage, tagged_binders, body') ->-    let-        expr'       = mkLams tagged_binders body'-        usage1      = markAllNonTailCalled usage-        one_shot_gp = all isOneShotBndr tagged_binders-        final_usage | one_shot_gp = usage1-                    | otherwise   = markAllInsideLam usage1-    in-    (final_usage, expr') }-  where-    (binders, body) = collectBinders expr--occAnal env (Case scrut bndr ty alts)-  = case occ_anal_scrut scrut alts     of { (scrut_usage, scrut') ->-    case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts')   ->-    let-        alts_usage  = foldr orUDs emptyDetails alts_usage_s-        (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr-        total_usage = markAllNonTailCalled scrut_usage `andUDs` alts_usage1-                        -- Alts can have tail calls, but the scrutinee can't-    in-    total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}-  where-    alt_env = mkAltEnv env scrut bndr-    occ_anal_alt = occAnalAlt alt_env--    occ_anal_scrut (Var v) (alt1 : other_alts)-        | not (null other_alts) || not (isDefaultAlt alt1)-        = (mkOneOcc env v IsInteresting 0, Var v)-            -- The 'True' says that the variable occurs in an interesting-            -- context; the case has at least one non-default alternative-    occ_anal_scrut (Tick t e) alts-        | t `tickishScopesLike` SoftScope-          -- No reason to not look through all ticks here, but only-          -- for soft-scoped ticks we can do so without having to-          -- update returned occurrence info (see occAnal)-        = second (Tick t) $ occ_anal_scrut e alts--    occ_anal_scrut scrut _alts-        = occAnal (vanillaCtxt env) scrut    -- No need for rhsCtxt--occAnal env (Let bind body)-  = case occAnal env body                of { (body_usage, body') ->-    case occAnalBind env NotTopLevel-                     noImpRuleEdges bind-                     body_usage          of { (final_usage, new_binds) ->-       (final_usage, mkLets new_binds body') }}--occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])-occAnalArgs _ [] _-  = (emptyDetails, [])--occAnalArgs env (arg:args) one_shots-  | isTypeArg arg-  = case occAnalArgs env args one_shots of { (uds, args') ->-    (uds, arg:args') }--  | otherwise-  = case argCtxt env one_shots           of { (arg_env, one_shots') ->-    case occAnal arg_env arg             of { (uds1, arg') ->-    case occAnalArgs env args one_shots' of { (uds2, args') ->-    (uds1 `andUDs` uds2, arg':args') }}}--{--Applications are dealt with specially because we want-the "build hack" to work.--Note [Arguments of let-bound constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    f x = let y = expensive x in-          let z = (True,y) in-          (case z of {(p,q)->q}, case z of {(p,q)->q})-We feel free to duplicate the WHNF (True,y), but that means-that y may be duplicated thereby.--If we aren't careful we duplicate the (expensive x) call!-Constructors are rather like lambdas in this way.--}--occAnalApp :: OccEnv-           -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id])-           -> (UsageDetails, Expr CoreBndr)-occAnalApp env (Var fun, args, ticks)-  | null ticks = (uds, mkApps (Var fun) args')-  | otherwise  = (uds, mkTicks ticks $ mkApps (Var fun) args')-  where-    uds = fun_uds `andUDs` final_args_uds--    !(args_uds, args') = occAnalArgs env args one_shots-    !final_args_uds-       | isRhsEnv env && is_exp = markAllNonTailCalled $-                                  markAllInsideLam args_uds-       | otherwise              = markAllNonTailCalled args_uds-       -- We mark the free vars of the argument of a constructor or PAP-       -- as "inside-lambda", if it is the RHS of a let(rec).-       -- This means that nothing gets inlined into a constructor or PAP-       -- argument position, which is what we want.  Typically those-       -- constructor arguments are just variables, or trivial expressions.-       -- We use inside-lam because it's like eta-expanding the PAP.-       ---       -- This is the *whole point* of the isRhsEnv predicate-       -- See Note [Arguments of let-bound constructors]--    n_val_args = valArgCount args-    n_args     = length args-    fun_uds    = mkOneOcc env fun (if n_val_args > 0 then IsInteresting else NotInteresting) n_args-    is_exp     = isExpandableApp fun n_val_args-        -- See Note [CONLIKE pragma] in BasicTypes-        -- The definition of is_exp should match that in Simplify.prepareRhs--    one_shots  = argsOneShots (idStrictness fun) guaranteed_val_args-    guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo-                                                         (occ_one_shots env))-        -- See Note [Sources of one-shot information], bullet point A']--occAnalApp env (fun, args, ticks)-  = (markAllNonTailCalled (fun_uds `andUDs` args_uds),-     mkTicks ticks $ mkApps fun' args')-  where-    !(fun_uds, fun') = occAnal (addAppCtxt env args) fun-        -- The addAppCtxt is a bit cunning.  One iteration of the simplifier-        -- often leaves behind beta redexs like-        --      (\x y -> e) a1 a2-        -- Here we would like to mark x,y as one-shot, and treat the whole-        -- thing much like a let.  We do this by pushing some True items-        -- onto the context stack.-    !(args_uds, args') = occAnalArgs env args []--zapDetailsIf :: Bool              -- If this is true-             -> UsageDetails      -- Then do zapDetails on this-             -> UsageDetails-zapDetailsIf True  uds = zapDetails uds-zapDetailsIf False uds = uds--{--Note [Sources of one-shot information]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The occurrence analyser obtains one-shot-lambda information from two sources:--A:  Saturated applications:  eg   f e1 .. en--    In general, given a call (f e1 .. en) we can propagate one-shot info from-    f's strictness signature into e1 .. en, but /only/ if n is enough to-    saturate the strictness signature. A strictness signature like--          f :: C1(C1(L))LS--    means that *if f is applied to three arguments* then it will guarantee to-    call its first argument at most once, and to call the result of that at-    most once. But if f has fewer than three arguments, all bets are off; e.g.--          map (f (\x y. expensive) e2) xs--    Here the \x y abstraction may be called many times (once for each element of-    xs) so we should not mark x and y as one-shot. But if it was--          map (f (\x y. expensive) 3 2) xs--    then the first argument of f will be called at most once.--    The one-shot info, derived from f's strictness signature, is-    computed by 'argsOneShots', called in occAnalApp.--A': Non-obviously saturated applications: eg    build (f (\x y -> expensive))-    where f is as above.--    In this case, f is only manifestly applied to one argument, so it does not-    look saturated. So by the previous point, we should not use its strictness-    signature to learn about the one-shotness of \x y. But in this case we can:-    build is fully applied, so we may use its strictness signature; and from-    that we learn that build calls its argument with two arguments *at most once*.--    So there is really only one call to f, and it will have three arguments. In-    that sense, f is saturated, and we may proceed as described above.--    Hence the computation of 'guaranteed_val_args' in occAnalApp, using-    '(occ_one_shots env)'.  See also #13227, comment:9--B:  Let-bindings:  eg   let f = \c. let ... in \n -> blah-                        in (build f, build f)--    Propagate one-shot info from the demanand-info on 'f' to the-    lambdas in its RHS (which may not be syntactically at the top)--    This information must have come from a previous run of the demanand-    analyser.--Previously, the demand analyser would *also* set the one-shot information, but-that code was buggy (see #11770), so doing it only in on place, namely here, is-saner.--Note [OneShots]-~~~~~~~~~~~~~~~-When analysing an expression, the occ_one_shots argument contains information-about how the function is being used. The length of the list indicates-how many arguments will eventually be passed to the analysed expression,-and the OneShotInfo indicates whether this application is once or multiple times.--Example:-- Context of f                occ_one_shots when analysing f-- f 1 2                       [OneShot, OneShot]- map (f 1)                   [OneShot, NoOneShotInfo]- build f                     [OneShot, OneShot]- f 1 2 `seq` f 2 1           [NoOneShotInfo, OneShot]--Note [Binders in case alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    case x of y { (a,b) -> f y }-We treat 'a', 'b' as dead, because they don't physically occur in the-case alternative.  (Indeed, a variable is dead iff it doesn't occur in-its scope in the output of OccAnal.)  It really helps to know when-binders are unused.  See esp the call to isDeadBinder in-Simplify.mkDupableAlt--In this example, though, the Simplifier will bring 'a' and 'b' back to-life, because it binds 'y' to (a,b) (imagine got inlined and-scrutinised y).--}--occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr-                -> (UsageDetails, [CoreBndr], CoreExpr)-occAnalLamOrRhs env [] body-  = case occAnal env body of (body_usage, body') -> (body_usage, [], body')-      -- RHS of thunk or nullary join point-occAnalLamOrRhs env (bndr:bndrs) body-  | isTyVar bndr-  = -- Important: Keep the environment so that we don't inline into an RHS like-    --   \(@ x) -> C @x (f @x)-    -- (see the beginning of Note [Cascading inlines]).-    case occAnalLamOrRhs env bndrs body of-      (body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body')-occAnalLamOrRhs env binders body-  = case occAnal env_body body of { (body_usage, body') ->-    let-        (final_usage, tagged_binders) = tagLamBinders body_usage binders'-                      -- Use binders' to put one-shot info on the lambdas-    in-    (final_usage, tagged_binders, body') }-  where-    (env_body, binders') = oneShotGroup env binders--occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr))-           -> CoreAlt-           -> (UsageDetails, Alt IdWithOccInfo)-occAnalAlt (env, scrut_bind) (con, bndrs, rhs)-  = case occAnal env rhs of { (rhs_usage1, rhs1) ->-    let-      (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs-                                -- See Note [Binders in case alternatives]-      (alt_usg', rhs2) = wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1-    in-    (alt_usg', (con, tagged_bndrs, rhs2)) }--wrapAltRHS :: OccEnv-           -> Maybe (Id, CoreExpr)      -- proxy mapping generated by mkAltEnv-           -> UsageDetails              -- usage for entire alt (p -> rhs)-           -> [Var]                     -- alt binders-           -> CoreExpr                  -- alt RHS-           -> (UsageDetails, CoreExpr)-wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs-  | occ_binder_swap env-  , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this-                               -- handles condition (a) in Note [Binder swap]-  , not captured               -- See condition (b) in Note [Binder swap]-  = ( alt_usg' `andUDs` let_rhs_usg-    , Let (NonRec tagged_scrut_var let_rhs') alt_rhs )-  where-    captured = any (`usedIn` let_rhs_usg) bndrs  -- Check condition (b)--    -- The rhs of the let may include coercion variables-    -- if the scrutinee was a cast, so we must gather their-    -- usage. See Note [Gather occurrences of coercion variables]-    -- Moreover, the rhs of the let may mention the case-binder, and-    -- we want to gather its occ-info as well-    (let_rhs_usg, let_rhs') = occAnal env let_rhs--    (alt_usg', tagged_scrut_var) = tagLamBinder alt_usg scrut_var--wrapAltRHS _ _ alt_usg _ alt_rhs-  = (alt_usg, alt_rhs)--{--************************************************************************-*                                                                      *-                    OccEnv-*                                                                      *-************************************************************************--}--data OccEnv-  = OccEnv { occ_encl       :: !OccEncl      -- Enclosing context information-           , occ_one_shots  :: !OneShots     -- See Note [OneShots]-           , occ_gbl_scrut  :: GlobalScruts--           , occ_unf_act   :: Id -> Bool   -- Which Id unfoldings are active--           , occ_rule_act   :: Activation -> Bool   -- Which rules are active-             -- See Note [Finding rule RHS free vars]--           , occ_binder_swap :: !Bool -- enable the binder_swap-             -- See CorePrep Note [Dead code in CorePrep]-    }--type GlobalScruts = IdSet   -- See Note [Binder swap on GlobalId scrutinees]---------------------------------- OccEncl is used to control whether to inline into constructor arguments--- For example:---      x = (p,q)               -- Don't inline p or q---      y = /\a -> (p a, q a)   -- Still don't inline p or q---      z = f (p,q)             -- Do inline p,q; it may make a rule fire--- So OccEncl tells enough about the context to know what to do when--- we encounter a constructor application or PAP.--data OccEncl-  = OccRhs              -- RHS of let(rec), albeit perhaps inside a type lambda-                        -- Don't inline into constructor args here-  | OccVanilla          -- Argument of function, body of lambda, scruintee of case etc.-                        -- Do inline into constructor args here--instance Outputable OccEncl where-  ppr OccRhs     = text "occRhs"-  ppr OccVanilla = text "occVanilla"---- See note [OneShots]-type OneShots = [OneShotInfo]--initOccEnv :: OccEnv-initOccEnv-  = OccEnv { occ_encl      = OccVanilla-           , occ_one_shots = []-           , occ_gbl_scrut = emptyVarSet-                 -- To be conservative, we say that all-                 -- inlines and rules are active-           , occ_unf_act   = \_ -> True-           , occ_rule_act  = \_ -> True-           , occ_binder_swap = True }--vanillaCtxt :: OccEnv -> OccEnv-vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] }--rhsCtxt :: OccEnv -> OccEnv-rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] }--argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])-argCtxt env []-  = (env { occ_encl = OccVanilla, occ_one_shots = [] }, [])-argCtxt env (one_shots:one_shots_s)-  = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s)--isRhsEnv :: OccEnv -> Bool-isRhsEnv (OccEnv { occ_encl = OccRhs })     = True-isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False--oneShotGroup :: OccEnv -> [CoreBndr]-             -> ( OccEnv-                , [CoreBndr] )-        -- The result binders have one-shot-ness set that they might not have had originally.-        -- This happens in (build (\c n -> e)).  Here the occurrence analyser-        -- linearity context knows that c,n are one-shot, and it records that fact in-        -- the binder. This is useful to guide subsequent float-in/float-out transformations--oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs-  = go ctxt bndrs []-  where-    go ctxt [] rev_bndrs-      = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla }-        , reverse rev_bndrs )--    go [] bndrs rev_bndrs-      = ( env { occ_one_shots = [], occ_encl = OccVanilla }-        , reverse rev_bndrs ++ bndrs )--    go ctxt@(one_shot : ctxt') (bndr : bndrs) rev_bndrs-      | isId bndr = go ctxt' bndrs (bndr': rev_bndrs)-      | otherwise = go ctxt  bndrs (bndr : rev_bndrs)-      where-        bndr' = updOneShotInfo bndr one_shot-               -- Use updOneShotInfo, not setOneShotInfo, as pre-existing-               -- one-shot info might be better than what we can infer, e.g.-               -- due to explicit use of the magic 'oneShot' function.-               -- See Note [The oneShot function]---markJoinOneShots :: Maybe JoinArity -> [Var] -> [Var]--- Mark the lambdas of a non-recursive join point as one-shot.--- This is good to prevent gratuitous float-out etc-markJoinOneShots mb_join_arity bndrs-  = case mb_join_arity of-      Nothing -> bndrs-      Just n  -> go n bndrs- where-   go 0 bndrs  = bndrs-   go _ []     = [] -- This can legitimately happen.-                    -- e.g.    let j = case ... in j True-                    -- This will become an arity-1 join point after the-                    -- simplifier has eta-expanded it; but it may not have-                    -- enough lambdas /yet/. (Lint checks that JoinIds do-                    -- have enough lambdas.)-   go n (b:bs) = b' : go (n-1) bs-     where-       b' | isId b    = setOneShotLambda b-          | otherwise = b--addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv-addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args-  = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt }--transClosureFV :: UniqFM VarSet -> UniqFM VarSet--- If (f,g), (g,h) are in the input, then (f,h) is in the output---                                   as well as (f,g), (g,h)-transClosureFV env-  | no_change = env-  | otherwise = transClosureFV (listToUFM new_fv_list)-  where-    (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env)-      -- It's OK to use nonDetUFMToList here because we'll forget the-      -- ordering by creating a new set with listToUFM-    bump no_change (b,fvs)-      | no_change_here = (no_change, (b,fvs))-      | otherwise      = (False,     (b,new_fvs))-      where-        (new_fvs, no_change_here) = extendFvs env fvs----------------extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet-extendFvs_ env s = fst (extendFvs env s)   -- Discard the Bool flag--extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool)--- (extendFVs env s) returns---     (s `union` env(s), env(s) `subset` s)-extendFvs env s-  | isNullUFM env-  = (s, True)-  | otherwise-  = (s `unionVarSet` extras, extras `subVarSet` s)-  where-    extras :: VarSet    -- env(s)-    extras = nonDetFoldUFM unionVarSet emptyVarSet $-      -- It's OK to use nonDetFoldUFM here because unionVarSet commutes-             intersectUFM_C (\x _ -> x) env (getUniqSet s)--{--************************************************************************-*                                                                      *-                    Binder swap-*                                                                      *-************************************************************************--Note [Binder swap]-~~~~~~~~~~~~~~~~~~-The "binder swap" transformation swaps occurrence of the-scrutinee of a case for occurrences of the case-binder:-- (1)  case x of b { pi -> ri }-         ==>-      case x of b { pi -> let x=b in ri }-- (2)  case (x |> co) of b { pi -> ri }-        ==>-      case (x |> co) of b { pi -> let x = b |> sym co in ri }--In both cases, the trivial 'let' can be eliminated by the-immediately following simplifier pass.--There are two reasons for making this swap:--(A) It reduces the number of occurrences of the scrutinee, x.-    That in turn might reduce its occurrences to one, so we-    can inline it and save an allocation.  E.g.-      let x = factorial y in case x of b { I# v -> ...x... }-    If we replace 'x' by 'b' in the alternative we get-      let x = factorial y in case x of b { I# v -> ...b... }-    and now we can inline 'x', thus-      case (factorial y) of b { I# v -> ...b... }--(B) The case-binder b has unfolding information; in the-    example above we know that b = I# v. That in turn allows-    nested cases to simplify.  Consider-       case x of b { I# v ->-       ...(case x of b2 { I# v2 -> rhs })...-    If we replace 'x' by 'b' in the alternative we get-       case x of b { I# v ->-       ...(case b of b2 { I# v2 -> rhs })...-    and now it is trivial to simplify the inner case:-       case x of b { I# v ->-       ...(let b2 = b in rhs)...--    The same can happen even if the scrutinee is a variable-    with a cast: see Note [Case of cast]--In both cases, in a particular alternative (pi -> ri), we only-add the binding if-  (a) x occurs free in (pi -> ri)-        (ie it occurs in ri, but is not bound in pi)-  (b) the pi does not bind b (or the free vars of co)-We need (a) and (b) for the inserted binding to be correct.--For the alternatives where we inject the binding, we can transfer-all x's OccInfo to b.  And that is the point.--Notice that-  * The deliberate shadowing of 'x'.-  * That (a) rapidly becomes false, so no bindings are injected.--The reason for doing these transformations /here in the occurrence-analyser/ is because it allows us to adjust the OccInfo for 'x' and-'b' as we go.--  * Suppose the only occurrences of 'x' are the scrutinee and in the-    ri; then this transformation makes it occur just once, and hence-    get inlined right away.--  * If instead we do this in the Simplifier, we don't know whether 'x'-    is used in ri, so we are forced to pessimistically zap b's OccInfo-    even though it is typically dead (ie neither it nor x appear in-    the ri).  There's nothing actually wrong with zapping it, except-    that it's kind of nice to know which variables are dead.  My nose-    tells me to keep this information as robustly as possible.--The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding-{x=b}; it's Nothing if the binder-swap doesn't happen.--There is a danger though.  Consider-      let v = x +# y-      in case (f v) of w -> ...v...v...-And suppose that (f v) expands to just v.  Then we'd like to-use 'w' instead of 'v' in the alternative.  But it may be too-late; we may have substituted the (cheap) x+#y for v in the-same simplifier pass that reduced (f v) to v.--I think this is just too bad.  CSE will recover some of it.--Note [Case of cast]-~~~~~~~~~~~~~~~~~~~-Consider        case (x `cast` co) of b { I# ->-                ... (case (x `cast` co) of {...}) ...-We'd like to eliminate the inner case.  That is the motivation for-equation (2) in Note [Binder swap].  When we get to the inner case, we-inline x, cancel the casts, and away we go.--Note [Binder swap on GlobalId scrutinees]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When the scrutinee is a GlobalId we must take care in two ways-- i) In order to *know* whether 'x' occurs free in the RHS, we need its-    occurrence info. BUT, we don't gather occurrence info for-    GlobalIds.  That's the reason for the (small) occ_gbl_scrut env in-    OccEnv is for: it says "gather occurrence info for these".-- ii) We must call localiseId on 'x' first, in case it's a GlobalId, or-     has an External Name. See, for example, SimplEnv Note [Global Ids in-     the substitution].--Note [Zap case binders in proxy bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-From the original-     case x of cb(dead) { p -> ...x... }-we will get-     case x of cb(live) { p -> let x = cb in ...x... }--Core Lint never expects to find an *occurrence* of an Id marked-as Dead, so we must zap the OccInfo on cb before making the-binding x = cb.  See #5028.--NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier-doesn't use it. So this is only to satisfy the perhaps-over-picky Lint.--Historical note [no-case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We *used* to suppress the binder-swap in case expressions when--fno-case-of-case is on.  Old remarks:-    "This happens in the first simplifier pass,-    and enhances full laziness.  Here's the bad case:-            f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )-    If we eliminate the inner case, we trap it inside the I# v -> arm,-    which might prevent some full laziness happening.  I've seen this-    in action in spectral/cichelli/Prog.hs:-             [(m,n) | m <- [1..max], n <- [1..max]]-    Hence the check for NoCaseOfCase."-However, now the full-laziness pass itself reverses the binder-swap, so this-check is no longer necessary.--Historical note [Suppressing the case binder-swap]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This old note describes a problem that is also fixed by doing the-binder-swap in OccAnal:--    There is another situation when it might make sense to suppress the-    case-expression binde-swap. If we have--        case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }-                       ...other cases .... }--    We'll perform the binder-swap for the outer case, giving--        case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }-                       ...other cases .... }--    But there is no point in doing it for the inner case, because w1 can't-    be inlined anyway.  Furthermore, doing the case-swapping involves-    zapping w2's occurrence info (see paragraphs that follow), and that-    forces us to bind w2 when doing case merging.  So we get--        case x of w1 { A -> let w2 = w1 in e1-                       B -> let w2 = w1 in e2-                       ...other cases .... }--    This is plain silly in the common case where w2 is dead.--    Even so, I can't see a good way to implement this idea.  I tried-    not doing the binder-swap if the scrutinee was already evaluated-    but that failed big-time:--            data T = MkT !Int--            case v of w  { MkT x ->-            case x of x1 { I# y1 ->-            case x of x2 { I# y2 -> ...--    Notice that because MkT is strict, x is marked "evaluated".  But to-    eliminate the last case, we must either make sure that x (as well as-    x1) has unfolding MkT y1.  The straightforward thing to do is to do-    the binder-swap.  So this whole note is a no-op.--It's fixed by doing the binder-swap in OccAnal because we can do the-binder-swap unconditionally and still get occurrence analysis-information right.--}--mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr))--- Does three things: a) makes the occ_one_shots = OccVanilla---                    b) extends the GlobalScruts if possible---                    c) returns a proxy mapping, binding the scrutinee---                       to the case binder, if possible-mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr-  = case stripTicksTopE (const True) scrut of-      Var v           -> add_scrut v case_bndr'-      Cast (Var v) co -> add_scrut v (Cast case_bndr' (mkSymCo co))-                          -- See Note [Case of cast]-      _               -> (env { occ_encl = OccVanilla }, Nothing)--  where-    add_scrut v rhs-      | isGlobalId v = (env { occ_encl = OccVanilla }, Nothing)-      | otherwise    = ( env { occ_encl = OccVanilla-                             , occ_gbl_scrut = pe `extendVarSet` v }-                       , Just (localise v, rhs) )-      -- ToDO: this isGlobalId stuff is a TEMPORARY FIX-      --       to avoid the binder-swap for GlobalIds-      --       See #16346--    case_bndr' = Var (zapIdOccInfo case_bndr)-                   -- See Note [Zap case binders in proxy bindings]--    -- Localise the scrut_var before shadowing it; we're making a-    -- new binding for it, and it might have an External Name, or-    -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]-    -- Also we don't want any INLINE or NOINLINE pragmas!-    localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var))-                                          (idType scrut_var)--{--************************************************************************-*                                                                      *-\subsection[OccurAnal-types]{OccEnv}-*                                                                      *-************************************************************************--Note [UsageDetails and zapping]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--On many occasions, we must modify all gathered occurrence data at once. For-instance, all occurrences underneath a (non-one-shot) lambda set the-'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but-that takes O(n) time and we will do this often---in particular, there are many-places where tail calls are not allowed, and each of these causes all variables-to get marked with 'NoTailCallInfo'.--Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along-with the 'OccInfoEnv'. Each of these extra environments is a "zapped set"-recording which variables have been zapped in some way. Zapping all occurrence-info then simply means setting the corresponding zapped set to the whole-'OccInfoEnv', a fast O(1) operation.--}--type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage-                -- INVARIANT: never IAmDead-                -- (Deadness is signalled by not being in the map at all)--type ZappedSet = OccInfoEnv -- Values are ignored--data UsageDetails-  = UD { ud_env       :: !OccInfoEnv-       , ud_z_many    :: ZappedSet   -- apply 'markMany' to these-       , ud_z_in_lam  :: ZappedSet   -- apply 'markInsideLam' to these-       , ud_z_no_tail :: ZappedSet } -- apply 'markNonTailCalled' to these-  -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv--instance Outputable UsageDetails where-  ppr ud = ppr (ud_env (flattenUsageDetails ud))------------------------ UsageDetails API--andUDs, orUDs-        :: UsageDetails -> UsageDetails -> UsageDetails-andUDs = combineUsageDetailsWith addOccInfo-orUDs  = combineUsageDetailsWith orOccInfo--andUDsList :: [UsageDetails] -> UsageDetails-andUDsList = foldl' andUDs emptyDetails--mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails-mkOneOcc env id int_cxt arity-  | isLocalId id-  = singleton $ OneOcc { occ_in_lam  = NotInsideLam-                       , occ_one_br  = InOneBranch-                       , occ_int_cxt = int_cxt-                       , occ_tail    = AlwaysTailCalled arity }-  | id `elemVarSet` occ_gbl_scrut env-  = singleton noOccInfo--  | otherwise-  = emptyDetails-  where-    singleton info = emptyDetails { ud_env = unitVarEnv id info }--addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails-addOneOcc ud id info-  = ud { ud_env = extendVarEnv_C plus_zapped (ud_env ud) id info }-      `alterZappedSets` (`delVarEnv` id)-  where-    plus_zapped old new = doZapping ud id old `addOccInfo` new--addManyOccsSet :: UsageDetails -> VarSet -> UsageDetails-addManyOccsSet usage id_set = nonDetFoldUniqSet addManyOccs usage id_set-  -- It's OK to use nonDetFoldUFM here because addManyOccs commutes---- Add several occurrences, assumed not to be tail calls-addManyOccs :: Var -> UsageDetails -> UsageDetails-addManyOccs v u | isId v    = addOneOcc u v noOccInfo-                | otherwise = u-        -- Give a non-committal binder info (i.e noOccInfo) because-        --   a) Many copies of the specialised thing can appear-        --   b) We don't want to substitute a BIG expression inside a RULE-        --      even if that's the only occurrence of the thing-        --      (Same goes for INLINE.)--delDetails :: UsageDetails -> Id -> UsageDetails-delDetails ud bndr-  = ud `alterUsageDetails` (`delVarEnv` bndr)--delDetailsList :: UsageDetails -> [Id] -> UsageDetails-delDetailsList ud bndrs-  = ud `alterUsageDetails` (`delVarEnvList` bndrs)--emptyDetails :: UsageDetails-emptyDetails = UD { ud_env       = emptyVarEnv-                  , ud_z_many    = emptyVarEnv-                  , ud_z_in_lam  = emptyVarEnv-                  , ud_z_no_tail = emptyVarEnv }--isEmptyDetails :: UsageDetails -> Bool-isEmptyDetails = isEmptyVarEnv . ud_env--markAllMany, markAllInsideLam, markAllNonTailCalled, zapDetails-  :: UsageDetails -> UsageDetails-markAllMany          ud = ud { ud_z_many    = ud_env ud }-markAllInsideLam     ud = ud { ud_z_in_lam  = ud_env ud }-markAllNonTailCalled ud = ud { ud_z_no_tail = ud_env ud }--zapDetails = markAllMany . markAllNonTailCalled -- effectively sets to noOccInfo--lookupDetails :: UsageDetails -> Id -> OccInfo-lookupDetails ud id-  | isCoVar id  -- We do not currently gather occurrence info (from types)-  = noOccInfo   -- for CoVars, so we must conservatively mark them as used-                -- See Note [DoO not mark CoVars as dead]-  | otherwise-  = case lookupVarEnv (ud_env ud) id of-      Just occ -> doZapping ud id occ-      Nothing  -> IAmDead--usedIn :: Id -> UsageDetails -> Bool-v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud--udFreeVars :: VarSet -> UsageDetails -> VarSet--- Find the subset of bndrs that are mentioned in uds-udFreeVars bndrs ud = restrictUniqSetToUFM bndrs (ud_env ud)--{- Note [Do not mark CoVars as dead]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's obviously wrong to mark CoVars as dead if they are used.-Currently we don't traverse types to gather usase info for CoVars,-so we had better treat them as having noOccInfo.--This showed up in #15696 we had something like-  case eq_sel d of co -> ...(typeError @(...co...) "urk")...--Then 'd' was substituted by a dictionary, so the expression-simpified to-  case (Coercion <blah>) of co -> ...(typeError @(...co...) "urk")...--But then the "drop the case altogether" equation of rebuildCase-thought that 'co' was dead, and discarded the entire case. Urk!--I have no idea how we managed to avoid this pitfall for so long!--}------------------------ Auxiliary functions for UsageDetails implementation--combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo)-                        -> UsageDetails -> UsageDetails -> UsageDetails-combineUsageDetailsWith plus_occ_info ud1 ud2-  | isEmptyDetails ud1 = ud2-  | isEmptyDetails ud2 = ud1-  | otherwise-  = UD { ud_env       = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2)-       , ud_z_many    = plusVarEnv (ud_z_many    ud1) (ud_z_many    ud2)-       , ud_z_in_lam  = plusVarEnv (ud_z_in_lam  ud1) (ud_z_in_lam  ud2)-       , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) }--doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo-doZapping ud var occ-  = doZappingByUnique ud (varUnique var) occ--doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo-doZappingByUnique ud uniq-  = (if | in_subset ud_z_many    -> markMany-        | in_subset ud_z_in_lam  -> markInsideLam-        | otherwise              -> id) .-    (if | in_subset ud_z_no_tail -> markNonTailCalled-        | otherwise              -> id)-  where-    in_subset field = uniq `elemVarEnvByKey` field ud--alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails-alterZappedSets ud f-  = ud { ud_z_many    = f (ud_z_many    ud)-       , ud_z_in_lam  = f (ud_z_in_lam  ud)-       , ud_z_no_tail = f (ud_z_no_tail ud) }--alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails-alterUsageDetails ud f-  = ud { ud_env = f (ud_env ud) }-      `alterZappedSets` f--flattenUsageDetails :: UsageDetails -> UsageDetails-flattenUsageDetails ud-  = ud { ud_env = mapUFM_Directly (doZappingByUnique ud) (ud_env ud) }-      `alterZappedSets` const emptyVarEnv------------------------ See Note [Adjusting right-hand sides]-adjustRhsUsage :: Maybe JoinArity -> RecFlag-               -> [CoreBndr] -- Outer lambdas, AFTER occ anal-               -> UsageDetails -> UsageDetails-adjustRhsUsage mb_join_arity rec_flag bndrs usage-  = maybe_mark_lam (maybe_drop_tails usage)-  where-    maybe_mark_lam ud   | one_shot   = ud-                        | otherwise  = markAllInsideLam ud-    maybe_drop_tails ud | exact_join = ud-                        | otherwise  = markAllNonTailCalled ud--    one_shot = case mb_join_arity of-                 Just join_arity-                   | isRec rec_flag -> False-                   | otherwise      -> all isOneShotBndr (drop join_arity bndrs)-                 Nothing            -> all isOneShotBndr bndrs--    exact_join = case mb_join_arity of-                   Just join_arity -> bndrs `lengthIs` join_arity-                   _               -> False--type IdWithOccInfo = Id--tagLamBinders :: UsageDetails          -- Of scope-              -> [Id]                  -- Binders-              -> (UsageDetails,        -- Details with binders removed-                 [IdWithOccInfo])    -- Tagged binders-tagLamBinders usage binders-  = usage' `seq` (usage', bndrs')-  where-    (usage', bndrs') = mapAccumR tagLamBinder usage binders--tagLamBinder :: UsageDetails       -- Of scope-             -> Id                 -- Binder-             -> (UsageDetails,     -- Details with binder removed-                 IdWithOccInfo)    -- Tagged binders--- Used for lambda and case binders--- It copes with the fact that lambda bindings can have a--- stable unfolding, used for join points-tagLamBinder usage bndr-  = (usage2, bndr')-  where-        occ    = lookupDetails usage bndr-        bndr'  = setBinderOcc (markNonTailCalled occ) bndr-                   -- Don't try to make an argument into a join point-        usage1 = usage `delDetails` bndr-        usage2 | isId bndr = addManyOccsSet usage1 (idUnfoldingVars bndr)-                               -- This is effectively the RHS of a-                               -- non-join-point binding, so it's okay to use-                               -- addManyOccsSet, which assumes no tail calls-               | otherwise = usage1--tagNonRecBinder :: TopLevelFlag           -- At top level?-                -> UsageDetails           -- Of scope-                -> CoreBndr               -- Binder-                -> (UsageDetails,         -- Details with binder removed-                    IdWithOccInfo)        -- Tagged binder--tagNonRecBinder lvl usage binder- = let-     occ     = lookupDetails usage binder-     will_be_join = decideJoinPointHood lvl usage [binder]-     occ'    | will_be_join = -- must already be marked AlwaysTailCalled-                              ASSERT(isAlwaysTailCalled occ) occ-             | otherwise    = markNonTailCalled occ-     binder' = setBinderOcc occ' binder-     usage'  = usage `delDetails` binder-   in-   usage' `seq` (usage', binder')--tagRecBinders :: TopLevelFlag           -- At top level?-              -> UsageDetails           -- Of body of let ONLY-              -> [(CoreBndr,            -- Binder-                   UsageDetails,        -- RHS usage details-                   [CoreBndr])]         -- Lambdas in new RHS-              -> (UsageDetails,         -- Adjusted details for whole scope,-                                        -- with binders removed-                  [IdWithOccInfo])      -- Tagged binders--- Substantially more complicated than non-recursive case. Need to adjust RHS--- details *before* tagging binders (because the tags depend on the RHSes).-tagRecBinders lvl body_uds triples- = let-     (bndrs, rhs_udss, _) = unzip3 triples--     -- 1. Determine join-point-hood of whole group, as determined by-     --    the *unadjusted* usage details-     unadj_uds     = foldr andUDs body_uds rhs_udss-     will_be_joins = decideJoinPointHood lvl unadj_uds bndrs--     -- 2. Adjust usage details of each RHS, taking into account the-     --    join-point-hood decision-     rhs_udss' = map adjust triples-     adjust (bndr, rhs_uds, rhs_bndrs)-       = adjustRhsUsage mb_join_arity Recursive rhs_bndrs rhs_uds-       where-         -- Can't use willBeJoinId_maybe here because we haven't tagged the-         -- binder yet (the tag depends on these adjustments!)-         mb_join_arity-           | will_be_joins-           , let occ = lookupDetails unadj_uds bndr-           , AlwaysTailCalled arity <- tailCallInfo occ-           = Just arity-           | otherwise-           = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if-             Nothing                   -- we are making join points!--     -- 3. Compute final usage details from adjusted RHS details-     adj_uds   = foldr andUDs body_uds rhs_udss'--     -- 4. Tag each binder with its adjusted details-     bndrs'    = [ setBinderOcc (lookupDetails adj_uds bndr) bndr-                 | bndr <- bndrs ]--     -- 5. Drop the binders from the adjusted details and return-     usage'    = adj_uds `delDetailsList` bndrs-   in-   (usage', bndrs')--setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr-setBinderOcc occ_info bndr-  | isTyVar bndr      = bndr-  | isExportedId bndr = if isManyOccs (idOccInfo bndr)-                          then bndr-                          else setIdOccInfo bndr noOccInfo-            -- Don't use local usage info for visible-elsewhere things-            -- BUT *do* erase any IAmALoopBreaker annotation, because we're-            -- about to re-generate it and it shouldn't be "sticky"--  | otherwise = setIdOccInfo bndr occ_info---- | Decide whether some bindings should be made into join points or not.--- Returns `False` if they can't be join points. Note that it's an--- all-or-nothing decision, as if multiple binders are given, they're--- assumed to be mutually recursive.------ It must, however, be a final decision. If we say "True" for 'f',--- and then subsequently decide /not/ make 'f' into a join point, then--- the decision about another binding 'g' might be invalidated if (say)--- 'f' tail-calls 'g'.------ See Note [Invariants on join points] in GHC.Core.-decideJoinPointHood :: TopLevelFlag -> UsageDetails-                    -> [CoreBndr]-                    -> Bool-decideJoinPointHood TopLevel _ _-  = False-decideJoinPointHood NotTopLevel usage bndrs-  | isJoinId (head bndrs)-  = WARN(not all_ok, text "OccurAnal failed to rediscover join point(s):" <+>-                       ppr bndrs)-    all_ok-  | otherwise-  = all_ok-  where-    -- See Note [Invariants on join points]; invariants cited by number below.-    -- Invariant 2 is always satisfiable by the simplifier by eta expansion.-    all_ok = -- Invariant 3: Either all are join points or none are-             all ok bndrs--    ok bndr-      | -- Invariant 1: Only tail calls, all same join arity-        AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr)--      , -- Invariant 1 as applied to LHSes of rules-        all (ok_rule arity) (idCoreRules bndr)--        -- Invariant 2a: stable unfoldings-        -- See Note [Join points and INLINE pragmas]-      , ok_unfolding arity (realIdUnfolding bndr)--        -- Invariant 4: Satisfies polymorphism rule-      , isValidJoinPointType arity (idType bndr)-      = True--      | otherwise-      = False--    ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans-    ok_rule join_arity (Rule { ru_args = args })-      = args `lengthIs` join_arity-        -- Invariant 1 as applied to LHSes of rules--    -- ok_unfolding returns False if we should /not/ convert a non-join-id-    -- into a join-id, even though it is AlwaysTailCalled-    ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs })-      = not (isStableSource src && join_arity > joinRhsArity rhs)-    ok_unfolding _ (DFunUnfolding {})-      = False-    ok_unfolding _ _-      = True--willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity-willBeJoinId_maybe bndr-  = case tailCallInfo (idOccInfo bndr) of-      AlwaysTailCalled arity -> Just arity-      _                      -> isJoinId_maybe bndr---{- Note [Join points and INLINE pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f x = let g = \x. not  -- Arity 1-             {-# INLINE g #-}-         in case x of-              A -> g True True-              B -> g True False-              C -> blah2--Here 'g' is always tail-called applied to 2 args, but the stable-unfolding captured by the INLINE pragma has arity 1.  If we try to-convert g to be a join point, its unfolding will still have arity 1-(since it is stable, and we don't meddle with stable unfoldings), and-Lint will complain (see Note [Invariants on join points], (2a), in-GHC.Core.  #13413.--Moreover, since g is going to be inlined anyway, there is no benefit-from making it a join point.--If it is recursive, and uselessly marked INLINE, this will stop us-making it a join point, which is annoying.  But occasionally-(notably in class methods; see Note [Instances and loop breakers] in-TcInstDcls) we mark recursive things as INLINE but the recursion-unravels; so ignoring INLINE pragmas on recursive things isn't good-either.--See Invariant 2a of Note [Invariants on join points] in GHC.Core---************************************************************************-*                                                                      *-\subsection{Operations over OccInfo}-*                                                                      *-************************************************************************--}--markMany, markInsideLam, markNonTailCalled :: OccInfo -> OccInfo--markMany IAmDead = IAmDead-markMany occ     = ManyOccs { occ_tail = occ_tail occ }--markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam }-markInsideLam occ             = occ--markNonTailCalled IAmDead = IAmDead-markNonTailCalled occ     = occ { occ_tail = NoTailCallInfo }--addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo--addOccInfo a1 a2  = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )-                    ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`-                                          tailCallInfo a2 }-                                -- Both branches are at least One-                                -- (Argument is never IAmDead)---- (orOccInfo orig new) is used--- when combining occurrence info from branches of a case--orOccInfo (OneOcc { occ_in_lam = in_lam1, occ_int_cxt = int_cxt1-                  , occ_tail   = tail1 })-          (OneOcc { occ_in_lam = in_lam2, occ_int_cxt = int_cxt2-                  , occ_tail   = tail2 })-  = OneOcc { occ_one_br  = MultipleBranches -- because it occurs in both branches-           , occ_in_lam  = in_lam1 `mappend` in_lam2-           , occ_int_cxt = int_cxt1 `mappend` int_cxt2-           , occ_tail    = tail1 `andTailCallInfo` tail2 }--orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )-                  ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`-                                        tailCallInfo a2 }--andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo-andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2)-  | arity1 == arity2 = info-andTailCallInfo _ _  = NoTailCallInfo
compiler/typecheck/Constraint.hs view
@@ -14,7 +14,7 @@         QCInst(..), isPendingScInst,          -- Canonical constraints-        Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts,+        Xi, Ct(..), Cts, CtIrredStatus(..), emptyCts, andCts, andManyCts, pprCts,         singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,         isEmptyCts, isCTyEqCan, isCFunEqCan,         isPendingScDict, superClassesMightHelp, getPendingWantedScs,@@ -25,7 +25,7 @@         ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,         ctEvId, mkTcEqPredLikeEv,         mkNonCanonical, mkNonCanonicalCt, mkGivens,-        mkIrredCt, mkInsolubleCt,+        mkIrredCt,         ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,         ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,         tyCoVarsOfCt, tyCoVarsOfCts,@@ -55,7 +55,7 @@         isWanted, isGiven, isDerived, isGivenOrWDeriv,         ctEvRole, -        wrapType, wrapTypeWithImplication,+        wrapType,          CtFlavour(..), ShadowInfo(..), ctEvFlavour,         CtFlavourRole, ctEvFlavourRole, ctFlavourRole,@@ -80,13 +80,12 @@ import {-# SOURCE #-} TcRnTypes ( TcLclEnv, setLclEnvTcLevel, getLclEnvTcLevel                                 , setLclEnvLoc, getLclEnvLoc ) -import Predicate-import Type-import Coercion-import Class-import TyCon-import Var-import Id+import GHC.Core.Predicate+import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Types.Var  import TcType import TcEvidence@@ -94,15 +93,15 @@  import GHC.Core -import TyCoPpr-import OccName+import GHC.Core.TyCo.Ppr+import GHC.Types.Name.Occurrence import FV-import VarSet+import GHC.Types.Var.Set import GHC.Driver.Session-import BasicTypes+import GHC.Types.Basic  import Outputable-import SrcLoc+import GHC.Types.SrcLoc import Bag import Util @@ -146,13 +145,12 @@     }    | CIrredCan {  -- These stand for yet-unusable predicates-      cc_ev    :: CtEvidence,   -- See Note [Ct/evidence invariant]-      cc_insol :: Bool   -- True  <=> definitely an error, can never be solved-                         -- False <=> might be soluble+      cc_ev     :: CtEvidence,   -- See Note [Ct/evidence invariant]+      cc_status :: CtIrredStatus          -- For the might-be-soluble case, the ctev_pred of the evidence is         -- of form   (tv xi1 xi2 ... xin)   with a tyvar at the head-        --      or   (tv1 ~ ty2)   where the CTyEqCan  kind invariant fails+        --      or   (tv1 ~ ty2)   where the CTyEqCan  kind invariant (TyEq:K) fails         --      or   (F tys ~ ty)  where the CFunEqCan kind invariant fails         -- See Note [CIrredCan constraints] @@ -164,19 +162,21 @@   | CTyEqCan {  -- tv ~ rhs        -- Invariants:        --   * See Note [inert_eqs: the inert equalities] in TcSMonad-       --   * tv not in tvs(rhs)   (occurs check)-       --   * If tv is a TauTv, then rhs has no foralls+       --   * (TyEq:OC) tv not in deep tvs(rhs)   (occurs check)+       --   * (TyEq:F) If tv is a TauTv, then rhs has no foralls        --       (this avoids substituting a forall for the tyvar in other types)-       --   * tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant]-       --   * rhs may have at most one top-level cast-       --   * rhs (perhaps under the one cast) is *almost function-free*,+       --   * (TyEq:K) tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant]+       --   * (TyEq:AFF) rhs (perhaps under the one cast) is *almost function-free*,        --       See Note [Almost function-free]-       --   * If the equality is representational, rhs has no top-level newtype+       --   * (TyEq:N) If the equality is representational, rhs has no top-level newtype        --     See Note [No top-level newtypes on RHS of representational        --     equalities] in TcCanonical-       --   * If rhs (perhaps under the cast) is also a tv, then it is oriented+       --   * (TyEq:TV) If rhs (perhaps under the cast) is also a tv, then it is oriented        --     to give best chance of        --     unification happening; eg if rhs is touchable then lhs is too+       --     See TcCanonical Note [Canonical orientation for tyvar/tyvar equality constraints]+       --   * (TyEq:H) The RHS has no blocking coercion holes. See TcCanonical+       --     Note [Equalities with incompatible kinds], wrinkle (2)       cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]       cc_tyvar  :: TcTyVar,       cc_rhs    :: TcType,     -- Not necessarily function-free (hence not Xi)@@ -242,6 +242,21 @@               | TypeHole                  -- ^ A hole in a type (PartialTypeSignatures) +------------+-- | Used to indicate extra information about why a CIrredCan is irreducible+data CtIrredStatus+  = InsolubleCIS   -- this constraint will never be solved+  | BlockedCIS     -- this constraint is blocked on a coercion hole+                   -- The hole will appear in the ctEvPred of the constraint with this status+                   -- See Note [Equalities with incompatible kinds] in TcCanonical+                   -- Wrinkle (4a)+  | OtherCIS++instance Outputable CtIrredStatus where+  ppr InsolubleCIS = text "(insoluble)"+  ppr BlockedCIS   = text "(blocked)"+  ppr OtherCIS     = text "(soluble)"+ {- Note [Hole constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~ CHoleCan constraints are used for two kinds of holes,@@ -297,7 +312,8 @@  * under a forall, or  * in a coercion (either in a CastTy or a CercionTy) -The RHS of a CTyEqCan must be almost function-free. This is for two reasons:+The RHS of a CTyEqCan must be almost function-free, invariant (TyEq:AFF).+This is for two reasons:  1. There cannot be a top-level function. If there were, the equality should    really be a CFunEqCan, not a CTyEqCan.@@ -347,11 +363,8 @@ mkNonCanonicalCt :: Ct -> Ct mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct } -mkIrredCt :: CtEvidence -> Ct-mkIrredCt ev = CIrredCan { cc_ev = ev, cc_insol = False }--mkInsolubleCt :: CtEvidence -> Ct-mkInsolubleCt ev = CIrredCan { cc_ev = ev, cc_insol = True }+mkIrredCt :: CtIrredStatus -> CtEvidence -> Ct+mkIrredCt status ev = CIrredCan { cc_ev = ev, cc_status = status }  mkGivens :: CtLoc -> [EvId] -> [Ct] mkGivens loc ev_ids@@ -410,9 +423,7 @@          CDictCan { cc_pend_sc = pend_sc }             | pend_sc   -> text "CDictCan(psc)"             | otherwise -> text "CDictCan"-         CIrredCan { cc_insol = insol }-            | insol     -> text "CIrredCan(insol)"-            | otherwise -> text "CIrredCan(sol)"+         CIrredCan { cc_status = status } -> text "CIrredCan" <> ppr status          CHoleCan { cc_occ = occ } -> text "CHoleCan:" <+> ppr occ          CQuantCan (QCI { qci_pend_sc = pend_sc })             | pend_sc   -> text "CQuantCan(psc)"@@ -440,14 +451,10 @@ -- | Returns free variables of constraints as a composable FV computation. -- See Note [Deterministic FV] in FV. tyCoFVsOfCt :: Ct -> FV-tyCoFVsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })-  = tyCoFVsOfType xi `unionFV` FV.unitFV tv-                     `unionFV` tyCoFVsOfType (tyVarKind tv)-tyCoFVsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk })-  = tyCoFVsOfTypes tys `unionFV` FV.unitFV fsk-                       `unionFV` tyCoFVsOfType (tyVarKind fsk)-tyCoFVsOfCt (CDictCan { cc_tyargs = tys }) = tyCoFVsOfTypes tys tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct)+  -- This must consult only the ctPred, so that it gets *tidied* fvs if the+  -- constraint has been tidied. Tidying a constraint does not tidy the+  -- fields of the Ct, only the predicate in the CtEvidence.  -- | Returns free variables of a bag of constraints as a non-deterministic -- set. See Note [Deterministic FV] in FV.@@ -550,18 +557,15 @@      keep_deriv       = case ct of-          CHoleCan {} -> True-          CIrredCan { cc_insol = insoluble }-                      -> keep_eq insoluble-          _           -> keep_eq False+          CHoleCan {}                            -> True+          CIrredCan { cc_status = InsolubleCIS } -> keep_eq True+          _                                      -> keep_eq False      keep_eq definitely_insoluble        | isGivenOrigin orig    -- Arising only from givens        = definitely_insoluble  -- Keep only definitely insoluble        | otherwise        = case orig of-           KindEqOrigin {} -> True    -- See Note [Dropping derived constraints]-            -- See Note [Dropping derived constraints]            -- For fundeps, drop wanted/wanted interactions            FunDepOrigin2 {} -> True   -- Top-level/Wanted@@ -611,12 +615,6 @@  * Type holes are derived constraints, because they have no evidence    and we want to keep them, so we get the error report - * Insoluble kind equalities (e.g. [D] * ~ (* -> *)), with-   KindEqOrigin, may arise from a type equality a ~ Int#, say.  See-   Note [Equalities with incompatible kinds] in TcCanonical.-   Keeping these around produces better error messages, in practice.-   E.g., test case dependent/should_fail/T11471-  * We keep most derived equalities arising from functional dependencies       - Given/Given interactions (subset of FunDepOrigin1):         The definitely-insoluble ones reflect unreachable code.@@ -665,7 +663,6 @@  isCTyEqCan :: Ct -> Bool isCTyEqCan (CTyEqCan {})  = True-isCTyEqCan (CFunEqCan {}) = False isCTyEqCan _              = False  isCDictCan_Maybe :: Ct -> Maybe Class@@ -991,8 +988,8 @@ --                   True for  Int ~ F a Int --               but False for  Maybe Int ~ F a Int Int --               (where F is an arity-1 type function)-insolubleEqCt (CIrredCan { cc_insol = insol }) = insol-insolubleEqCt _                                = False+insolubleEqCt (CIrredCan { cc_status = InsolubleCIS }) = True+insolubleEqCt _                                        = False  instance Outputable WantedConstraints where   ppr (WC {wc_simple = s, wc_impl = i})@@ -1292,17 +1289,6 @@   --- | Wraps the given type with the constraints (via ic_given) in the given--- implication, according to the variables mentioned (via ic_skols)--- in the implication, but taking care to only wrap those variables--- that are mentioned in the type or the implication.-wrapTypeWithImplication :: Type -> Implication -> Type-wrapTypeWithImplication ty impl = wrapType ty mentioned_skols givens-    where givens = map idType $ ic_given impl-          skols = ic_skols impl-          freeVars = fvVarSet $ tyCoFVsOfTypes (ty:givens)-          mentioned_skols = filter (`elemVarSet` freeVars) skols- wrapType :: Type -> [TyVar] -> [PredType] -> Type wrapType ty skols givens = mkSpecForAllTys skols $ mkPhiTy givens ty @@ -1356,7 +1342,7 @@    | HoleDest  CoercionHole  -- ^ fill in this hole with the evidence               -- HoleDest is always used for type-equalities-              -- See Note [Coercion holes] in TyCoRep+              -- See Note [Coercion holes] in GHC.Core.TyCo.Rep  data CtEvidence   = CtGiven    -- Truly given, not depending on subgoals
compiler/typecheck/TcEvidence.hs view
@@ -55,33 +55,33 @@  import GhcPrelude -import Var-import CoAxiom-import Coercion+import GHC.Types.Var+import GHC.Core.Coercion.Axiom+import GHC.Core.Coercion import GHC.Core.Ppr ()   -- Instance OutputableBndr TyVar import TcType-import Type-import TyCon-import DataCon( DataCon, dataConWrapId )-import Class( Class )+import GHC.Core.Type+import GHC.Core.TyCon+import GHC.Core.DataCon( DataCon, dataConWrapId )+import GHC.Core.Class( Class ) import PrelNames-import VarEnv-import VarSet-import Predicate-import Name+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Core.Predicate+import GHC.Types.Name import Pair  import GHC.Core-import Class ( classSCSelId )-import GHC.Core.FVs ( exprSomeFreeVars )+import GHC.Core.Class ( classSCSelId )+import GHC.Core.FVs   ( exprSomeFreeVars )  import Util import Bag import qualified Data.Data as Data import Outputable-import SrcLoc+import GHC.Types.SrcLoc import Data.IORef( IORef )-import UniqSet+import GHC.Types.Unique.Set  {- Note [TcCoercions]@@ -442,8 +442,7 @@ evidence bindings are allowed.  Notebly ():    - Places in types where we are solving kind constraints (all of which-    are equalities); see solveEqualities, solveLocalEqualities,-    checkTvConstraints+    are equalities); see solveEqualities, solveLocalEqualities    - When unifying forall-types -}@@ -473,7 +472,7 @@             -- let $dNum = GHC.Num.$fNumInt in             -- let $dEq = GHC.Classes.$fEqInt in ...             ---            -- See Note [Deterministic UniqFM] in UniqDFM for explanation why+            -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why             -- @UniqFM@ can lead to nondeterministic order.  emptyEvBindMap :: EvBindMap
compiler/typecheck/TcHoleFitTypes.hs view
@@ -11,13 +11,13 @@ import Constraint import TcType -import RdrName+import GHC.Types.Name.Reader  import GHC.Hs.Doc-import Id+import GHC.Types.Id  import Outputable-import Name+import GHC.Types.Name  import Data.Function ( on )
compiler/typecheck/TcOrigin.hs view
@@ -33,21 +33,21 @@  import GHC.Hs -import Id-import DataCon-import ConLike-import TyCon-import InstEnv-import PatSyn+import GHC.Types.Id+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Core.TyCon+import GHC.Core.InstEnv+import GHC.Core.PatSyn -import Module-import Name-import RdrName+import GHC.Types.Module+import GHC.Types.Name+import GHC.Types.Name.Reader -import SrcLoc+import GHC.Types.SrcLoc import FastString import Outputable-import BasicTypes+import GHC.Types.Basic  {- ********************************************************************* *                                                                      *@@ -363,7 +363,7 @@                        -- visible.) Only used for prioritizing error messages.                  } -  | KindEqOrigin  -- See Note [Equalities with incompatible kinds] in TcCanonical.+  | KindEqOrigin       TcType (Maybe TcType)     -- A kind equality arising from unifying these two types       CtOrigin                  -- originally arising from this       (Maybe TypeOrKind)        -- the level of the eq this arises from
compiler/typecheck/TcRnTypes.hs view
@@ -88,32 +88,32 @@ import GHC.Hs import GHC.Driver.Types import TcEvidence-import Type-import TyCon    ( TyCon, tyConKind )-import PatSyn   ( PatSyn )-import Id       ( idType, idName )-import FieldLabel ( FieldLabel )+import GHC.Core.Type+import GHC.Core.TyCon  ( TyCon, tyConKind )+import GHC.Core.PatSyn ( PatSyn )+import GHC.Types.Id         ( idType, idName )+import GHC.Types.FieldLabel ( FieldLabel ) import TcType import Constraint import TcOrigin-import Annotations-import InstEnv-import FamInstEnv+import GHC.Types.Annotations+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv import {-# SOURCE #-} GHC.HsToCore.PmCheck.Types (Deltas) import IOEnv-import RdrName-import Name-import NameEnv-import NameSet-import Avail-import Var-import VarEnv-import Module-import SrcLoc-import VarSet+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Avail+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Module+import GHC.Types.SrcLoc+import GHC.Types.Var.Set import ErrUtils-import UniqFM-import BasicTypes+import GHC.Types.Unique.FM+import GHC.Types.Basic import Bag import GHC.Driver.Session import Outputable@@ -121,10 +121,9 @@ import Fingerprint import Util import PrelNames ( isUnboundName )-import CostCentreState+import GHC.Types.CostCentre.State  import Control.Monad (ap)-import qualified Control.Monad.Fail as MonadFail import Data.Set      ( Set ) import qualified Data.Set as S @@ -384,7 +383,7 @@ -- --      - For any code involving Names, we want semantic modules. --        See lookupIfaceTop in GHC.Iface.Env, mkIface and addFingerprints---        in GHC.Iface.Utils, and tcLookupGlobal in TcEnv+--        in GHC.Iface.{Make,Recomp}, and tcLookupGlobal in TcEnv -- --      - When reading interfaces, we want the identity module to --        identify the specific interface we want (such interfaces@@ -664,7 +663,7 @@       Used (a) to report "defined but not used"                (see GHC.Rename.Names.reportUnusedNames)            (b) to generate version-tracking usage info in interface-               files (see GHC.Iface.Utils.mkUsedNames)+               files (see GHC.Iface.Make.mkUsedNames)    This usage info is mainly gathered by the renamer's    gathering of free-variables @@ -1653,14 +1652,11 @@   (<*>) = ap  instance Monad TcPluginM where-#if !MIN_VERSION_base(4,13,0)-  fail = MonadFail.fail-#endif   TcPluginM m >>= k =     TcPluginM (\ ev -> do a <- m ev                           runTcPluginM (k a) ev) -instance MonadFail.MonadFail TcPluginM where+instance MonadFail TcPluginM where   fail x   = TcPluginM (const $ fail x)  runTcPluginM :: TcPluginM a -> EvBindsVar -> TcM a
compiler/typecheck/TcRnTypes.hs-boot view
@@ -1,7 +1,7 @@ module TcRnTypes where  import TcType-import SrcLoc+import GHC.Types.SrcLoc  data TcLclEnv
compiler/typecheck/TcType.hs view
@@ -68,7 +68,7 @@   tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs,   tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe,   tcRepGetNumAppTys,-  tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, nextRole,+  tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar,   tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe,    ---------------------------------@@ -193,32 +193,32 @@ -- friends: import GhcPrelude -import TyCoRep-import TyCoSubst ( mkTvSubst, substTyWithCoVars )-import TyCoFVs-import TyCoPpr-import Class-import Var-import ForeignCall-import VarSet-import Coercion-import Type-import Predicate+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars )+import GHC.Core.TyCo.FVs+import GHC.Core.TyCo.Ppr+import GHC.Core.Class+import GHC.Types.Var+import GHC.Types.ForeignCall+import GHC.Types.Var.Set+import GHC.Core.Coercion+import GHC.Core.Type as Type+import GHC.Core.Predicate import GHC.Types.RepType-import TyCon+import GHC.Core.TyCon  -- others: import GHC.Driver.Session import GHC.Core.FVs-import Name -- hiding (varName)+import GHC.Types.Name as Name             -- We use this to make dictionaries for type literals.             -- Perhaps there's a better way to do this?-import NameSet-import VarEnv+import GHC.Types.Name.Set+import GHC.Types.Var.Env import PrelNames import TysWiredIn( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey                  , listTyCon, constraintKind )-import BasicTypes+import GHC.Types.Basic import Util import Maybes import ListSetOps ( getNth, findDupsEq )@@ -508,7 +508,7 @@                   --     how this level number is used        Bool       -- True <=> this skolem type variable can be overlapped                   --          when looking up instances-                  -- See Note [Binding when looking up instances] in InstEnv+                  -- See Note [Binding when looking up instances] in GHC.Core.InstEnv    | RuntimeUnk    -- Stands for an as-yet-unknown type in the GHCi                   -- interactive context@@ -518,7 +518,7 @@            , mtv_tclvl :: TcLevel }  -- See Note [TcLevel and untouchable type variables]  vanillaSkolemTv, superSkolemTv :: TcTyVarDetails--- See Note [Binding when looking up instances] in InstEnv+-- See Note [Binding when looking up instances] in GHC.Core.InstEnv vanillaSkolemTv = SkolemTv topTcLevel False  -- Might be instantiated superSkolemTv   = SkolemTv topTcLevel True   -- Treat this as a completely distinct type                   -- The choice of level number here is a bit dodgy, but@@ -853,6 +853,10 @@ anyRewritableTyVar ignore_cos role pred ty   = go role emptyVarSet ty   where+    -- NB: No need to expand synonyms, because we can find+    -- all free variables of a synonym by looking at its+    -- arguments+     go_tv rl bvs tv | tv `elemVarSet` bvs = False                     | otherwise           = pred rl tv @@ -860,7 +864,10 @@     go _ _     (LitTy {})        = False     go rl bvs (TyConApp tc tys)  = go_tc rl bvs tc tys     go rl bvs (AppTy fun arg)    = go rl bvs fun || go NomEq bvs arg-    go rl bvs (FunTy _ arg res)  = go rl bvs arg || go rl bvs res+    go rl bvs (FunTy _ arg res)  = go NomEq bvs arg_rep || go NomEq bvs res_rep ||+                                   go rl bvs arg || go rl bvs res+      where arg_rep = getRuntimeRep arg -- forgetting these causes #17024+            res_rep = getRuntimeRep res     go rl bvs (ForAllTy tv ty)   = go rl (bvs `extendVarSet` binderVar tv) ty     go rl bvs (CastTy ty co)     = go rl bvs ty || go_co rl bvs co     go rl bvs (CoercionTy co)    = go_co rl bvs co  -- ToDo: check@@ -914,7 +921,7 @@ which type variables are mentioned in a type.  It only matters occasionally -- see the calls to exactTyCoVarsOfType. -We place this function here in TcType, note in TyCoFVs,+We place this function here in TcType, not in GHC.Core.TyCo.FVs, because we want to "see" tcView (efficiency issue only). -} @@ -1487,7 +1494,7 @@  tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool -- tcEqType is a proper implements the same Note [Non-trivial definitional--- equality] (in TyCoRep) as `eqType`, but Type.eqType believes (* ==+-- equality] (in GHC.Core.TyCo.Rep) as `eqType`, but Type.eqType believes (* == -- Constraint), and that is NOT what we want in the type checker! tcEqType ty1 ty2   =  tc_eq_type False False ki1 ki2@@ -1549,7 +1556,7 @@     go env ty (FunTy _ arg res) = eqFunTy env arg res ty     go env (FunTy _ arg res) ty = eqFunTy env arg res ty -      -- See Note [Equality on AppTys] in Type+      -- See Note [Equality on AppTys] in GHC.Core.Type     go env (AppTy s1 t1)        ty2       | Just (s2, t2) <- tcRepSplitAppTy_maybe ty2       = go env s1 s2 && go env t1 t2@@ -1916,7 +1923,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We can't quantify over a constraint (t1 ~# t2) because that isn't a predicate type; see Note [Types for coercions, predicates, and evidence]-in TyCoRep.+in GHC.Core.TyCo.Rep.  So we have to 'lift' it to (t1 ~ t2).  Similarly (~R#) must be lifted to Coercible.
− compiler/types/Class.hs 
@@ -1,360 +0,0 @@--- (c) The University of Glasgow 2006--- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998------ The @Class@ datatype--{-# LANGUAGE CPP #-}--module Class (-        Class,-        ClassOpItem,-        ClassATItem(..),-        ClassMinimalDef,-        DefMethInfo, pprDefMethInfo,--        FunDep, pprFundeps, pprFunDep,--        mkClass, mkAbstractClass, classTyVars, classArity,-        classKey, className, classATs, classATItems, classTyCon, classMethods,-        classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,-        classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds,-        isAbstractClass,-    ) where--#include "HsVersions.h"--import GhcPrelude--import {-# SOURCE #-} TyCon     ( TyCon )-import {-# SOURCE #-} TyCoRep   ( Type, PredType )-import {-# SOURCE #-} TyCoPpr   ( pprType )-import Var-import Name-import BasicTypes-import Unique-import Util-import SrcLoc-import Outputable-import BooleanFormula (BooleanFormula, mkTrue)--import qualified Data.Data as Data--{--************************************************************************-*                                                                      *-\subsection[Class-basic]{@Class@: basic definition}-*                                                                      *-************************************************************************--A @Class@ corresponds to a Greek kappa in the static semantics:--}--data Class-  = Class {-        classTyCon :: TyCon,    -- The data type constructor for-                                -- dictionaries of this class-                                -- See Note [ATyCon for classes] in TyCoRep--        className :: Name,              -- Just the cached name of the TyCon-        classKey  :: Unique,            -- Cached unique of TyCon--        classTyVars  :: [TyVar],        -- The class kind and type variables;-                                        -- identical to those of the TyCon-           -- If you want visibility info, look at the classTyCon-           -- This field is redundant because it's duplicated in the-           -- classTyCon, but classTyVars is used quite often, so maybe-           -- it's a bit faster to cache it here--        classFunDeps :: [FunDep TyVar],  -- The functional dependencies--        classBody :: ClassBody -- Superclasses, ATs, methods--     }----  | e.g.------ >  class C a b c | a b -> c, a c -> b where...------  Here fun-deps are [([a,b],[c]), ([a,c],[b])]------  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'',---- For details on above see note [Api annotations] in ApiAnnotation-type FunDep a = ([a],[a])--type ClassOpItem = (Id, DefMethInfo)-        -- Selector function; contains unfolding-        -- Default-method info--type DefMethInfo = Maybe (Name, DefMethSpec Type)-   -- Nothing                    No default method-   -- Just ($dm, VanillaDM)      A polymorphic default method, name $dm-   -- Just ($gm, GenericDM ty)   A generic default method, name $gm, type ty-   --                              The generic dm type is *not* quantified-   --                              over the class variables; ie has the-   --                              class variables free--data ClassATItem-  = ATI TyCon         -- See Note [Associated type tyvar names]-        (Maybe (Type, SrcSpan))-                      -- Default associated type (if any) from this template-                      -- Note [Associated type defaults]--type ClassMinimalDef = BooleanFormula Name -- Required methods--data ClassBody-  = AbstractClass-  | ConcreteClass {-        -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)-        -- We need value-level selectors for both the dictionary-        -- superclasses and the equality superclasses-        cls_sc_theta :: [PredType],     -- Immediate superclasses,-        cls_sc_sel_ids :: [Id],          -- Selector functions to extract the-                                        --   superclasses from a-                                        --   dictionary of this class-        -- Associated types-        cls_ats :: [ClassATItem],  -- Associated type families--        -- Class operations (methods, not superclasses)-        cls_ops :: [ClassOpItem],  -- Ordered by tag--        -- Minimal complete definition-        cls_min_def :: ClassMinimalDef-    }-    -- TODO: maybe super classes should be allowed in abstract class definitions--classMinimalDef :: Class -> ClassMinimalDef-classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d-classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction--{--Note [Associated type defaults]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The following is an example of associated type defaults:-   class C a where-     data D a r--     type F x a b :: *-     type F p q r = (p,q)->r    -- Default--Note that-- * The TyCons for the associated types *share type variables* with the-   class, so that we can tell which argument positions should be-   instantiated in an instance decl.  (The first for 'D', the second-   for 'F'.)-- * We can have default definitions only for *type* families,-   not data families-- * In the default decl, the "patterns" should all be type variables,-   but (in the source language) they don't need to be the same as in-   the 'type' decl signature or the class.  It's more like a-   free-standing 'type instance' declaration.-- * HOWEVER, in the internal ClassATItem we rename the RHS to match the-   tyConTyVars of the family TyCon.  So in the example above we'd get-   a ClassATItem of-        ATI F ((x,a) -> b)-   So the tyConTyVars of the family TyCon bind the free vars of-   the default Type rhs--The @mkClass@ function fills in the indirect superclasses.--The SrcSpan is for the entire original declaration.--}--mkClass :: Name -> [TyVar]-        -> [FunDep TyVar]-        -> [PredType] -> [Id]-        -> [ClassATItem]-        -> [ClassOpItem]-        -> ClassMinimalDef-        -> TyCon-        -> Class--mkClass cls_name tyvars fds super_classes superdict_sels at_stuff-        op_stuff mindef tycon-  = Class { classKey     = nameUnique cls_name,-            className    = cls_name,-                -- NB:  tyConName tycon = cls_name,-                -- But it takes a module loop to assert it here-            classTyVars  = tyvars,-            classFunDeps = fds,-            classBody = ConcreteClass {-                    cls_sc_theta = super_classes,-                    cls_sc_sel_ids = superdict_sels,-                    cls_ats  = at_stuff,-                    cls_ops  = op_stuff,-                    cls_min_def = mindef-                },-            classTyCon   = tycon }--mkAbstractClass :: Name -> [TyVar]-        -> [FunDep TyVar]-        -> TyCon-        -> Class--mkAbstractClass cls_name tyvars fds tycon-  = Class { classKey     = nameUnique cls_name,-            className    = cls_name,-                -- NB:  tyConName tycon = cls_name,-                -- But it takes a module loop to assert it here-            classTyVars  = tyvars,-            classFunDeps = fds,-            classBody = AbstractClass,-            classTyCon   = tycon }--{--Note [Associated type tyvar names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The TyCon of an associated type should use the same variable names as its-parent class. Thus-    class C a b where-      type F b x a :: *-We make F use the same Name for 'a' as C does, and similarly 'b'.--The reason for this is when checking instances it's easier to match-them up, to ensure they match.  Eg-    instance C Int [d] where-      type F [d] x Int = ....-we should make sure that the first and third args match the instance-header.--Having the same variables for class and tycon is also used in checkValidRoles-(in TcTyClsDecls) when checking a class's roles.---************************************************************************-*                                                                      *-\subsection[Class-selectors]{@Class@: simple selectors}-*                                                                      *-************************************************************************--The rest of these functions are just simple selectors.--}--classArity :: Class -> Arity-classArity clas = length (classTyVars clas)-        -- Could memoise this--classAllSelIds :: Class -> [Id]--- Both superclass-dictionary and method selectors-classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }})-  = sc_sels ++ classMethods c-classAllSelIds c = ASSERT( null (classMethods c) ) []--classSCSelIds :: Class -> [Id]--- Both superclass-dictionary and method selectors-classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }})-  = sc_sels-classSCSelIds c = ASSERT( null (classMethods c) ) []--classSCSelId :: Class -> Int -> Id--- Get the n'th superclass selector Id--- where n is 0-indexed, and counts---    *all* superclasses including equalities-classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n-  = ASSERT( n >= 0 && lengthExceeds sc_sels n )-    sc_sels !! n-classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n)--classMethods :: Class -> [Id]-classMethods (Class { classBody = ConcreteClass { cls_ops = op_stuff } })-  = [op_sel | (op_sel, _) <- op_stuff]-classMethods _ = []--classOpItems :: Class -> [ClassOpItem]-classOpItems (Class { classBody = ConcreteClass { cls_ops = op_stuff }})-  = op_stuff-classOpItems _ = []--classATs :: Class -> [TyCon]-classATs (Class { classBody = ConcreteClass { cls_ats = at_stuff } })-  = [tc | ATI tc _ <- at_stuff]-classATs _ = []--classATItems :: Class -> [ClassATItem]-classATItems (Class { classBody = ConcreteClass { cls_ats = at_stuff }})-  = at_stuff-classATItems _ = []--classSCTheta :: Class -> [PredType]-classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }})-  = theta_stuff-classSCTheta _ = []--classTvsFds :: Class -> ([TyVar], [FunDep TyVar])-classTvsFds c = (classTyVars c, classFunDeps c)--classHasFds :: Class -> Bool-classHasFds (Class { classFunDeps = fds }) = not (null fds)--classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])-classBigSig (Class {classTyVars = tyvars,-                    classBody = AbstractClass})-  = (tyvars, [], [], [])-classBigSig (Class {classTyVars = tyvars,-                    classBody = ConcreteClass {-                        cls_sc_theta = sc_theta,-                        cls_sc_sel_ids = sc_sels,-                        cls_ops  = op_stuff-                    }})-  = (tyvars, sc_theta, sc_sels, op_stuff)--classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem])-classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,-                         classBody = AbstractClass})-  = (tyvars, fundeps, [], [], [], [])-classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,-                         classBody = ConcreteClass {-                             cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels,-                             cls_ats = ats, cls_ops = op_stuff-                         }})-  = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)--isAbstractClass :: Class -> Bool-isAbstractClass Class{ classBody = AbstractClass } = True-isAbstractClass _ = False--{--************************************************************************-*                                                                      *-\subsection[Class-instances]{Instance declarations for @Class@}-*                                                                      *-************************************************************************--We compare @Classes@ by their keys (which include @Uniques@).--}--instance Eq Class where-    c1 == c2 = classKey c1 == classKey c2-    c1 /= c2 = classKey c1 /= classKey c2--instance Uniquable Class where-    getUnique c = classKey c--instance NamedThing Class where-    getName clas = className clas--instance Outputable Class where-    ppr c = ppr (getName c)--pprDefMethInfo :: DefMethInfo -> SDoc-pprDefMethInfo Nothing                  = empty   -- No default method-pprDefMethInfo (Just (n, VanillaDM))    = text "Default method" <+> ppr n-pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method"-                                          <+> ppr n <+> dcolon <+> pprType ty--pprFundeps :: Outputable a => [FunDep a] -> SDoc-pprFundeps []  = empty-pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds))--pprFunDep :: Outputable a => FunDep a -> SDoc-pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs]--instance Data.Data Class where-    -- don't traverse?-    toConstr _   = abstractConstr "Class"-    gunfold _ _  = error "gunfold"-    dataTypeOf _ = mkNoRepType "Class"
− compiler/types/CoAxiom.hs 
@@ -1,573 +0,0 @@--- (c) The University of Glasgow 2012--{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures,-             ScopedTypeVariables, StandaloneDeriving, RoleAnnotations #-}---- | Module for coercion axioms, used to represent type family instances--- and newtypes--module CoAxiom (-       BranchFlag, Branched, Unbranched, BranchIndex, Branches(..),-       manyBranches, unbranched,-       fromBranches, numBranches,-       mapAccumBranches,--       CoAxiom(..), CoAxBranch(..),--       toBranchedAxiom, toUnbranchedAxiom,-       coAxiomName, coAxiomArity, coAxiomBranches,-       coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats,-       coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole,-       coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars,-       coAxBranchRoles,-       coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps,-       placeHolderIncomps,--       Role(..), fsFromRole,--       CoAxiomRule(..), TypeEqn,-       BuiltInSynFamily(..), trivialBuiltInFamily-       ) where--import GhcPrelude--import {-# SOURCE #-} TyCoRep ( Type )-import {-# SOURCE #-} TyCoPpr ( pprType )-import {-# SOURCE #-} TyCon ( TyCon )-import Outputable-import FastString-import Name-import Unique-import Var-import Util-import Binary-import Pair-import BasicTypes-import Data.Typeable ( Typeable )-import SrcLoc-import qualified Data.Data as Data-import Data.Array-import Data.List ( mapAccumL )--#include "HsVersions.h"--{--Note [Coercion axiom branches]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In order to allow closed type families, an axiom needs to contain an-ordered list of alternatives, called branches. The kind of the coercion built-from an axiom is determined by which index is used when building the coercion-from the axiom.--For example, consider the axiom derived from the following declaration:--type family F a where-  F [Int] = Bool-  F [a]   = Double-  F (a b) = Char--This will give rise to this axiom:--axF :: {                                         F [Int] ~ Bool-       ; forall (a :: *).                        F [a]   ~ Double-       ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char-       }--The axiom is used with the AxiomInstCo constructor of Coercion. If we wish-to have a coercion showing that F (Maybe Int) ~ Char, it will look like--axF[2] <*> <Maybe> <Int> :: F (Maybe Int) ~ Char--- or, written using concrete-ish syntax ---AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int]--Note that the index is 0-based.--For type-checking, it is also necessary to check that no previous pattern-can unify with the supplied arguments. After all, it is possible that some-of the type arguments are lambda-bound type variables whose instantiation may-cause an earlier match among the branches. We wish to prohibit this behavior,-so the type checker rules out the choice of a branch where a previous branch-can unify. See also [Apartness] in FamInstEnv.hs.--For example, the following is malformed, where 'a' is a lambda-bound type-variable:--axF[2] <*> <a> <Bool> :: F (a Bool) ~ Char--Why? Because a might be instantiated with [], meaning that branch 1 should-apply, not branch 2. This is a vital consistency check; without it, we could-derive Int ~ Bool, and that is a Bad Thing.--Note [Branched axioms]-~~~~~~~~~~~~~~~~~~~~~~-Although a CoAxiom has the capacity to store many branches, in certain cases,-we want only one. These cases are in data/newtype family instances, newtype-coercions, and type family instances.-Furthermore, these unbranched axioms are used in a-variety of places throughout GHC, and it would difficult to generalize all of-that code to deal with branched axioms, especially when the code can be sure-of the fact that an axiom is indeed a singleton. At the same time, it seems-dangerous to assume singlehood in various places through GHC.--The solution to this is to label a CoAxiom with a phantom type variable-declaring whether it is known to be a singleton or not. The branches-are stored using a special datatype, declared below, that ensures that the-type variable is accurate.--************************************************************************-*                                                                      *-                    Branches-*                                                                      *-************************************************************************--}--type BranchIndex = Int  -- The index of the branch in the list of branches-                        -- Counting from zero---- promoted data type-data BranchFlag = Branched | Unbranched-type Branched = 'Branched-type Unbranched = 'Unbranched--- By using type synonyms for the promoted constructors, we avoid needing--- DataKinds and the promotion quote in client modules. This also means that--- we don't need to export the term-level constructors, which should never be used.--newtype Branches (br :: BranchFlag)-  = MkBranches { unMkBranches :: Array BranchIndex CoAxBranch }-type role Branches nominal--manyBranches :: [CoAxBranch] -> Branches Branched-manyBranches brs = ASSERT( snd bnds >= fst bnds )-                   MkBranches (listArray bnds brs)-  where-    bnds = (0, length brs - 1)--unbranched :: CoAxBranch -> Branches Unbranched-unbranched br = MkBranches (listArray (0, 0) [br])--toBranched :: Branches br -> Branches Branched-toBranched = MkBranches . unMkBranches--toUnbranched :: Branches br -> Branches Unbranched-toUnbranched (MkBranches arr) = ASSERT( bounds arr == (0,0) )-                                MkBranches arr--fromBranches :: Branches br -> [CoAxBranch]-fromBranches = elems . unMkBranches--branchesNth :: Branches br -> BranchIndex -> CoAxBranch-branchesNth (MkBranches arr) n = arr ! n--numBranches :: Branches br -> Int-numBranches (MkBranches arr) = snd (bounds arr) + 1---- | The @[CoAxBranch]@ passed into the mapping function is a list of--- all previous branches, reversed-mapAccumBranches :: ([CoAxBranch] -> CoAxBranch -> CoAxBranch)-                  -> Branches br -> Branches br-mapAccumBranches f (MkBranches arr)-  = MkBranches (listArray (bounds arr) (snd $ mapAccumL go [] (elems arr)))-  where-    go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch)-    go prev_branches cur_branch = ( cur_branch : prev_branches-                                  , f prev_branches cur_branch )---{--************************************************************************-*                                                                      *-                    Coercion axioms-*                                                                      *-************************************************************************--Note [Storing compatibility]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-During axiom application, we need to be aware of which branches are compatible-with which others. The full explanation is in Note [Compatibility] in-FamInstEnv. (The code is placed there to avoid a dependency from CoAxiom on-the unification algorithm.) Although we could theoretically compute-compatibility on the fly, this is silly, so we store it in a CoAxiom.--Specifically, each branch refers to all other branches with which it is-incompatible. This list might well be empty, and it will always be for the-first branch of any axiom.--CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk-stored in cab_incomps. The incompatibilities are properly a property of the-axiom as a whole, and they are computed only when the final axiom is built.--During serialization, the list is converted into a list of the indices-of the branches.--}---- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom.---- If you edit this type, you may need to update the GHC formalism--- See Note [GHC Formalism] in GHC.Core.Lint-data CoAxiom br-  = CoAxiom                   -- Type equality axiom.-    { co_ax_unique   :: Unique        -- Unique identifier-    , co_ax_name     :: Name          -- Name for pretty-printing-    , co_ax_role     :: Role          -- Role of the axiom's equality-    , co_ax_tc       :: TyCon         -- The head of the LHS patterns-                                      -- e.g.  the newtype or family tycon-    , co_ax_branches :: Branches br   -- The branches that form this axiom-    , co_ax_implicit :: Bool          -- True <=> the axiom is "implicit"-                                      -- See Note [Implicit axioms]-         -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1.-    }--data CoAxBranch-  = CoAxBranch-    { cab_loc      :: SrcSpan       -- Location of the defining equation-                                    -- See Note [CoAxiom locations]-    , cab_tvs      :: [TyVar]       -- Bound type variables; not necessarily fresh-    , cab_eta_tvs  :: [TyVar]       -- Eta-reduced tyvars-                                    -- See Note [CoAxBranch type variables]-                                    -- cab_tvs and cab_lhs may be eta-reduded; see-                                    -- Note [Eta reduction for data families]-    , cab_cvs      :: [CoVar]       -- Bound coercion variables-                                    -- Always empty, for now.-                                    -- See Note [Constraints in patterns]-                                    -- in TcTyClsDecls-    , cab_roles    :: [Role]        -- See Note [CoAxBranch roles]-    , cab_lhs      :: [Type]        -- Type patterns to match against-    , cab_rhs      :: Type          -- Right-hand side of the equality-    , cab_incomps  :: [CoAxBranch]  -- The previous incompatible branches-                                    -- See Note [Storing compatibility]-    }-  deriving Data.Data--toBranchedAxiom :: CoAxiom br -> CoAxiom Branched-toBranchedAxiom (CoAxiom unique name role tc branches implicit)-  = CoAxiom unique name role tc (toBranched branches) implicit--toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched-toUnbranchedAxiom (CoAxiom unique name role tc branches implicit)-  = CoAxiom unique name role tc (toUnbranched branches) implicit--coAxiomNumPats :: CoAxiom br -> Int-coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0)--coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch-coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index-  = branchesNth bs index--coAxiomArity :: CoAxiom br -> BranchIndex -> Arity-coAxiomArity ax index-  = length tvs + length cvs-  where-    CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index--coAxiomName :: CoAxiom br -> Name-coAxiomName = co_ax_name--coAxiomRole :: CoAxiom br -> Role-coAxiomRole = co_ax_role--coAxiomBranches :: CoAxiom br -> Branches br-coAxiomBranches = co_ax_branches--coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch-coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr })-  | snd (bounds arr) == 0-  = Just $ arr ! 0-  | otherwise-  = Nothing--coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch-coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr })-  = arr ! 0--coAxiomTyCon :: CoAxiom br -> TyCon-coAxiomTyCon = co_ax_tc--coAxBranchTyVars :: CoAxBranch -> [TyVar]-coAxBranchTyVars = cab_tvs--coAxBranchCoVars :: CoAxBranch -> [CoVar]-coAxBranchCoVars = cab_cvs--coAxBranchLHS :: CoAxBranch -> [Type]-coAxBranchLHS = cab_lhs--coAxBranchRHS :: CoAxBranch -> Type-coAxBranchRHS = cab_rhs--coAxBranchRoles :: CoAxBranch -> [Role]-coAxBranchRoles = cab_roles--coAxBranchSpan :: CoAxBranch -> SrcSpan-coAxBranchSpan = cab_loc--isImplicitCoAxiom :: CoAxiom br -> Bool-isImplicitCoAxiom = co_ax_implicit--coAxBranchIncomps :: CoAxBranch -> [CoAxBranch]-coAxBranchIncomps = cab_incomps---- See Note [Compatibility checking] in FamInstEnv-placeHolderIncomps :: [CoAxBranch]-placeHolderIncomps = panic "placeHolderIncomps"--{--Note [CoAxBranch type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the case of a CoAxBranch of an associated type-family instance,-we use the *same* type variables (where possible) as the-enclosing class or instance.  Consider--  instance C Int [z] where-     type F Int [z] = ...   -- Second param must be [z]--In the CoAxBranch in the instance decl (F Int [z]) we use the-same 'z', so that it's easy to check that that type is the same-as that in the instance header.--So, unlike FamInsts, there is no expectation that the cab_tvs-are fresh wrt each other, or any other CoAxBranch.--Note [CoAxBranch roles]-~~~~~~~~~~~~~~~~~~~~~~~-Consider this code:--  newtype Age = MkAge Int-  newtype Wrap a = MkWrap a--  convert :: Wrap Age -> Int-  convert (MkWrap (MkAge i)) = i--We want this to compile to:--  NTCo:Wrap :: forall a. Wrap a ~R a-  NTCo:Age  :: Age ~R Int-  convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0])--But, note that NTCo:Age is at role R. Thus, we need to be able to pass-coercions at role R into axioms. However, we don't *always* want to be able to-do this, as it would be disastrous with type families. The solution is to-annotate the arguments to the axiom with roles, much like we annotate tycon-tyvars. Where do these roles get set? Newtype axioms inherit their roles from-the newtype tycon; family axioms are all at role N.--Note [CoAxiom locations]-~~~~~~~~~~~~~~~~~~~~~~~~-The source location of a CoAxiom is stored in two places in the-datatype tree.-  * The first is in the location info buried in the Name of the-    CoAxiom. This span includes all of the branches of a branched-    CoAxiom.-  * The second is in the cab_loc fields of the CoAxBranches.--In the case of a single branch, we can extract the source location of-the branch from the name of the CoAxiom. In other cases, we need an-explicit SrcSpan to correctly store the location of the equation-giving rise to the FamInstBranch.--Note [Implicit axioms]-~~~~~~~~~~~~~~~~~~~~~~-See also Note [Implicit TyThings] in GHC.Driver.Types-* A CoAxiom arising from data/type family instances is not "implicit".-  That is, it has its own IfaceAxiom declaration in an interface file--* The CoAxiom arising from a newtype declaration *is* "implicit".-  That is, it does not have its own IfaceAxiom declaration in an-  interface file; instead the CoAxiom is generated by type-checking-  the newtype declaration--Note [Eta reduction for data families]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this-   data family T a b :: *-   newtype instance T Int a = MkT (IO a) deriving( Monad )-We'd like this to work.--From the 'newtype instance' you might think we'd get:-   newtype TInt a = MkT (IO a)-   axiom ax1 a :: T Int a ~ TInt a   -- The newtype-instance part-   axiom ax2 a :: TInt a ~ IO a      -- The newtype part--But now what can we do?  We have this problem-   Given:   d  :: Monad IO-   Wanted:  d' :: Monad (T Int) = d |> ????-What coercion can we use for the ???--Solution: eta-reduce both axioms, thus:-   axiom ax1 :: T Int ~ TInt-   axiom ax2 :: TInt ~ IO-Now-   d' = d |> Monad (sym (ax2 ; ax1))------- Bottom line --------For a CoAxBranch for a data family instance with representation-TyCon rep_tc:--  - cab_tvs (of its CoAxiom) may be shorter-    than tyConTyVars of rep_tc.--  - cab_lhs may be shorter than tyConArity of the family tycon-       i.e. LHS is unsaturated--  - cab_rhs will be (rep_tc cab_tvs)-       i.e. RHS is un-saturated--  - This eta reduction happens for data instances as well-    as newtype instances. Here we want to eta-reduce the data family axiom.--  - This eta-reduction is done in TcInstDcls.tcDataFamInstDecl.--But for a /type/ family-  - cab_lhs has the exact arity of the family tycon--There are certain situations (e.g., pretty-printing) where it is necessary to-deal with eta-expanded data family instances. For these situations, the-cab_eta_tvs field records the stuff that has been eta-reduced away.-So if we have-    axiom forall a b. F [a->b] = D b a-and cab_eta_tvs is [p,q], then the original user-written definition-looked like-    axiom forall a b p q. F [a->b] p q = D b a p q-(See #9692, #14179, and #15845 for examples of what can go wrong if-we don't eta-expand when showing things to the user.)--(See also Note [Newtype eta] in TyCon.  This is notionally separate-and deals with the axiom connecting a newtype with its representation-type; but it too is eta-reduced.)--}--instance Eq (CoAxiom br) where-    a == b = getUnique a == getUnique b-    a /= b = getUnique a /= getUnique b--instance Uniquable (CoAxiom br) where-    getUnique = co_ax_unique--instance Outputable (CoAxiom br) where-    ppr = ppr . getName--instance NamedThing (CoAxiom br) where-    getName = co_ax_name--instance Typeable br => Data.Data (CoAxiom br) where-    -- don't traverse?-    toConstr _   = abstractConstr "CoAxiom"-    gunfold _ _  = error "gunfold"-    dataTypeOf _ = mkNoRepType "CoAxiom"--instance Outputable CoAxBranch where-  ppr (CoAxBranch { cab_loc = loc-                  , cab_lhs = lhs-                  , cab_rhs = rhs }) =-    text "CoAxBranch" <+> parens (ppr loc) <> colon-      <+> brackets (fsep (punctuate comma (map pprType lhs)))-      <+> text "=>" <+> pprType rhs--{--************************************************************************-*                                                                      *-                    Roles-*                                                                      *-************************************************************************--Roles are defined here to avoid circular dependencies.--}---- See Note [Roles] in Coercion--- defined here to avoid cyclic dependency with Coercion------ Order of constructors matters: the Ord instance coincides with the *super*typing--- relation on roles.-data Role = Nominal | Representational | Phantom-  deriving (Eq, Ord, Data.Data)---- These names are slurped into the parser code. Changing these strings--- will change the **surface syntax** that GHC accepts! If you want to--- change only the pretty-printing, do some replumbing. See--- mkRoleAnnotDecl in RdrHsSyn-fsFromRole :: Role -> FastString-fsFromRole Nominal          = fsLit "nominal"-fsFromRole Representational = fsLit "representational"-fsFromRole Phantom          = fsLit "phantom"--instance Outputable Role where-  ppr = ftext . fsFromRole--instance Binary Role where-  put_ bh Nominal          = putByte bh 1-  put_ bh Representational = putByte bh 2-  put_ bh Phantom          = putByte bh 3--  get bh = do tag <- getByte bh-              case tag of 1 -> return Nominal-                          2 -> return Representational-                          3 -> return Phantom-                          _ -> panic ("get Role " ++ show tag)--{--************************************************************************-*                                                                      *-                    CoAxiomRule-              Rules for building Evidence-*                                                                      *-************************************************************************--Conditional axioms.  The general idea is that a `CoAxiomRule` looks like this:--    forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2--My intention is to reuse these for both (~) and (~#).-The short-term plan is to use this datatype to represent the type-nat axioms.-In the longer run, it may be good to unify this and `CoAxiom`,-as `CoAxiom` is the special case when there are no assumptions.--}---- | A more explicit representation for `t1 ~ t2`.-type TypeEqn = Pair Type---- | For now, we work only with nominal equality.-data CoAxiomRule = CoAxiomRule-  { coaxrName      :: FastString-  , coaxrAsmpRoles :: [Role]    -- roles of parameter equations-  , coaxrRole      :: Role      -- role of resulting equation-  , coaxrProves    :: [TypeEqn] -> Maybe TypeEqn-        -- ^ coaxrProves returns @Nothing@ when it doesn't like-        -- the supplied arguments.  When this happens in a coercion-        -- that means that the coercion is ill-formed, and Core Lint-        -- checks for that.-  }--instance Data.Data CoAxiomRule where-  -- don't traverse?-  toConstr _   = abstractConstr "CoAxiomRule"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "CoAxiomRule"--instance Uniquable CoAxiomRule where-  getUnique = getUnique . coaxrName--instance Eq CoAxiomRule where-  x == y = coaxrName x == coaxrName y--instance Ord CoAxiomRule where-  compare x y = compare (coaxrName x) (coaxrName y)--instance Outputable CoAxiomRule where-  ppr = ppr . coaxrName----- Type checking of built-in families-data BuiltInSynFamily = BuiltInSynFamily-  { sfMatchFam      :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-  , sfInteractTop   :: [Type] -> Type -> [TypeEqn]-  , sfInteractInert :: [Type] -> Type ->-                       [Type] -> Type -> [TypeEqn]-  }---- Provides default implementations that do nothing.-trivialBuiltInFamily :: BuiltInSynFamily-trivialBuiltInFamily = BuiltInSynFamily-  { sfMatchFam      = \_ -> Nothing-  , sfInteractTop   = \_ _ -> []-  , sfInteractInert = \_ _ _ _ -> []-  }
− compiler/types/Coercion.hs 
@@ -1,2905 +0,0 @@-{--(c) The University of Glasgow 2006--}--{-# LANGUAGE RankNTypes, CPP, MultiWayIf, FlexibleContexts, BangPatterns,-             ScopedTypeVariables #-}---- | Module for (a) type kinds and (b) type coercions,--- as used in System FC. See 'GHC.Core.Expr' for--- more on System FC and how coercions fit into it.----module Coercion (-        -- * Main data type-        Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR,-        UnivCoProvenance, CoercionHole(..), coHoleCoVar, setCoHoleCoVar,-        LeftOrRight(..),-        Var, CoVar, TyCoVar,-        Role(..), ltRole,--        -- ** Functions over coercions-        coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole,-        coercionType, mkCoercionType,-        coercionKind, coercionLKind, coercionRKind,coercionKinds,-        coercionRole, coercionKindRole,--        -- ** Constructing coercions-        mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo,-        mkCoVarCo, mkCoVarCos,-        mkAxInstCo, mkUnbranchedAxInstCo,-        mkAxInstRHS, mkUnbranchedAxInstRHS,-        mkAxInstLHS, mkUnbranchedAxInstLHS,-        mkPiCo, mkPiCos, mkCoCast,-        mkSymCo, mkTransCo, mkTransMCo,-        mkNthCo, nthCoRole, mkLRCo,-        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo,-        mkForAllCo, mkForAllCos, mkHomoForAllCos,-        mkPhantomCo,-        mkHoleCo, mkUnivCo, mkSubCo,-        mkAxiomInstCo, mkProofIrrelCo,-        downgradeRole, mkAxiomRuleCo,-        mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,-        mkKindCo, castCoercionKind, castCoercionKindI,--        mkHeteroCoercionType,-        mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,-        mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,--        -- ** Decomposition-        instNewTyCon_maybe,--        NormaliseStepper, NormaliseStepResult(..), composeSteppers,-        mapStepResult, unwrapNewTypeStepper,-        topNormaliseNewType_maybe, topNormaliseTypeX,--        decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe,-        splitTyConAppCo_maybe,-        splitAppCo_maybe,-        splitFunCo_maybe,-        splitForAllCo_maybe,-        splitForAllCo_ty_maybe, splitForAllCo_co_maybe,--        nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,--        pickLR,--        isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,-        isReflCoVar_maybe, isGReflMCo, coToMCo,--        -- ** Coercion variables-        mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,-        isCoVar_maybe,--        -- ** Free variables-        tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo,-        tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet,-        coercionSize,--        -- ** Substitution-        CvSubstEnv, emptyCvSubstEnv,-        lookupCoVar,-        substCo, substCos, substCoVar, substCoVars, substCoWith,-        substCoVarBndr,-        extendTvSubstAndInScope, getCvSubstEnv,--        -- ** Lifting-        liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,-        emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,-        liftCoSubstVarBndrUsing, isMappedByLC,--        mkSubstLiftingContext, zapLiftingContext,-        substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet,--        LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,-        substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,--        -- ** Comparison-        eqCoercion, eqCoercionX,--        -- ** Forcing evaluation of coercions-        seqCo,--        -- * Pretty-printing-        pprCo, pprParendCo,-        pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS,-        pprCoAxBranchUser, tidyCoAxBndrsForUser,-        etaExpandCoAxBranch,--        -- * Tidying-        tidyCo, tidyCos,--        -- * Other-        promoteCoercion, buildCoercion,--        simplifyArgsWorker-       ) where--#include "HsVersions.h"--import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs)--import GhcPrelude--import GHC.Iface.Type-import TyCoRep-import TyCoFVs-import TyCoPpr-import TyCoSubst-import TyCoTidy-import Type-import TyCon-import CoAxiom-import Var-import VarEnv-import VarSet-import Name hiding ( varName )-import Util-import BasicTypes-import Outputable-import Unique-import Pair-import SrcLoc-import PrelNames-import TysPrim-import ListSetOps-import Maybes-import UniqFM--import Control.Monad (foldM, zipWithM)-import Data.Function ( on )-import Data.Char( isDigit )--{--%************************************************************************-%*                                                                      *-     -- The coercion arguments always *precisely* saturate-     -- arity of (that branch of) the CoAxiom.  If there are-     -- any left over, we use AppCo.  See-     -- See [Coercion axioms applied to coercions] in TyCoRep--\subsection{Coercion variables}-%*                                                                      *-%************************************************************************--}--coVarName :: CoVar -> Name-coVarName = varName--setCoVarUnique :: CoVar -> Unique -> CoVar-setCoVarUnique = setVarUnique--setCoVarName :: CoVar -> Name -> CoVar-setCoVarName   = setVarName--{--%************************************************************************-%*                                                                      *-                   Pretty-printing CoAxioms-%*                                                                      *-%************************************************************************--Defined here to avoid module loops. CoAxiom is loaded very early on.---}--etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type)--- Return the (tvs,lhs,rhs) after eta-expanding,--- to the way in which the axiom was originally written--- See Note [Eta reduction for data families] in CoAxiom-etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs-                                , cab_eta_tvs = eta_tvs-                                , cab_lhs = lhs-                                , cab_rhs = rhs })-  -- ToDo: what about eta_cvs?-  = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys)- where-    eta_tys = mkTyVarTys eta_tvs--pprCoAxiom :: CoAxiom br -> SDoc--- Used in debug-printing only-pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches })-  = hang (text "axiom" <+> ppr ax <+> dcolon)-       2 (vcat (map (pprCoAxBranchUser tc) (fromBranches branches)))--pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc--- Used when printing injectivity errors (FamInst.reportInjectivityErrors)--- and inaccessible branches (TcValidity.inaccessibleCoAxBranch)--- This happens in error messages: don't print the RHS of a data---   family axiom, which is meaningless to a user-pprCoAxBranchUser tc br-  | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br-  | otherwise            = pprCoAxBranch    tc br--pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc--- Print the family-instance equation when reporting---   a conflict between equations (FamInst.conflictInstErr)--- For type families the RHS is important; for data families not so.---   Indeed for data families the RHS is a mysterious internal---   type constructor, so we suppress it (#14179)--- See FamInstEnv Note [Family instance overlap conflicts]-pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs-  where-    pp_rhs _ _ = empty--pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc-pprCoAxBranch = ppr_co_ax_branch ppr_rhs-  where-    ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs--ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc)-                 -> TyCon -> CoAxBranch -> SDoc-ppr_co_ax_branch ppr_rhs fam_tc branch-  = foldr1 (flip hangNotEmpty 2)-    [ pprUserForAll (mkTyCoVarBinders Inferred bndrs')-         -- See Note [Printing foralls in type family instances] in GHC.Iface.Type-    , pp_lhs <+> ppr_rhs tidy_env ee_rhs-    , text "-- Defined" <+> pp_loc ]-  where-    loc = coAxBranchSpan branch-    pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc)-           | otherwise         = text "in" <+> ppr loc--    -- Eta-expand LHS and RHS types, because sometimes data family-    -- instances are eta-reduced.-    -- See Note [Eta reduction for data families] in FamInstEnv.-    (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch--    pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc)-                             (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs)--    (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs--tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var])--- Tidy wildcards "_1", "_2" to "_", and do not return them--- in the list of binders to be printed--- This is so that in error messages we see---     forall a. F _ [a] _ = ...--- rather than---     forall a _1 _2. F _1 [a] _2 = ...------ This is a rather disgusting function-tidyCoAxBndrsForUser init_env tcvs-  = (tidy_env, reverse tidy_bndrs)-  where-    (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs--    tidy_one (env@(occ_env, subst), rev_bndrs') bndr-      | is_wildcard bndr = (env_wild, rev_bndrs')-      | otherwise        = (env',     bndr' : rev_bndrs')-      where-        (env', bndr') = tidyVarBndr env bndr-        env_wild = (occ_env, extendVarEnv subst bndr wild_bndr)-        wild_bndr = setVarName bndr $-                    tidyNameOcc (varName bndr) (mkTyVarOcc "_")-                    -- Tidy the binder to "_"--    is_wildcard :: Var -> Bool-    is_wildcard tv = case occNameString (getOccName tv) of-                       ('_' : rest) -> all isDigit rest-                       _            -> False--{--%************************************************************************-%*                                                                      *-        Destructing coercions-%*                                                                      *-%************************************************************************--Note [Function coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~-Remember that-  (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> TYPE LiftedRep--Hence-  FunCo r co1 co2 :: (s1->t1) ~r (s2->t2)-is short for-  TyConAppCo (->) co_rep1 co_rep2 co1 co2-where co_rep1, co_rep2 are the coercions on the representations.--}----- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into--- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence:------ > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c]-decomposeCo :: Arity -> Coercion-            -> [Role]  -- the roles of the output coercions-                       -- this must have at least as many-                       -- entries as the Arity provided-            -> [Coercion]-decomposeCo arity co rs-  = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ]-           -- Remember, Nth is zero-indexed--decomposeFunCo :: HasDebugCallStack-               => Role      -- Role of the input coercion-               -> Coercion  -- Input coercion-               -> (Coercion, Coercion)--- Expects co :: (s1 -> t1) ~ (s2 -> t2)--- Returns (co1 :: s1~s2, co2 :: t1~t2)--- See Note [Function coercions] for the "2" and "3"-decomposeFunCo r co = ASSERT2( all_ok, ppr co )-                      (mkNthCo r 2 co, mkNthCo r 3 co)-  where-    Pair s1t1 s2t2 = coercionKind co-    all_ok = isFunTy s1t1 && isFunTy s2t2--{- Note [Pushing a coercion into a pi-type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have this:-    (f |> co) t1 .. tn-Then we want to push the coercion into the arguments, so as to make-progress. For example of why you might want to do so, see Note-[Respecting definitional equality] in TyCoRep.--This is done by decomposePiCos.  Specifically, if-    decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor)-then-    (f |> co) t1 .. tn   =   (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn--Notes:--* k can be smaller than n! That is decomposePiCos can return *fewer*-  coercions than there are arguments (ie k < n), if the kind provided-  doesn't have enough binders.--* If there is a type error, we might see-       (f |> co) t1-  where co :: (forall a. ty) ~ (ty1 -> ty2)-  Here 'co' is insoluble, but we don't want to crash in decoposePiCos.-  So decomposePiCos carefully tests both sides of the coercion to check-  they are both foralls or both arrows.  Not doing this caused #15343.--}--decomposePiCos :: HasDebugCallStack-               => CoercionN -> Pair Type  -- Coercion and its kind-               -> [Type]-               -> ([CoercionN], CoercionN)--- See Note [Pushing a coercion into a pi-type]-decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args-  = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args-  where-    orig_subst = mkEmptyTCvSubst $ mkInScopeSet $-                 tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co--    go :: [CoercionN]      -- accumulator for argument coercions, reversed-       -> (TCvSubst,Kind)  -- Lhs kind of coercion-       -> CoercionN        -- coercion originally applied to the function-       -> (TCvSubst,Kind)  -- Rhs kind of coercion-       -> [Type]           -- Arguments to that function-       -> ([CoercionN], Coercion)-    -- Invariant:  co :: subst1(k2) ~ subst2(k2)--    go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys)-      | Just (a, t1) <- splitForAllTy_maybe k1-      , Just (b, t2) <- splitForAllTy_maybe k2-        -- know     co :: (forall a:s1.t1) ~ (forall b:s2.t2)-        --    function :: forall a:s1.t1   (the function is not passed to decomposePiCos)-        --           a :: s1-        --           b :: s2-        --          ty :: s2-        -- need arg_co :: s2 ~ s1-        --      res_co :: t1[ty |> arg_co / a] ~ t2[ty / b]-      = let arg_co  = mkNthCo Nominal 0 (mkSymCo co)-            res_co  = mkInstCo co (mkGReflLeftCo Nominal ty arg_co)-            subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co)-            subst2' = extendTCvSubst subst2 b ty-        in-        go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys--      | Just (_s1, t1) <- splitFunTy_maybe k1-      , Just (_s2, t2) <- splitFunTy_maybe k2-        -- know     co :: (s1 -> t1) ~ (s2 -> t2)-        --    function :: s1 -> t1-        --          ty :: s2-        -- need arg_co :: s2 ~ s1-        --      res_co :: t1 ~ t2-      = let (sym_arg_co, res_co) = decomposeFunCo Nominal co-            arg_co               = mkSymCo sym_arg_co-        in-        go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys--      | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2)-      = go acc_arg_cos (zapTCvSubst subst1, substTy subst1 k1)-                       co-                       (zapTCvSubst subst2, substTy subst1 k2)-                       (ty:tys)--      -- tys might not be empty, if the left-hand type of the original coercion-      -- didn't have enough binders-    go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co)---- | Attempts to obtain the type variable underlying a 'Coercion'-getCoVar_maybe :: Coercion -> Maybe CoVar-getCoVar_maybe (CoVarCo cv) = Just cv-getCoVar_maybe _            = Nothing---- | Attempts to tease a coercion apart into a type constructor and the application--- of a number of coercion arguments to that constructor-splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion])-splitTyConAppCo_maybe co-  | Just (ty, r) <- isReflCo_maybe co-  = do { (tc, tys) <- splitTyConApp_maybe ty-       ; let args = zipWith mkReflCo (tyConRolesX r tc) tys-       ; return (tc, args) }-splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos)-splitTyConAppCo_maybe (FunCo _ arg res)     = Just (funTyCon, cos)-  where cos = [mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res]-splitTyConAppCo_maybe _                     = Nothing---- first result has role equal to input; third result is Nominal-splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)--- ^ Attempt to take a coercion application apart.-splitAppCo_maybe (AppCo co arg) = Just (co, arg)-splitAppCo_maybe (TyConAppCo r tc args)-  | args `lengthExceeds` tyConArity tc-  , Just (args', arg') <- snocView args-  = Just ( mkTyConAppCo r tc args', arg' )--  | not (mustBeSaturated tc)-    -- Never create unsaturated type family apps!-  , Just (args', arg') <- snocView args-  , Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg'-  = Just ( mkTyConAppCo r tc args', arg'' )-       -- Use mkTyConAppCo to preserve the invariant-       --  that identity coercions are always represented by Refl--splitAppCo_maybe co-  | Just (ty, r) <- isReflCo_maybe co-  , Just (ty1, ty2) <- splitAppTy_maybe ty-  = Just (mkReflCo r ty1, mkNomReflCo ty2)-splitAppCo_maybe _ = Nothing--splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion)-splitFunCo_maybe (FunCo _ arg res) = Just (arg, res)-splitFunCo_maybe _ = Nothing--splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion)-splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co)-splitForAllCo_maybe _                     = Nothing---- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder-splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)-splitForAllCo_ty_maybe (ForAllCo tv k_co co)-  | isTyVar tv = Just (tv, k_co, co)-splitForAllCo_ty_maybe _ = Nothing---- | Like 'splitForAllCo_maybe', but only returns Just for covar binder-splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)-splitForAllCo_co_maybe (ForAllCo cv k_co co)-  | isCoVar cv = Just (cv, k_co, co)-splitForAllCo_co_maybe _ = Nothing------------------------------------------------------------ and some coercion kind stuff--coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type-coVarLType cv | (_, _, ty1, _, _) <- coVarKindsTypesRole cv = ty1-coVarRType cv | (_, _, _, ty2, _) <- coVarKindsTypesRole cv = ty2--coVarTypes :: HasDebugCallStack => CoVar -> Pair Type-coVarTypes cv-  | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv-  = Pair ty1 ty2--coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role)-coVarKindsTypesRole cv- | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv)- = (k1, k2, ty1, ty2, eqTyConRole tc)- | otherwise- = pprPanic "coVarKindsTypesRole, non coercion variable"-            (ppr cv $$ ppr (varType cv))--coVarKind :: CoVar -> Type-coVarKind cv-  = ASSERT( isCoVar cv )-    varType cv--coVarRole :: CoVar -> Role-coVarRole cv-  = eqTyConRole (case tyConAppTyCon_maybe (varType cv) of-                   Just tc0 -> tc0-                   Nothing  -> pprPanic "coVarRole: not tyconapp" (ppr cv))--eqTyConRole :: TyCon -> Role--- Given (~#) or (~R#) return the Nominal or Representational respectively-eqTyConRole tc-  | tc `hasKey` eqPrimTyConKey-  = Nominal-  | tc `hasKey` eqReprPrimTyConKey-  = Representational-  | otherwise-  = pprPanic "eqTyConRole: unknown tycon" (ppr tc)---- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@,--- produce a coercion @rep_co :: r1 ~ r2@.-mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion-mkRuntimeRepCo co-  = mkNthCo Nominal 0 kind_co-  where-    kind_co = mkKindCo co  -- kind_co :: TYPE r1 ~ TYPE r2-                           -- (up to silliness with Constraint)--isReflCoVar_maybe :: Var -> Maybe Coercion--- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t)--- Works on all kinds of Vars, not just CoVars-isReflCoVar_maybe cv-  | isCoVar cv-  , Pair ty1 ty2 <- coVarTypes cv-  , ty1 `eqType` ty2-  = Just (mkReflCo (coVarRole cv) ty1)-  | otherwise-  = Nothing---- | Tests if this coercion is obviously a generalized reflexive coercion.--- Guaranteed to work very quickly.-isGReflCo :: Coercion -> Bool-isGReflCo (GRefl{}) = True-isGReflCo (Refl{})  = True -- Refl ty == GRefl N ty MRefl-isGReflCo _         = False---- | Tests if this MCoercion is obviously generalized reflexive--- Guaranteed to work very quickly.-isGReflMCo :: MCoercion -> Bool-isGReflMCo MRefl = True-isGReflMCo (MCo co) | isGReflCo co = True-isGReflMCo _ = False---- | Tests if this coercion is obviously reflexive. Guaranteed to work--- very quickly. Sometimes a coercion can be reflexive, but not obviously--- so. c.f. 'isReflexiveCo'-isReflCo :: Coercion -> Bool-isReflCo (Refl{}) = True-isReflCo (GRefl _ _ mco) | isGReflMCo mco = True-isReflCo _ = False---- | Returns the type coerced if this coercion is a generalized reflexive--- coercion. Guaranteed to work very quickly.-isGReflCo_maybe :: Coercion -> Maybe (Type, Role)-isGReflCo_maybe (GRefl r ty _) = Just (ty, r)-isGReflCo_maybe (Refl ty)      = Just (ty, Nominal)-isGReflCo_maybe _ = Nothing---- | Returns the type coerced if this coercion is reflexive. Guaranteed--- to work very quickly. Sometimes a coercion can be reflexive, but not--- obviously so. c.f. 'isReflexiveCo_maybe'-isReflCo_maybe :: Coercion -> Maybe (Type, Role)-isReflCo_maybe (Refl ty) = Just (ty, Nominal)-isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)-isReflCo_maybe _ = Nothing---- | Slowly checks if the coercion is reflexive. Don't call this in a loop,--- as it walks over the entire coercion.-isReflexiveCo :: Coercion -> Bool-isReflexiveCo = isJust . isReflexiveCo_maybe---- | Extracts the coerced type from a reflexive coercion. This potentially--- walks over the entire coercion, so avoid doing this in a loop.-isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role)-isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal)-isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)-isReflexiveCo_maybe co-  | ty1 `eqType` ty2-  = Just (ty1, r)-  | otherwise-  = Nothing-  where (Pair ty1 ty2, r) = coercionKindRole co--coToMCo :: Coercion -> MCoercion-coToMCo c = if isReflCo c-  then MRefl-  else MCo c--{--%************************************************************************-%*                                                                      *-            Building coercions-%*                                                                      *-%************************************************************************--These "smart constructors" maintain the invariants listed in the definition-of Coercion, and they perform very basic optimizations.--Note [Role twiddling functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--There are a plethora of functions for twiddling roles:--mkSubCo: Requires a nominal input coercion and always produces a-representational output. This is used when you (the programmer) are sure you-know exactly that role you have and what you want.--downgradeRole_maybe: This function takes both the input role and the output role-as parameters. (The *output* role comes first!) It can only *downgrade* a-role -- that is, change it from N to R or P, or from R to P. This one-way-behavior is why there is the "_maybe". If an upgrade is requested, this-function produces Nothing. This is used when you need to change the role of a-coercion, but you're not sure (as you're writing the code) of which roles are-involved.--This function could have been written using coercionRole to ascertain the role-of the input. But, that function is recursive, and the caller of downgradeRole_maybe-often knows the input role. So, this is more efficient.--downgradeRole: This is just like downgradeRole_maybe, but it panics if the-conversion isn't a downgrade.--setNominalRole_maybe: This is the only function that can *upgrade* a coercion.-The result (if it exists) is always Nominal. The input can be at any role. It-works on a "best effort" basis, as it should never be strictly necessary to-upgrade a coercion during compilation. It is currently only used within GHC in-splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second-coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable-that splitAppCo_maybe is operating over a TyConAppCo that uses a-representational coercion. Hence the need for setNominalRole_maybe.-splitAppCo_maybe, in turn, is used only within coercion optimization -- thus,-it is not absolutely critical that setNominalRole_maybe be complete.--Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom-UnivCos are perfectly type-safe, whereas representational and nominal ones are-not. (Nominal ones are no worse than representational ones, so this function *will*-change a UnivCo Representational to a UnivCo Nominal.)--Conal Elliott also came across a need for this function while working with the-GHC API, as he was decomposing Core casts. The Core casts use representational-coercions, as they must, but his use case required nominal coercions (he was-building a GADT). So, that's why this function is exported from this module.--One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as-appropriate? I (Richard E.) have decided not to do this, because upgrading a-role is bizarre and a caller should have to ask for this behavior explicitly.---}---- | Make a generalized reflexive coercion-mkGReflCo :: Role -> Type -> MCoercionN -> Coercion-mkGReflCo r ty mco-  | isGReflMCo mco = if r == Nominal then Refl ty-                     else GRefl r ty MRefl-  | otherwise    = GRefl r ty mco---- | Make a reflexive coercion-mkReflCo :: Role -> Type -> Coercion-mkReflCo Nominal ty = Refl ty-mkReflCo r       ty = GRefl r ty MRefl---- | Make a representational reflexive coercion-mkRepReflCo :: Type -> Coercion-mkRepReflCo ty = GRefl Representational ty MRefl---- | Make a nominal reflexive coercion-mkNomReflCo :: Type -> Coercion-mkNomReflCo = Refl---- | Apply a type constructor to a list of coercions. It is the--- caller's responsibility to get the roles correct on argument coercions.-mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion-mkTyConAppCo r tc cos-  | tc `hasKey` funTyConKey-  , [_rep1, _rep2, co1, co2] <- cos   -- See Note [Function coercions]-  = -- (a :: TYPE ra) -> (b :: TYPE rb)  ~  (c :: TYPE rc) -> (d :: TYPE rd)-    -- rep1 :: ra  ~  rc        rep2 :: rb  ~  rd-    -- co1  :: a   ~  c         co2  :: b   ~  d-    mkFunCo r co1 co2--               -- Expand type synonyms-  | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos-  = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos--  | Just tys_roles <- traverse isReflCo_maybe cos-  = mkReflCo r (mkTyConApp tc (map fst tys_roles))-  -- See Note [Refl invariant]--  | otherwise = TyConAppCo r tc cos---- | Build a function 'Coercion' from two other 'Coercion's. That is,--- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@.-mkFunCo :: Role -> Coercion -> Coercion -> Coercion-mkFunCo r co1 co2-    -- See Note [Refl invariant]-  | Just (ty1, _) <- isReflCo_maybe co1-  , Just (ty2, _) <- isReflCo_maybe co2-  = mkReflCo r (mkVisFunTy ty1 ty2)-  | otherwise = FunCo r co1 co2---- | Apply a 'Coercion' to another 'Coercion'.--- The second coercion must be Nominal, unless the first is Phantom.--- If the first is Phantom, then the second can be either Phantom or Nominal.-mkAppCo :: Coercion     -- ^ :: t1 ~r t2-        -> Coercion     -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2-        -> Coercion     -- ^ :: t1 s1 ~r t2 s2-mkAppCo co arg-  | Just (ty1, r) <- isReflCo_maybe co-  , Just (ty2, _) <- isReflCo_maybe arg-  = mkReflCo r (mkAppTy ty1 ty2)--  | Just (ty1, r) <- isReflCo_maybe co-  , Just (tc, tys) <- splitTyConApp_maybe ty1-    -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102)-  = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys)-  where-    zip_roles (r1:_)  []            = [downgradeRole r1 Nominal arg]-    zip_roles (r1:rs) (ty1:tys)     = mkReflCo r1 ty1 : zip_roles rs tys-    zip_roles _       _             = panic "zip_roles" -- but the roles are infinite...--mkAppCo (TyConAppCo r tc args) arg-  = case r of-      Nominal          -> mkTyConAppCo Nominal tc (args ++ [arg])-      Representational -> mkTyConAppCo Representational tc (args ++ [arg'])-        where new_role = (tyConRolesRepresentational tc) !! (length args)-              arg'     = downgradeRole new_role Nominal arg-      Phantom          -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg])-mkAppCo co arg = AppCo co  arg--- Note, mkAppCo is careful to maintain invariants regarding--- where Refl constructors appear; see the comments in the definition--- of Coercion and the Note [Refl invariant] in TyCoRep.---- | Applies multiple 'Coercion's to another 'Coercion', from left to right.--- See also 'mkAppCo'.-mkAppCos :: Coercion-         -> [Coercion]-         -> Coercion-mkAppCos co1 cos = foldl' mkAppCo co1 cos--{- Note [Unused coercion variable in ForAllCo]--See Note [Unused coercion variable in ForAllTy] in TyCoRep for the motivation for-checking coercion variable in types.-To lift the design choice to (ForAllCo cv kind_co body_co), we have two options:--(1) In mkForAllCo, we check whether cv is a coercion variable-    and whether it is not used in body_co. If so we construct a FunCo.-(2) We don't do this check in mkForAllCo.-    In coercionKind, we use mkTyCoForAllTy to perform the check and construct-    a FunTy when necessary.--We chose (2) for two reasons:--* for a coercion, all that matters is its kind, So ForAllCo or FunCo does not-  make a difference.-* even if cv occurs in body_co, it is possible that cv does not occur in the kind-  of body_co. Therefore the check in coercionKind is inevitable.--The last wrinkle is that there are restrictions around the use of the cv in the-coercion, as described in Section 5.8.5.2 of Richard's thesis. The idea is that-we cannot prove that the type system is consistent with unrestricted use of this-cv; the consistency proof uses an untyped rewrite relation that works over types-with all coercions and casts removed. So, we can allow the cv to appear only in-positions that are erased. As an approximation of this (and keeping close to the-published theory), we currently allow the cv only within the type in a Refl node-and under a GRefl node (including in the Coercion stored in a GRefl). It's-possible other places are OK, too, but this is a safe approximation.--Sadly, with heterogeneous equality, this restriction might be able to be violated;-Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst-function might create an invalid coercion. Because a violation of the-restriction might lead to a program that "goes wrong", it is checked all the time,-even in a production compiler and without -dcore-list. We *have* proved that the-problem does not occur with homogeneous equality, so this check can be dropped-once ~# is made to be homogeneous.--}----- | Make a Coercion from a tycovar, a kind coercion, and a body coercion.--- The kind of the tycovar should be the left-hand kind of the kind coercion.--- See Note [Unused coercion variable in ForAllCo]-mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion-mkForAllCo v kind_co co-  | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True-  , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True-  , Just (ty, r) <- isReflCo_maybe co-  , isGReflCo kind_co-  = mkReflCo r (mkTyCoInvForAllTy v ty)-  | otherwise-  = ForAllCo v kind_co co---- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious--- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'.--- The kind of the tycovar should be the left-hand kind of the kind coercion.-mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion-mkForAllCo_NoRefl v kind_co co-  | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True-  , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True-  , ASSERT( not (isReflCo co)) True-  , isCoVar v-  , not (v `elemVarSet` tyCoVarsOfCo co)-  = FunCo (coercionRole co) kind_co co-  | otherwise-  = ForAllCo v kind_co co---- | Make nested ForAllCos-mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion-mkForAllCos bndrs co-  | Just (ty, r ) <- isReflCo_maybe co-  = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in-    foldl' (flip $ uncurry mkForAllCo_NoRefl)-           (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty))-           non_refls_rev'd-  | otherwise-  = foldr (uncurry mkForAllCo_NoRefl) co bndrs---- | Make a Coercion quantified over a type/coercion variable;--- the variable has the same type in both sides of the coercion-mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion-mkHomoForAllCos vs co-  | Just (ty, r) <- isReflCo_maybe co-  = mkReflCo r (mkTyCoInvForAllTys vs ty)-  | otherwise-  = mkHomoForAllCos_NoRefl vs co---- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious--- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'.-mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion-mkHomoForAllCos_NoRefl vs orig_co-  = ASSERT( not (isReflCo orig_co))-    foldr go orig_co vs-  where-    go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co--mkCoVarCo :: CoVar -> Coercion--- cv :: s ~# t--- See Note [mkCoVarCo]-mkCoVarCo cv = CoVarCo cv--mkCoVarCos :: [CoVar] -> [Coercion]-mkCoVarCos = map mkCoVarCo--{- Note [mkCoVarCo]-~~~~~~~~~~~~~~~~~~~-In the past, mkCoVarCo optimised (c :: t~t) to (Refl t).  That is-valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but-it's a relatively expensive test and perhaps better done in-optCoercion.  Not a big deal either way.--}---- | Extract a covar, if possible. This check is dirty. Be ashamed--- of yourself. (It's dirty because it cares about the structure of--- a coercion, which is morally reprehensible.)-isCoVar_maybe :: Coercion -> Maybe CoVar-isCoVar_maybe (CoVarCo cv) = Just cv-isCoVar_maybe _            = Nothing--mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion]-           -> Coercion--- mkAxInstCo can legitimately be called over-staturated;--- i.e. with more type arguments than the coercion requires-mkAxInstCo role ax index tys cos-  | arity == n_tys = downgradeRole role ax_role $-                     mkAxiomInstCo ax_br index (rtys `chkAppend` cos)-  | otherwise      = ASSERT( arity < n_tys )-                     downgradeRole role ax_role $-                     mkAppCos (mkAxiomInstCo ax_br index-                                             (ax_args `chkAppend` cos))-                              leftover_args-  where-    n_tys         = length tys-    ax_br         = toBranchedAxiom ax-    branch        = coAxiomNthBranch ax_br index-    tvs           = coAxBranchTyVars branch-    arity         = length tvs-    arg_roles     = coAxBranchRoles branch-    rtys          = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys-    (ax_args, leftover_args)-                  = splitAt arity rtys-    ax_role       = coAxiomRole ax---- worker function-mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion-mkAxiomInstCo ax index args-  = ASSERT( args `lengthIs` coAxiomArity ax index )-    AxiomInstCo ax index args---- to be used only with unbranched axioms-mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched-                     -> [Type] -> [Coercion] -> Coercion-mkUnbranchedAxInstCo role ax tys cos-  = mkAxInstCo role ax 0 tys cos--mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type--- Instantiate the axiom with specified types,--- returning the instantiated RHS--- A companion to mkAxInstCo:---    mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys))-mkAxInstRHS ax index tys cos-  = ASSERT( tvs `equalLength` tys1 )-    mkAppTys rhs' tys2-  where-    branch       = coAxiomNthBranch ax index-    tvs          = coAxBranchTyVars branch-    cvs          = coAxBranchCoVars branch-    (tys1, tys2) = splitAtList tvs tys-    rhs'         = substTyWith tvs tys1 $-                   substTyWithCoVars cvs cos $-                   coAxBranchRHS branch--mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type-mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0---- | Return the left-hand type of the axiom, when the axiom is instantiated--- at the types given.-mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type-mkAxInstLHS ax index tys cos-  = ASSERT( tvs `equalLength` tys1 )-    mkTyConApp fam_tc (lhs_tys `chkAppend` tys2)-  where-    branch       = coAxiomNthBranch ax index-    tvs          = coAxBranchTyVars branch-    cvs          = coAxBranchCoVars branch-    (tys1, tys2) = splitAtList tvs tys-    lhs_tys      = substTysWith tvs tys1 $-                   substTysWithCoVars cvs cos $-                   coAxBranchLHS branch-    fam_tc       = coAxiomTyCon ax---- | Instantiate the left-hand side of an unbranched axiom-mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type-mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0---- | Make a coercion from a coercion hole-mkHoleCo :: CoercionHole -> Coercion-mkHoleCo h = HoleCo h---- | Make a universal coercion between two arbitrary types.-mkUnivCo :: UnivCoProvenance-         -> Role       -- ^ role of the built coercion, "r"-         -> Type       -- ^ t1 :: k1-         -> Type       -- ^ t2 :: k2-         -> Coercion   -- ^ :: t1 ~r t2-mkUnivCo prov role ty1 ty2-  | ty1 `eqType` ty2 = mkReflCo role ty1-  | otherwise        = UnivCo prov role ty1 ty2---- | Create a symmetric version of the given 'Coercion' that asserts---   equality between the same types but in the other "direction", so---   a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@.-mkSymCo :: Coercion -> Coercion---- Do a few simple optimizations, but don't bother pushing occurrences--- of symmetry to the leaves; the optimizer will take care of that.-mkSymCo co | isReflCo co          = co-mkSymCo    (SymCo co)             = co-mkSymCo    (SubCo (SymCo co))     = SubCo co-mkSymCo co                        = SymCo co---- | Create a new 'Coercion' by composing the two given 'Coercion's transitively.---   (co1 ; co2)-mkTransCo :: Coercion -> Coercion -> Coercion-mkTransCo co1 co2 | isReflCo co1 = co2-                  | isReflCo co2 = co1-mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2))-  = GRefl r t1 (MCo $ mkTransCo co1 co2)-mkTransCo co1 co2                 = TransCo co1 co2---- | Compose two MCoercions via transitivity-mkTransMCo :: MCoercion -> MCoercion -> MCoercion-mkTransMCo MRefl     co2       = co2-mkTransMCo co1       MRefl     = co1-mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2)--mkNthCo :: HasDebugCallStack-        => Role  -- The role of the coercion you're creating-        -> Int   -- Zero-indexed-        -> Coercion-        -> Coercion-mkNthCo r n co-  = ASSERT2( good_call, bad_call_msg )-    go r n co-  where-    Pair ty1 ty2 = coercionKind co--    go r 0 co-      | Just (ty, _) <- isReflCo_maybe co-      , Just (tv, _) <- splitForAllTy_maybe ty-      = -- works for both tyvar and covar-        ASSERT( r == Nominal )-        mkNomReflCo (varType tv)--    go r n co-      | Just (ty, r0) <- isReflCo_maybe co-      , let tc = tyConAppTyCon ty-      = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty )-        ASSERT( nthRole r0 tc n == r )-        mkReflCo r (tyConAppArgN n ty)-      where ok_tc_app :: Type -> Int -> Bool-            ok_tc_app ty n-              | Just (_, tys) <- splitTyConApp_maybe ty-              = tys `lengthExceeds` n-              | isForAllTy ty  -- nth:0 pulls out a kind coercion from a hetero forall-              = n == 0-              | otherwise-              = False--    go r 0 (ForAllCo _ kind_co _)-      = ASSERT( r == Nominal )-        kind_co-      -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)-      -- then (nth 0 co :: k1 ~N k2)-      -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)-      -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4))--    go r n co@(FunCo r0 arg res)-      -- See Note [Function coercions]-      -- If FunCo _ arg_co res_co ::   (s1:TYPE sk1 -> s2:TYPE sk2)-      --                             ~ (t1:TYPE tk1 -> t2:TYPE tk2)-      -- Then we want to behave as if co was-      --    TyConAppCo argk_co resk_co arg_co res_co-      -- where-      --    argk_co :: sk1 ~ tk1  =  mkNthCo 0 (mkKindCo arg_co)-      --    resk_co :: sk2 ~ tk2  =  mkNthCo 0 (mkKindCo res_co)-      --                             i.e. mkRuntimeRepCo-      = case n of-          0 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg-          1 -> ASSERT( r == Nominal ) mkRuntimeRepCo res-          2 -> ASSERT( r == r0 )      arg-          3 -> ASSERT( r == r0 )      res-          _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co)--    go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n-                                                    , (vcat [ ppr tc-                                                            , ppr arg_cos-                                                            , ppr r0-                                                            , ppr n-                                                            , ppr r ]) )-                                             arg_cos `getNth` n--    go r n co =-      NthCo r n co--    -- Assertion checking-    bad_call_msg = vcat [ text "Coercion =" <+> ppr co-                        , text "LHS ty =" <+> ppr ty1-                        , text "RHS ty =" <+> ppr ty2-                        , text "n =" <+> ppr n, text "r =" <+> ppr r-                        , text "coercion role =" <+> ppr (coercionRole co) ]-    good_call-      -- If the Coercion passed in is between forall-types, then the Int must-      -- be 0 and the role must be Nominal.-      | Just (_tv1, _) <- splitForAllTy_maybe ty1-      , Just (_tv2, _) <- splitForAllTy_maybe ty2-      = n == 0 && r == Nominal--      -- If the Coercion passed in is between T tys and T tys', then the Int-      -- must be less than the length of tys/tys' (which must be the same-      -- lengths).-      ---      -- If the role of the Coercion is nominal, then the role passed in must-      -- be nominal. If the role of the Coercion is representational, then the-      -- role passed in must be tyConRolesRepresentational T !! n. If the role-      -- of the Coercion is Phantom, then the role passed in must be Phantom.-      ---      -- See also Note [NthCo Cached Roles] if you're wondering why it's-      -- blaringly obvious that we should be *computing* this role instead of-      -- passing it in.-      | Just (tc1, tys1) <- splitTyConApp_maybe ty1-      , Just (tc2, tys2) <- splitTyConApp_maybe ty2-      , tc1 == tc2-      = let len1 = length tys1-            len2 = length tys2-            good_role = case coercionRole co of-                          Nominal -> r == Nominal-                          Representational -> r == (tyConRolesRepresentational tc1 !! n)-                          Phantom -> r == Phantom-        in len1 == len2 && n < len1 && good_role--      | otherwise-      = True------ | If you're about to call @mkNthCo r n co@, then @r@ should be--- whatever @nthCoRole n co@ returns.-nthCoRole :: Int -> Coercion -> Role-nthCoRole n co-  | Just (tc, _) <- splitTyConApp_maybe lty-  = nthRole r tc n--  | Just _ <- splitForAllTy_maybe lty-  = Nominal--  | otherwise-  = pprPanic "nthCoRole" (ppr co)--  where-    lty = coercionLKind co-    r   = coercionRole co--mkLRCo :: LeftOrRight -> Coercion -> Coercion-mkLRCo lr co-  | Just (ty, eq) <- isReflCo_maybe co-  = mkReflCo eq (pickLR lr (splitAppTy ty))-  | otherwise-  = LRCo lr co---- | Instantiates a 'Coercion'.-mkInstCo :: Coercion -> Coercion -> Coercion-mkInstCo (ForAllCo tcv _kind_co body_co) co-  | Just (arg, _) <- isReflCo_maybe co-      -- works for both tyvar and covar-  = substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co-mkInstCo co arg = InstCo co arg---- | Given @ty :: k1@, @co :: k1 ~ k2@,--- produces @co' :: ty ~r (ty |> co)@-mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion-mkGReflRightCo r ty co-  | isGReflCo co = mkReflCo r ty-    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@-    -- instead of @isReflCo@-  | otherwise = GRefl r ty (MCo co)---- | Given @ty :: k1@, @co :: k1 ~ k2@,--- produces @co' :: (ty |> co) ~r ty@-mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion-mkGReflLeftCo r ty co-  | isGReflCo co = mkReflCo r ty-    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@-    -- instead of @isReflCo@-  | otherwise    = mkSymCo $ GRefl r ty (MCo co)---- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@,--- produces @co' :: (ty |> co) ~r ty'--- It is not only a utility function, but it saves allocation when co--- is a GRefl coercion.-mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion-mkCoherenceLeftCo r ty co co2-  | isGReflCo co = co2-  | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2---- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@,--- produces @co' :: ty' ~r (ty |> co)--- It is not only a utility function, but it saves allocation when co--- is a GRefl coercion.-mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion-mkCoherenceRightCo r ty co co2-  | isGReflCo co = co2-  | otherwise = co2 `mkTransCo` GRefl r ty (MCo co)---- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@.-mkKindCo :: Coercion -> Coercion-mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty)-mkKindCo (GRefl _ _ (MCo co)) = co-mkKindCo (UnivCo (PhantomProv h) _ _ _)    = h-mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h-mkKindCo co-  | Pair ty1 ty2 <- coercionKind co-       -- generally, calling coercionKind during coercion creation is a bad idea,-       -- as it can lead to exponential behavior. But, we don't have nested mkKindCos,-       -- so it's OK here.-  , let tk1 = typeKind ty1-        tk2 = typeKind ty2-  , tk1 `eqType` tk2-  = Refl tk1-  | otherwise-  = KindCo co--mkSubCo :: Coercion -> Coercion--- Input coercion is Nominal, result is Representational--- see also Note [Role twiddling functions]-mkSubCo (Refl ty) = GRefl Representational ty MRefl-mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co-mkSubCo (TyConAppCo Nominal tc cos)-  = TyConAppCo Representational tc (applyRoles tc cos)-mkSubCo (FunCo Nominal arg res)-  = FunCo Representational-          (downgradeRole Representational Nominal arg)-          (downgradeRole Representational Nominal res)-mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) )-             SubCo co---- | Changes a role, but only a downgrade. See Note [Role twiddling functions]-downgradeRole_maybe :: Role   -- ^ desired role-                    -> Role   -- ^ current role-                    -> Coercion -> Maybe Coercion--- In (downgradeRole_maybe dr cr co) it's a precondition that---                                   cr = coercionRole co--downgradeRole_maybe Nominal          Nominal          co = Just co-downgradeRole_maybe Nominal          _                _  = Nothing--downgradeRole_maybe Representational Nominal          co = Just (mkSubCo co)-downgradeRole_maybe Representational Representational co = Just co-downgradeRole_maybe Representational Phantom          _  = Nothing--downgradeRole_maybe Phantom          Phantom          co = Just co-downgradeRole_maybe Phantom          _                co = Just (toPhantomCo co)---- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade.--- See Note [Role twiddling functions]-downgradeRole :: Role  -- desired role-              -> Role  -- current role-              -> Coercion -> Coercion-downgradeRole r1 r2 co-  = case downgradeRole_maybe r1 r2 co of-      Just co' -> co'-      Nothing  -> pprPanic "downgradeRole" (ppr co)--mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion-mkAxiomRuleCo = AxiomRuleCo---- | Make a "coercion between coercions".-mkProofIrrelCo :: Role       -- ^ role of the created coercion, "r"-               -> Coercion   -- ^ :: phi1 ~N phi2-               -> Coercion   -- ^ g1 :: phi1-               -> Coercion   -- ^ g2 :: phi2-               -> Coercion   -- ^ :: g1 ~r g2---- if the two coercion prove the same fact, I just don't care what--- the individual coercions are.-mkProofIrrelCo r co g  _ | isGReflCo co  = mkReflCo r (mkCoercionTy g)-  -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@-mkProofIrrelCo r kco        g1 g2 = mkUnivCo (ProofIrrelProv kco) r-                                             (mkCoercionTy g1) (mkCoercionTy g2)--{--%************************************************************************-%*                                                                      *-   Roles-%*                                                                      *-%************************************************************************--}---- | Converts a coercion to be nominal, if possible.--- See Note [Role twiddling functions]-setNominalRole_maybe :: Role -- of input coercion-                     -> Coercion -> Maybe Coercion-setNominalRole_maybe r co-  | r == Nominal = Just co-  | otherwise = setNominalRole_maybe_helper co-  where-    setNominalRole_maybe_helper (SubCo co)  = Just co-    setNominalRole_maybe_helper co@(Refl _) = Just co-    setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co-    setNominalRole_maybe_helper (TyConAppCo Representational tc cos)-      = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos-           ; return $ TyConAppCo Nominal tc cos' }-    setNominalRole_maybe_helper (FunCo Representational co1 co2)-      = do { co1' <- setNominalRole_maybe Representational co1-           ; co2' <- setNominalRole_maybe Representational co2-           ; return $ FunCo Nominal co1' co2'-           }-    setNominalRole_maybe_helper (SymCo co)-      = SymCo <$> setNominalRole_maybe_helper co-    setNominalRole_maybe_helper (TransCo co1 co2)-      = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2-    setNominalRole_maybe_helper (AppCo co1 co2)-      = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2-    setNominalRole_maybe_helper (ForAllCo tv kind_co co)-      = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co-    setNominalRole_maybe_helper (NthCo _r n co)-      -- NB, this case recurses via setNominalRole_maybe, not-      -- setNominalRole_maybe_helper!-      = NthCo Nominal n <$> setNominalRole_maybe (coercionRole co) co-    setNominalRole_maybe_helper (InstCo co arg)-      = InstCo <$> setNominalRole_maybe_helper co <*> pure arg-    setNominalRole_maybe_helper (UnivCo prov _ co1 co2)-      | case prov of PhantomProv _    -> False  -- should always be phantom-                     ProofIrrelProv _ -> True   -- it's always safe-                     PluginProv _     -> False  -- who knows? This choice is conservative.-      = Just $ UnivCo prov Nominal co1 co2-    setNominalRole_maybe_helper _ = Nothing---- | Make a phantom coercion between two types. The coercion passed--- in must be a nominal coercion between the kinds of the--- types.-mkPhantomCo :: Coercion -> Type -> Type -> Coercion-mkPhantomCo h t1 t2-  = mkUnivCo (PhantomProv h) Phantom t1 t2---- takes any coercion and turns it into a Phantom coercion-toPhantomCo :: Coercion -> Coercion-toPhantomCo co-  = mkPhantomCo (mkKindCo co) ty1 ty2-  where Pair ty1 ty2 = coercionKind co---- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational-applyRoles :: TyCon -> [Coercion] -> [Coercion]-applyRoles tc cos-  = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos---- the Role parameter is the Role of the TyConAppCo--- defined here because this is intimately concerned with the implementation--- of TyConAppCo--- Always returns an infinite list (with a infinite tail of Nominal)-tyConRolesX :: Role -> TyCon -> [Role]-tyConRolesX Representational tc = tyConRolesRepresentational tc-tyConRolesX role             _  = repeat role---- Returns the roles of the parameters of a tycon, with an infinite tail--- of Nominal-tyConRolesRepresentational :: TyCon -> [Role]-tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal--nthRole :: Role -> TyCon -> Int -> Role-nthRole Nominal _ _ = Nominal-nthRole Phantom _ _ = Phantom-nthRole Representational tc n-  = (tyConRolesRepresentational tc) `getNth` n--ltRole :: Role -> Role -> Bool--- Is one role "less" than another?---     Nominal < Representational < Phantom-ltRole Phantom          _       = False-ltRole Representational Phantom = True-ltRole Representational _       = False-ltRole Nominal          Nominal = False-ltRole Nominal          _       = True------------------------------------- | like mkKindCo, but aggressively & recursively optimizes to avoid using--- a KindCo constructor. The output role is nominal.-promoteCoercion :: Coercion -> CoercionN---- First cases handles anything that should yield refl.-promoteCoercion co = case co of--    _ | ki1 `eqType` ki2-      -> mkNomReflCo (typeKind ty1)-     -- no later branch should return refl-     --    The ASSERT( False )s throughout-     -- are these cases explicitly, but they should never fire.--    Refl _ -> ASSERT( False )-              mkNomReflCo ki1--    GRefl _ _ MRefl -> ASSERT( False )-                       mkNomReflCo ki1--    GRefl _ _ (MCo co) -> co--    TyConAppCo _ tc args-      | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args-      -> co'-      | otherwise-      -> mkKindCo co--    AppCo co1 arg-      | Just co' <- instCoercion (coercionKind (mkKindCo co1))-                                 (promoteCoercion co1) arg-      -> co'-      | otherwise-      -> mkKindCo co--    ForAllCo tv _ g-      | isTyVar tv-      -> promoteCoercion g--    ForAllCo _ _ _-      -> ASSERT( False )-         mkNomReflCo liftedTypeKind-      -- See Note [Weird typing rule for ForAllTy] in Type--    FunCo _ _ _-      -> ASSERT( False )-         mkNomReflCo liftedTypeKind--    CoVarCo {}     -> mkKindCo co-    HoleCo {}      -> mkKindCo co-    AxiomInstCo {} -> mkKindCo co-    AxiomRuleCo {} -> mkKindCo co--    UnivCo (PhantomProv kco) _ _ _    -> kco-    UnivCo (ProofIrrelProv kco) _ _ _ -> kco-    UnivCo (PluginProv _) _ _ _       -> mkKindCo co--    SymCo g-      -> mkSymCo (promoteCoercion g)--    TransCo co1 co2-      -> mkTransCo (promoteCoercion co1) (promoteCoercion co2)--    NthCo _ n co1-      | Just (_, args) <- splitTyConAppCo_maybe co1-      , args `lengthExceeds` n-      -> promoteCoercion (args !! n)--      | Just _ <- splitForAllCo_maybe co-      , n == 0-      -> ASSERT( False ) mkNomReflCo liftedTypeKind--      | otherwise-      -> mkKindCo co--    LRCo lr co1-      | Just (lco, rco) <- splitAppCo_maybe co1-      -> case lr of-           CLeft  -> promoteCoercion lco-           CRight -> promoteCoercion rco--      | otherwise-      -> mkKindCo co--    InstCo g _-      | isForAllTy_ty ty1-      -> ASSERT( isForAllTy_ty ty2 )-         promoteCoercion g-      | otherwise-      -> ASSERT( False)-         mkNomReflCo liftedTypeKind-           -- See Note [Weird typing rule for ForAllTy] in Type--    KindCo _-      -> ASSERT( False )-         mkNomReflCo liftedTypeKind--    SubCo g-      -> promoteCoercion g--  where-    Pair ty1 ty2 = coercionKind co-    ki1 = typeKind ty1-    ki2 = typeKind ty2---- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@,--- where @g' = promoteCoercion (h w)@.--- fails if this is not possible, if @g@ coerces between a forall and an ->--- or if second parameter has a representational role and can't be used--- with an InstCo.-instCoercion :: Pair Type -- g :: lty ~ rty-             -> CoercionN  -- ^  must be nominal-             -> Coercion-             -> Maybe CoercionN-instCoercion (Pair lty rty) g w-  | (isForAllTy_ty lty && isForAllTy_ty rty)-  || (isForAllTy_co lty && isForAllTy_co rty)-  , Just w' <- setNominalRole_maybe (coercionRole w) w-    -- g :: (forall t1. t2) ~ (forall t1. t3)-    -- w :: s1 ~ s2-    -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2]-  = Just $ mkInstCo g w'-  | isFunTy lty && isFunTy rty-    -- g :: (t1 -> t2) ~ (t3 -> t4)-    -- returns t2 ~ t4-  = Just $ mkNthCo Nominal 3 g -- extract result type, which is the 4th argument to (->)-  | otherwise -- one forall, one funty...-  = Nothing---- | Repeated use of 'instCoercion'-instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN-instCoercions g ws-  = let arg_ty_pairs = map coercionKind ws in-    snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws)-  where-    go :: (Pair Type, Coercion) -> (Pair Type, Coercion)-       -> Maybe (Pair Type, Coercion)-    go (g_tys, g) (w_tys, w)-      = do { g' <- instCoercion g_tys g w-           ; return (piResultTy <$> g_tys <*> w_tys, g') }---- | Creates a new coercion with both of its types casted by different casts--- @castCoercionKind g r t1 t2 h1 h2@, where @g :: t1 ~r t2@,--- has type @(t1 |> h1) ~r (t2 |> h2)@.--- @h1@ and @h2@ must be nominal.-castCoercionKind :: Coercion -> Role -> Type -> Type-                 -> CoercionN -> CoercionN -> Coercion-castCoercionKind g r t1 t2 h1 h2-  = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g)---- | Creates a new coercion with both of its types casted by different casts--- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@,--- has type @(t1 |> h1) ~r (t2 |> h2)@.--- @h1@ and @h2@ must be nominal.--- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for)--- Use @castCoercionKind@ instead if @t1@, @t2@, and @r@ are known beforehand.-castCoercionKindI :: Coercion -> CoercionN -> CoercionN -> Coercion-castCoercionKindI g h1 h2-  = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g)-  where (Pair t1 t2, r) = coercionKindRole g---- See note [Newtype coercions] in TyCon--mkPiCos :: Role -> [Var] -> Coercion -> Coercion-mkPiCos r vs co = foldr (mkPiCo r) co vs---- | Make a forall 'Coercion', where both types related by the coercion--- are quantified over the same variable.-mkPiCo  :: Role -> Var -> Coercion -> Coercion-mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co-              | isCoVar v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) )-                  -- We didn't call mkForAllCo here because if v does not appear-                  -- in co, the argement coercion will be nominal. But here we-                  -- want it to be r. It is only called in 'mkPiCos', which is-                  -- only used in SimplUtils, where we are sure for-                  -- now (Aug 2018) v won't occur in co.-                            mkFunCo r (mkReflCo r (varType v)) co-              | otherwise = mkFunCo r (mkReflCo r (varType v)) co---- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2--- The first coercion might be lifted or unlifted; thus the ~? above--- Lifted and unlifted equalities take different numbers of arguments,--- so we have to make sure to supply the right parameter to decomposeCo.--- Also, note that the role of the first coercion is the same as the role of--- the equalities related by the second coercion. The second coercion is--- itself always representational.-mkCoCast :: Coercion -> CoercionR -> Coercion-mkCoCast c g-  | (g2:g1:_) <- reverse co_list-  = mkSymCo g1 `mkTransCo` c `mkTransCo` g2--  | otherwise-  = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g))-  where-    -- g  :: (s1 ~# t1) ~# (s2 ~# t2)-    -- g1 :: s1 ~# s2-    -- g2 :: t1 ~# t2-    (tc, _) = splitTyConApp (coercionLKind g)-    co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc)--{--%************************************************************************-%*                                                                      *-            Newtypes-%*                                                                      *-%************************************************************************--}---- | If @co :: T ts ~ rep_ty@ then:------ > instNewTyCon_maybe T ts = Just (rep_ty, co)------ Checks for a newtype, and for being saturated-instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)-instNewTyCon_maybe tc tys-  | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc  -- Check for newtype-  , tvs `leLength` tys                                    -- Check saturated enough-  = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys [])-  | otherwise-  = Nothing--{--************************************************************************-*                                                                      *-         Type normalisation-*                                                                      *-************************************************************************--}---- | A function to check if we can reduce a type by one step. Used--- with 'topNormaliseTypeX'.-type NormaliseStepper ev = RecTcChecker-                         -> TyCon     -- tc-                         -> [Type]    -- tys-                         -> NormaliseStepResult ev---- | The result of stepping in a normalisation function.--- See 'topNormaliseTypeX'.-data NormaliseStepResult ev-  = NS_Done   -- ^ Nothing more to do-  | NS_Abort  -- ^ Utter failure. The outer function should fail too.-  | NS_Step RecTcChecker Type ev    -- ^ We stepped, yielding new bits;-                                    -- ^ ev is evidence;-                                    -- Usually a co :: old type ~ new type--mapStepResult :: (ev1 -> ev2)-              -> NormaliseStepResult ev1 -> NormaliseStepResult ev2-mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev)-mapStepResult _ NS_Done                 = NS_Done-mapStepResult _ NS_Abort                = NS_Abort---- | Try one stepper and then try the next, if the first doesn't make--- progress.--- So if it returns NS_Done, it means that both steppers are satisfied-composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev-                -> NormaliseStepper ev-composeSteppers step1 step2 rec_nts tc tys-  = case step1 rec_nts tc tys of-      success@(NS_Step {}) -> success-      NS_Done              -> step2 rec_nts tc tys-      NS_Abort             -> NS_Abort---- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into--- a loop. If it would fall into a loop, it produces 'NS_Abort'.-unwrapNewTypeStepper :: NormaliseStepper Coercion-unwrapNewTypeStepper rec_nts tc tys-  | Just (ty', co) <- instNewTyCon_maybe tc tys-  = case checkRecTc rec_nts tc of-      Just rec_nts' -> NS_Step rec_nts' ty' co-      Nothing       -> NS_Abort--  | otherwise-  = NS_Done---- | A general function for normalising the top-level of a type. It continues--- to use the provided 'NormaliseStepper' until that function fails, and then--- this function returns. The roles of the coercions produced by the--- 'NormaliseStepper' must all be the same, which is the role returned from--- the call to 'topNormaliseTypeX'.------ Typically ev is Coercion.------ If topNormaliseTypeX step plus ty = Just (ev, ty')--- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty'--- and ev = ev1 `plus` ev2 `plus` ... `plus` evn--- If it returns Nothing then no newtype unwrapping could happen-topNormaliseTypeX :: NormaliseStepper ev -> (ev -> ev -> ev)-                  -> Type -> Maybe (ev, Type)-topNormaliseTypeX stepper plus ty- | Just (tc, tys) <- splitTyConApp_maybe ty- , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys- = go rec_nts ev ty'- | otherwise- = Nothing- where-    go rec_nts ev ty-      | Just (tc, tys) <- splitTyConApp_maybe ty-      = case stepper rec_nts tc tys of-          NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty'-          NS_Done  -> Just (ev, ty)-          NS_Abort -> Nothing--      | otherwise-      = Just (ev, ty)--topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)--- ^ Sometimes we want to look through a @newtype@ and get its associated coercion.--- This function strips off @newtype@ layers enough to reveal something that isn't--- a @newtype@.  Specifically, here's the invariant:------ > topNormaliseNewType_maybe rec_nts ty = Just (co, ty')------ then (a)  @co : ty0 ~ ty'@.---      (b)  ty' is not a newtype.------ The function returns @Nothing@ for non-@newtypes@,--- or unsaturated applications------ This function does *not* look through type families, because it has no access to--- the type family environment. If you do have that at hand, consider to use--- topNormaliseType_maybe, which should be a drop-in replacement for--- topNormaliseNewType_maybe--- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty'-topNormaliseNewType_maybe ty-  = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty--{--%************************************************************************-%*                                                                      *-                   Comparison of coercions-%*                                                                      *-%************************************************************************--}---- | Syntactic equality of coercions-eqCoercion :: Coercion -> Coercion -> Bool-eqCoercion = eqType `on` coercionType---- | Compare two 'Coercion's, with respect to an RnEnv2-eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool-eqCoercionX env = eqTypeX env `on` coercionType--{--%************************************************************************-%*                                                                      *-                   "Lifting" substitution-           [(TyCoVar,Coercion)] -> Type -> Coercion-%*                                                                      *-%************************************************************************--Note [Lifting coercions over types: liftCoSubst]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The KPUSH rule deals with this situation-   data T a = K (a -> Maybe a)-   g :: T t1 ~ T t2-   x :: t1 -> Maybe t1--   case (K @t1 x) |> g of-     K (y:t2 -> Maybe t2) -> rhs--We want to push the coercion inside the constructor application.-So we do this--   g' :: t1~t2  =  Nth 0 g--   case K @t2 (x |> g' -> Maybe g') of-     K (y:t2 -> Maybe t2) -> rhs--The crucial operation is that we-  * take the type of K's argument: a -> Maybe a-  * and substitute g' for a-thus giving *coercion*.  This is what liftCoSubst does.--In the presence of kind coercions, this is a bit-of a hairy operation. So, we refer you to the paper introducing kind coercions,-available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf--Note [extendLiftingContextEx]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider we have datatype-  K :: \/k. \/a::k. P -> T k  -- P be some type-  g :: T k1 ~ T k2--  case (K @k1 @t1 x) |> g of-    K y -> rhs--We want to push the coercion inside the constructor application.-We first get the coercion mapped by the universal type variable k:-   lc = k |-> Nth 0 g :: k1~k2--Here, the important point is that the kind of a is coerced, and P might be-dependent on the existential type variable a.-Thus we first get the coercion of a's kind-   g2 = liftCoSubst lc k :: k1 ~ k2--Then we store a new mapping into the lifting context-   lc2 = a |-> (t1 ~ t1 |> g2), lc--So later when we can correctly deal with the argument type P-   liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)]--This is exactly what extendLiftingContextEx does.-* For each (tyvar:k, ty) pair, we product the mapping-    tyvar |-> (ty ~ ty |> (liftCoSubst lc k))-* For each (covar:s1~s2, ty) pair, we produce the mapping-    covar |-> (co ~ co')-    co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2'--This follows the lifting context extension definition in the-"FC with Explicit Kind Equality" paper.--}---- ------------------------------------------------------- See Note [Lifting coercions over types: liftCoSubst]--- ------------------------------------------------------data LiftingContext = LC TCvSubst LiftCoEnv-  -- in optCoercion, we need to lift when optimizing InstCo.-  -- See Note [Optimising InstCo] in OptCoercion-  -- We thus propagate the substitution from OptCoercion here.--instance Outputable LiftingContext where-  ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env)--type LiftCoEnv = VarEnv Coercion-     -- Maps *type variables* to *coercions*.-     -- That's the whole point of this function!-     -- Also maps coercion variables to ProofIrrelCos.---- like liftCoSubstWith, but allows for existentially-bound types as well-liftCoSubstWithEx :: Role          -- desired role for output coercion-                  -> [TyVar]       -- universally quantified tyvars-                  -> [Coercion]    -- coercions to substitute for those-                  -> [TyCoVar]     -- existentially quantified tycovars-                  -> [Type]        -- types and coercions to be bound to ex vars-                  -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args)-liftCoSubstWithEx role univs omegas exs rhos-  = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas)-        psi   = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos)-    in (ty_co_subst psi role, substTys (lcSubstRight psi) (mkTyCoVarTys exs))--liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion-liftCoSubstWith r tvs cos ty-  = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty---- | @liftCoSubst role lc ty@ produces a coercion (at role @role@)--- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where--- @lc_left@ is a substitution mapping type variables to the left-hand--- types of the mapped coercions in @lc@, and similar for @lc_right@.-liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion-liftCoSubst r lc@(LC subst env) ty-  | isEmptyVarEnv env = mkReflCo r (substTy subst ty)-  | otherwise         = ty_co_subst lc r ty--emptyLiftingContext :: InScopeSet -> LiftingContext-emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv--mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext-mkLiftingContext pairs-  = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs))-       (mkVarEnv pairs)--mkSubstLiftingContext :: TCvSubst -> LiftingContext-mkSubstLiftingContext subst = LC subst emptyVarEnv---- | Extend a lifting context with a new mapping.-extendLiftingContext :: LiftingContext  -- ^ original LC-                     -> TyCoVar         -- ^ new variable to map...-                     -> Coercion        -- ^ ...to this lifted version-                     -> LiftingContext-    -- mappings to reflexive coercions are just substitutions-extendLiftingContext (LC subst env) tv arg-  | Just (ty, _) <- isReflCo_maybe arg-  = LC (extendTCvSubst subst tv ty) env-  | otherwise-  = LC subst (extendVarEnv env tv arg)---- | Extend a lifting context with a new mapping, and extend the in-scope set-extendLiftingContextAndInScope :: LiftingContext  -- ^ Original LC-                               -> TyCoVar         -- ^ new variable to map...-                               -> Coercion        -- ^ to this coercion-                               -> LiftingContext-extendLiftingContextAndInScope (LC subst env) tv co-  = extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co---- | Extend a lifting context with existential-variable bindings.--- See Note [extendLiftingContextEx]-extendLiftingContextEx :: LiftingContext    -- ^ original lifting context-                       -> [(TyCoVar,Type)]  -- ^ ex. var / value pairs-                       -> LiftingContext--- Note that this is more involved than extendLiftingContext. That function--- takes a coercion to extend with, so it's assumed that the caller has taken--- into account any of the kind-changing stuff worried about here.-extendLiftingContextEx lc [] = lc-extendLiftingContextEx lc@(LC subst env) ((v,ty):rest)--- This function adds bindings for *Nominal* coercions. Why? Because it--- works with existentially bound variables, which are considered to have--- nominal roles.-  | isTyVar v-  = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty)-                 (extendVarEnv env v $-                  mkGReflRightCo Nominal-                                 ty-                                 (ty_co_subst lc Nominal (tyVarKind v)))-    in extendLiftingContextEx lc' rest-  | CoercionTy co <- ty-  = -- co      :: s1 ~r s2-    -- lift_s1 :: s1 ~r s1'-    -- lift_s2 :: s2 ~r s2'-    -- kco     :: (s1 ~r s2) ~N (s1' ~r s2')-    ASSERT( isCoVar v )-    let (_, _, s1, s2, r) = coVarKindsTypesRole v-        lift_s1 = ty_co_subst lc r s1-        lift_s2 = ty_co_subst lc r s2-        kco     = mkTyConAppCo Nominal (equalityTyCon r)-                               [ mkKindCo lift_s1, mkKindCo lift_s2-                               , lift_s1         , lift_s2          ]-        lc'     = LC (subst `extendTCvInScopeSet` tyCoVarsOfCo co)-                     (extendVarEnv env v-                        (mkProofIrrelCo Nominal kco co $-                          (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2))-    in extendLiftingContextEx lc' rest-  | otherwise-  = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty)----- | Erase the environments in a lifting context-zapLiftingContext :: LiftingContext -> LiftingContext-zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv---- | Like 'substForAllCoBndr', but works on a lifting context-substForAllCoBndrUsingLC :: Bool-                            -> (Coercion -> Coercion)-                            -> LiftingContext -> TyCoVar -> Coercion-                            -> (LiftingContext, TyCoVar, Coercion)-substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co-  = (LC subst' lc_env, tv', co')-  where-    (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co---- | The \"lifting\" operation which substitutes coercions for type---   variables in a type to produce a coercion.------   For the inverse operation, see 'liftCoMatch'-ty_co_subst :: LiftingContext -> Role -> Type -> Coercion-ty_co_subst lc role ty-  = go role ty-  where-    go :: Role -> Type -> Coercion-    go r ty                | Just ty' <- coreView ty-                           = go r ty'-    go Phantom ty          = lift_phantom ty-    go r (TyVarTy tv)      = expectJust "ty_co_subst bad roles" $-                             liftCoSubstTyVar lc r tv-    go r (AppTy ty1 ty2)   = mkAppCo (go r ty1) (go Nominal ty2)-    go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys)-    go r (FunTy _ ty1 ty2) = mkFunCo r (go r ty1) (go r ty2)-    go r t@(ForAllTy (Bndr v _) ty)-       = let (lc', v', h) = liftCoSubstVarBndr lc v-             body_co = ty_co_subst lc' r ty in-         if isTyVar v' || almostDevoidCoVarOfCo v' body_co-           -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo-           -- imposes an extra restriction on where a covar can appear. See last-           -- wrinkle in Note [Unused coercion variable in ForAllCo].-           -- We specifically check for this and panic because we know that-           -- there's a hole in the type system here, and we'd rather panic than-           -- fall into it.-         then mkForAllCo v' h body_co-         else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t)-    go r ty@(LitTy {})     = ASSERT( r == Nominal )-                             mkNomReflCo ty-    go r (CastTy ty co)    = castCoercionKindI (go r ty) (substLeftCo lc co)-                                                         (substRightCo lc co)-    go r (CoercionTy co)   = mkProofIrrelCo r kco (substLeftCo lc co)-                                                  (substRightCo lc co)-      where kco = go Nominal (coercionType co)--    lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty))-                                  (substTy (lcSubstLeft  lc) ty)-                                  (substTy (lcSubstRight lc) ty)--{--Note [liftCoSubstTyVar]-~~~~~~~~~~~~~~~~~~~~~~~~~-This function can fail if a coercion in the environment is of too low a role.--liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and-also in matchAxiom in OptCoercion. From liftCoSubst, the so-called lifting-lemma guarantees that the roles work out. If we fail in this-case, we really should panic -- something is deeply wrong. But, in matchAxiom,-failing is fine. matchAxiom is trying to find a set of coercions-that match, but it may fail, and this is healthy behavior.--}---- See Note [liftCoSubstTyVar]-liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion-liftCoSubstTyVar (LC subst env) r v-  | Just co_arg <- lookupVarEnv env v-  = downgradeRole_maybe r (coercionRole co_arg) co_arg--  | otherwise-  = Just $ mkReflCo r (substTyVar subst v)--{- Note [liftCoSubstVarBndr]--callback:-  We want 'liftCoSubstVarBndrUsing' to be general enough to be reused in-  FamInstEnv, therefore the input arg 'fun' returns a pair with polymorphic type-  in snd.-  However in 'liftCoSubstVarBndr', we don't need the snd, so we use unit and-  ignore the fourth component of the return value.--liftCoSubstTyVarBndrUsing:-  Given-    forall tv:k. t-  We want to get-    forall (tv:k1) (kind_co :: k1 ~ k2) body_co--  We lift the kind k to get the kind_co-    kind_co = ty_co_subst k :: k1 ~ k2--  Now in the LiftingContext, we add the new mapping-    tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2)--liftCoSubstCoVarBndrUsing:-  Given-    forall cv:(s1 ~ s2). t-  We want to get-    forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co--  We lift s1 and s2 respectively to get-    eta1 :: s1' ~ t1-    eta2 :: s2' ~ t2-  And-    kind_co = TyConAppCo Nominal (~#) eta1 eta2--  Now in the liftingContext, we add the new mapping-    cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2)--}---- See Note [liftCoSubstVarBndr]-liftCoSubstVarBndr :: LiftingContext -> TyCoVar-                   -> (LiftingContext, TyCoVar, Coercion)-liftCoSubstVarBndr lc tv-  = let (lc', tv', h, _) = liftCoSubstVarBndrUsing callback lc tv in-    (lc', tv', h)-  where-    callback lc' ty' = (ty_co_subst lc' Nominal ty', ())---- the callback must produce a nominal coercion-liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))-                           -> LiftingContext -> TyCoVar-                           -> (LiftingContext, TyCoVar, CoercionN, a)-liftCoSubstVarBndrUsing fun lc old_var-  | isTyVar old_var-  = liftCoSubstTyVarBndrUsing fun lc old_var-  | otherwise-  = liftCoSubstCoVarBndrUsing fun lc old_var---- Works for tyvar binder-liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))-                           -> LiftingContext -> TyVar-                           -> (LiftingContext, TyVar, CoercionN, a)-liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var-  = ASSERT( isTyVar old_var )-    ( LC (subst `extendTCvInScope` new_var) new_cenv-    , new_var, eta, stuff )-  where-    old_kind     = tyVarKind old_var-    (eta, stuff) = fun lc old_kind-    k1           = coercionLKind eta-    new_var      = uniqAway (getTCvInScope subst) (setVarType old_var k1)--    lifted   = mkGReflRightCo Nominal (TyVarTy new_var) eta-               -- :: new_var ~ new_var |> eta-    new_cenv = extendVarEnv cenv old_var lifted---- Works for covar binder-liftCoSubstCoVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))-                           -> LiftingContext -> CoVar-                           -> (LiftingContext, CoVar, CoercionN, a)-liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var-  = ASSERT( isCoVar old_var )-    ( LC (subst `extendTCvInScope` new_var) new_cenv-    , new_var, kind_co, stuff )-  where-    old_kind     = coVarKind old_var-    (eta, stuff) = fun lc old_kind-    k1           = coercionLKind eta-    new_var      = uniqAway (getTCvInScope subst) (setVarType old_var k1)--    -- old_var :: s1  ~r s2-    -- eta     :: (s1' ~r s2') ~N (t1 ~r t2)-    -- eta1    :: s1' ~r t1-    -- eta2    :: s2' ~r t2-    -- co1     :: s1' ~r s2'-    -- co2     :: t1  ~r t2-    -- kind_co :: (s1' ~r s2') ~N (t1 ~r t2)-    -- lifted  :: co1 ~N co2--    role   = coVarRole old_var-    eta'   = downgradeRole role Nominal eta-    eta1   = mkNthCo role 2 eta'-    eta2   = mkNthCo role 3 eta'--    co1     = mkCoVarCo new_var-    co2     = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2-    kind_co = mkTyConAppCo Nominal (equalityTyCon role)-                           [ mkKindCo co1, mkKindCo co2-                           , co1         , co2          ]-    lifted  = mkProofIrrelCo Nominal kind_co co1 co2--    new_cenv = extendVarEnv cenv old_var lifted---- | Is a var in the domain of a lifting context?-isMappedByLC :: TyCoVar -> LiftingContext -> Bool-isMappedByLC tv (LC _ env) = tv `elemVarEnv` env---- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1--- If [a |-> (g1, g2)] is in the substitution, substitute a for g1-substLeftCo :: LiftingContext -> Coercion -> Coercion-substLeftCo lc co-  = substCo (lcSubstLeft lc) co---- Ditto, but for t2 and g2-substRightCo :: LiftingContext -> Coercion -> Coercion-substRightCo lc co-  = substCo (lcSubstRight lc) co---- | Apply "sym" to all coercions in a 'LiftCoEnv'-swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv-swapLiftCoEnv = mapVarEnv mkSymCo--lcSubstLeft :: LiftingContext -> TCvSubst-lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env--lcSubstRight :: LiftingContext -> TCvSubst-lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env--liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst-liftEnvSubstLeft = liftEnvSubst pFst--liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst-liftEnvSubstRight = liftEnvSubst pSnd--liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst-liftEnvSubst selector subst lc_env-  = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst-  where-    pairs            = nonDetUFMToList lc_env-                       -- It's OK to use nonDetUFMToList here because we-                       -- immediately forget the ordering by creating-                       -- a VarEnv-    (tpairs, cpairs) = partitionWith ty_or_co pairs-    tenv             = mkVarEnv_Directly tpairs-    cenv             = mkVarEnv_Directly cpairs--    ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion)-    ty_or_co (u, co)-      | Just equality_co <- isCoercionTy_maybe equality_ty-      = Right (u, equality_co)-      | otherwise-      = Left (u, equality_ty)-      where-        equality_ty = selector (coercionKind co)---- | Extract the underlying substitution from the LiftingContext-lcTCvSubst :: LiftingContext -> TCvSubst-lcTCvSubst (LC subst _) = subst---- | Get the 'InScopeSet' from a 'LiftingContext'-lcInScopeSet :: LiftingContext -> InScopeSet-lcInScopeSet (LC subst _) = getTCvInScope subst--{--%************************************************************************-%*                                                                      *-            Sequencing on coercions-%*                                                                      *-%************************************************************************--}--seqMCo :: MCoercion -> ()-seqMCo MRefl    = ()-seqMCo (MCo co) = seqCo co--seqCo :: Coercion -> ()-seqCo (Refl ty)                 = seqType ty-seqCo (GRefl r ty mco)          = r `seq` seqType ty `seq` seqMCo mco-seqCo (TyConAppCo r tc cos)     = r `seq` tc `seq` seqCos cos-seqCo (AppCo co1 co2)           = seqCo co1 `seq` seqCo co2-seqCo (ForAllCo tv k co)        = seqType (varType tv) `seq` seqCo k-                                                       `seq` seqCo co-seqCo (FunCo r co1 co2)         = r `seq` seqCo co1 `seq` seqCo co2-seqCo (CoVarCo cv)              = cv `seq` ()-seqCo (HoleCo h)                = coHoleCoVar h `seq` ()-seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos-seqCo (UnivCo p r t1 t2)-  = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2-seqCo (SymCo co)                = seqCo co-seqCo (TransCo co1 co2)         = seqCo co1 `seq` seqCo co2-seqCo (NthCo r n co)            = r `seq` n `seq` seqCo co-seqCo (LRCo lr co)              = lr `seq` seqCo co-seqCo (InstCo co arg)           = seqCo co `seq` seqCo arg-seqCo (KindCo co)               = seqCo co-seqCo (SubCo co)                = seqCo co-seqCo (AxiomRuleCo _ cs)        = seqCos cs--seqProv :: UnivCoProvenance -> ()-seqProv (PhantomProv co)    = seqCo co-seqProv (ProofIrrelProv co) = seqCo co-seqProv (PluginProv _)      = ()--seqCos :: [Coercion] -> ()-seqCos []       = ()-seqCos (co:cos) = seqCo co `seq` seqCos cos--{--%************************************************************************-%*                                                                      *-             The kind of a type, and of a coercion-%*                                                                      *-%************************************************************************--}---- | Apply 'coercionKind' to multiple 'Coercion's-coercionKinds :: [Coercion] -> Pair [Type]-coercionKinds tys = sequenceA $ map coercionKind tys---- | Get a coercion's kind and role.-coercionKindRole :: Coercion -> (Pair Type, Role)-coercionKindRole co = (coercionKind co, coercionRole co)--coercionType :: Coercion -> Type-coercionType co = case coercionKindRole co of-  (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2----------------------- | If it is the case that------ > c :: (t1 ~ t2)------ i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@.--coercionKind :: Coercion -> Pair Type-coercionKind co = Pair (coercionLKind co) (coercionRKind co)--coercionLKind :: Coercion -> Type-coercionLKind co-  = go co-  where-    go (Refl ty)                = ty-    go (GRefl _ ty _)           = ty-    go (TyConAppCo _ tc cos)    = mkTyConApp tc (map go cos)-    go (AppCo co1 co2)          = mkAppTy (go co1) (go co2)-    go (ForAllCo tv1 _ co1)     = mkTyCoInvForAllTy tv1 (go co1)-    go (FunCo _ co1 co2)        = mkVisFunTy (go co1) (go co2)-    go (CoVarCo cv)             = coVarLType cv-    go (HoleCo h)               = coVarLType (coHoleCoVar h)-    go (UnivCo _ _ ty1 _)       = ty1-    go (SymCo co)               = coercionRKind co-    go (TransCo co1 _)          = go co1-    go (LRCo lr co)             = pickLR lr (splitAppTy (go co))-    go (InstCo aco arg)         = go_app aco [go arg]-    go (KindCo co)              = typeKind (go co)-    go (SubCo co)               = go co-    go (NthCo _ d co)           = go_nth d (go co)-    go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos)-    go (AxiomRuleCo ax cos)     = pFst $ expectJust "coercionKind" $-                                  coaxrProves ax $ map coercionKind cos--    go_ax_inst ax ind tys-      | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs-                   , cab_lhs = lhs } <- coAxiomNthBranch ax ind-      , let (tys1, cotys1) = splitAtList tvs tys-            cos1           = map stripCoercionTy cotys1-      = ASSERT( tys `equalLength` (tvs ++ cvs) )-                  -- Invariant of AxiomInstCo: cos should-                  -- exactly saturate the axiom branch-        substTyWith tvs tys1       $-        substTyWithCoVars cvs cos1 $-        mkTyConApp (coAxiomTyCon ax) lhs--    go_app :: Coercion -> [Type] -> Type-    -- Collect up all the arguments and apply all at once-    -- See Note [Nested InstCos]-    go_app (InstCo co arg) args = go_app co (go arg:args)-    go_app co              args = piResultTys (go co) args--go_nth :: Int -> Type -> Type-go_nth d ty-  | Just args <- tyConAppArgs_maybe ty-  = ASSERT( args `lengthExceeds` d )-    args `getNth` d--  | d == 0-  , Just (tv,_) <- splitForAllTy_maybe ty-  = tyVarKind tv--  | otherwise-  = pprPanic "coercionLKind:nth" (ppr d <+> ppr ty)--coercionRKind :: Coercion -> Type-coercionRKind co-  = go co-  where-    go (Refl ty)                = ty-    go (GRefl _ ty MRefl)       = ty-    go (GRefl _ ty (MCo co1))   = mkCastTy ty co1-    go (TyConAppCo _ tc cos)    = mkTyConApp tc (map go cos)-    go (AppCo co1 co2)          = mkAppTy (go co1) (go co2)-    go (CoVarCo cv)             = coVarRType cv-    go (HoleCo h)               = coVarRType (coHoleCoVar h)-    go (FunCo _ co1 co2)        = mkVisFunTy (go co1) (go co2)-    go (UnivCo _ _ _ ty2)       = ty2-    go (SymCo co)               = coercionLKind co-    go (TransCo _ co2)          = go co2-    go (LRCo lr co)             = pickLR lr (splitAppTy (go co))-    go (InstCo aco arg)         = go_app aco [go arg]-    go (KindCo co)              = typeKind (go co)-    go (SubCo co)               = go co-    go (NthCo _ d co)           = go_nth d (go co)-    go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos)-    go (AxiomRuleCo ax cos)     = pSnd $ expectJust "coercionKind" $-                                  coaxrProves ax $ map coercionKind cos--    go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar-       | isGReflCo k_co           = mkTyCoInvForAllTy tv1 (go co1)-         -- kind_co always has kind @Type@, thus @isGReflCo@-       | otherwise                = go_forall empty_subst co-       where-         empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co)--    go_ax_inst ax ind tys-      | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs-                   , cab_rhs = rhs } <- coAxiomNthBranch ax ind-      , let (tys2, cotys2) = splitAtList tvs tys-            cos2           = map stripCoercionTy cotys2-      = ASSERT( tys `equalLength` (tvs ++ cvs) )-                  -- Invariant of AxiomInstCo: cos should-                  -- exactly saturate the axiom branch-        substTyWith tvs tys2 $-        substTyWithCoVars cvs cos2 rhs--    go_app :: Coercion -> [Type] -> Type-    -- Collect up all the arguments and apply all at once-    -- See Note [Nested InstCos]-    go_app (InstCo co arg) args = go_app co (go arg:args)-    go_app co              args = piResultTys (go co) args--    go_forall subst (ForAllCo tv1 k_co co)-      -- See Note [Nested ForAllCos]-      | isTyVar tv1-      = mkInvForAllTy tv2 (go_forall subst' co)-      where-        k2  = coercionRKind k_co-        tv2 = setTyVarKind tv1 (substTy subst k2)-        subst' | isGReflCo k_co = extendTCvInScope subst tv1-                 -- kind_co always has kind @Type@, thus @isGReflCo@-               | otherwise      = extendTvSubst (extendTCvInScope subst tv2) tv1 $-                                  TyVarTy tv2 `mkCastTy` mkSymCo k_co--    go_forall subst (ForAllCo cv1 k_co co)-      | isCoVar cv1-      = mkTyCoInvForAllTy cv2 (go_forall subst' co)-      where-        k2 = coercionRKind k_co-        r         = coVarRole cv1-        eta1      = mkNthCo r 2 (downgradeRole r Nominal k_co)-        eta2      = mkNthCo r 3 (downgradeRole r Nominal k_co)--        -- k_co :: (t1 ~r t2) ~N (s1 ~r s2)-        -- k1    = t1 ~r t2-        -- k2    = s1 ~r s2-        -- cv1  :: t1 ~r t2-        -- cv2  :: s1 ~r s2-        -- eta1 :: t1 ~r s1-        -- eta2 :: t2 ~r s2-        -- n_subst  = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2--        cv2     = setVarType cv1 (substTy subst k2)-        n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2)-        subst'  | isReflCo k_co = extendTCvInScope subst cv1-                | otherwise     = extendCvSubst (extendTCvInScope subst cv2)-                                                cv1 n_subst--    go_forall subst other_co-      -- when other_co is not a ForAllCo-      = substTy subst (go other_co)--{---Note [Nested ForAllCos]-~~~~~~~~~~~~~~~~~~~~~~~--Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an-co)...) )`.   We do not want to perform `n` single-type-variable-substitutions over the kind of `co`; rather we want to do one substitution-which substitutes for all of `a1`, `a2` ... simultaneously.  If we do one-at a time we get the performance hole reported in #11735.--Solution: gather up the type variables for nested `ForAllCos`, and-substitute for them all at once.  Remarkably, for #11735 this single-change reduces /total/ compile time by a factor of more than ten.---}---- | Retrieve the role from a coercion.-coercionRole :: Coercion -> Role-coercionRole = go-  where-    go (Refl _) = Nominal-    go (GRefl r _ _) = r-    go (TyConAppCo r _ _) = r-    go (AppCo co1 _) = go co1-    go (ForAllCo _ _ co) = go co-    go (FunCo r _ _) = r-    go (CoVarCo cv) = coVarRole cv-    go (HoleCo h)   = coVarRole (coHoleCoVar h)-    go (AxiomInstCo ax _ _) = coAxiomRole ax-    go (UnivCo _ r _ _)  = r-    go (SymCo co) = go co-    go (TransCo co1 _co2) = go co1-    go (NthCo r _d _co) = r-    go (LRCo {}) = Nominal-    go (InstCo co _) = go co-    go (KindCo {}) = Nominal-    go (SubCo _) = Representational-    go (AxiomRuleCo ax _) = coaxrRole ax--{--Note [Nested InstCos]-~~~~~~~~~~~~~~~~~~~~~-In #5631 we found that 70% of the entire compilation time was-being spent in coercionKind!  The reason was that we had-   (g @ ty1 @ ty2 .. @ ty100)    -- The "@s" are InstCos-where-   g :: forall a1 a2 .. a100. phi-If we deal with the InstCos one at a time, we'll do this:-   1.  Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi'-   2.  Substitute phi'[ ty100/a100 ], a single tyvar->type subst-But this is a *quadratic* algorithm, and the blew up #5631.-So it's very important to do the substitution simultaneously;-cf Type.piResultTys (which in fact we call here).---}---- | Makes a coercion type from two types: the types whose equality--- is proven by the relevant 'Coercion'-mkCoercionType :: Role -> Type -> Type -> Type-mkCoercionType Nominal          = mkPrimEqPred-mkCoercionType Representational = mkReprPrimEqPred-mkCoercionType Phantom          = \ty1 ty2 ->-  let ki1 = typeKind ty1-      ki2 = typeKind ty2-  in-  TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2]--mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type-mkHeteroCoercionType Nominal          = mkHeteroPrimEqPred-mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred-mkHeteroCoercionType Phantom          = panic "mkHeteroCoercionType"---- | Creates a primitive type equality predicate.--- Invariant: the types are not Coercions-mkPrimEqPred :: Type -> Type -> Type-mkPrimEqPred ty1 ty2-  = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2]-  where-    k1 = typeKind ty1-    k2 = typeKind ty2---- | Makes a lifted equality predicate at the given role-mkPrimEqPredRole :: Role -> Type -> Type -> PredType-mkPrimEqPredRole Nominal          = mkPrimEqPred-mkPrimEqPredRole Representational = mkReprPrimEqPred-mkPrimEqPredRole Phantom          = panic "mkPrimEqPredRole phantom"---- | Creates a primite type equality predicate with explicit kinds-mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type-mkHeteroPrimEqPred k1 k2 ty1 ty2 = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2]---- | Creates a primitive representational type equality predicate--- with explicit kinds-mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type-mkHeteroReprPrimEqPred k1 k2 ty1 ty2-  = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]--mkReprPrimEqPred :: Type -> Type -> Type-mkReprPrimEqPred ty1  ty2-  = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]-  where-    k1 = typeKind ty1-    k2 = typeKind ty2---- | Assuming that two types are the same, ignoring coercions, find--- a nominal coercion between the types. This is useful when optimizing--- transitivity over coercion applications, where splitting two--- AppCos might yield different kinds. See Note [EtaAppCo] in OptCoercion.-buildCoercion :: Type -> Type -> CoercionN-buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2-  where-    go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2-               | Just ty2' <- coreView ty2 = go ty1 ty2'--    go (CastTy ty1 co) ty2-      = let co' = go ty1 ty2-            r = coercionRole co'-        in  mkCoherenceLeftCo r ty1 co co'--    go ty1 (CastTy ty2 co)-      = let co' = go ty1 ty2-            r = coercionRole co'-        in  mkCoherenceRightCo r ty2 co co'--    go ty1@(TyVarTy tv1) _tyvarty-      = ASSERT( case _tyvarty of-                  { TyVarTy tv2 -> tv1 == tv2-                  ; _           -> False      } )-        mkNomReflCo ty1--    go (FunTy { ft_arg = arg1, ft_res = res1 })-       (FunTy { ft_arg = arg2, ft_res = res2 })-      = mkFunCo Nominal (go arg1 arg2) (go res1 res2)--    go (TyConApp tc1 args1) (TyConApp tc2 args2)-      = ASSERT( tc1 == tc2 )-        mkTyConAppCo Nominal tc1 (zipWith go args1 args2)--    go (AppTy ty1a ty1b) ty2-      | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2-      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)--    go ty1 (AppTy ty2a ty2b)-      | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1-      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)--    go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2)-      | isTyVar tv1-      = ASSERT( isTyVar tv2 )-        mkForAllCo tv1 kind_co (go ty1 ty2')-      where kind_co  = go (tyVarKind tv1) (tyVarKind tv2)-            in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co-            ty2'     = substTyWithInScope in_scope [tv2]-                         [mkTyVarTy tv1 `mkCastTy` kind_co]-                         ty2--    go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2)-      = ASSERT( isCoVar cv1 && isCoVar cv2 )-        mkForAllCo cv1 kind_co (go ty1 ty2')-      where s1 = varType cv1-            s2 = varType cv2-            kind_co = go s1 s2--            -- s1 = t1 ~r t2-            -- s2 = t3 ~r t4-            -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4)-            -- eta1 :: t1 ~r t3-            -- eta2 :: t2 ~r t4--            r    = coVarRole cv1-            kind_co' = downgradeRole r Nominal kind_co-            eta1 = mkNthCo r 2 kind_co'-            eta2 = mkNthCo r 3 kind_co'--            subst = mkEmptyTCvSubst $ mkInScopeSet $-                      tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co-            ty2'  = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo`-                                                       mkCoVarCo cv1 `mkTransCo`-                                                       eta2)-                            ty2--    go ty1@(LitTy lit1) _lit2-      = ASSERT( case _lit2 of-                  { LitTy lit2 -> lit1 == lit2-                  ; _          -> False        } )-        mkNomReflCo ty1--    go (CoercionTy co1) (CoercionTy co2)-      = mkProofIrrelCo Nominal kind_co co1 co2-      where-        kind_co = go (coercionType co1) (coercionType co2)--    go ty1 ty2-      = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2-                                           , ppr ty1, ppr ty2 ])--{--%************************************************************************-%*                                                                      *-       Simplifying types-%*                                                                      *-%************************************************************************--The function below morally belongs in TcFlatten, but it is used also in-FamInstEnv, and so lives here.--Note [simplifyArgsWorker]-~~~~~~~~~~~~~~~~~~~~~~~~~-Invariant (F2) of Note [Flattening] says that flattening is homogeneous.-This causes some trouble when flattening a function applied to a telescope-of arguments, perhaps with dependency. For example, suppose--  type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k]--and we wish to flatten the args of (with kind applications explicit)--  F a b (Just a c) (Right a b d) False--where all variables are skolems and--  a :: Type-  b :: Type-  c :: a-  d :: k--  [G] aco :: a ~ fa-  [G] bco :: b ~ fb-  [G] cco :: c ~ fc-  [G] dco :: d ~ fd--The first step is to flatten all the arguments. This is done before calling-simplifyArgsWorker. We start from--  a-  b-  Just a c-  Right a b d-  False--and get--  (fa,                             co1 :: fa ~ a)-  (fb,                             co2 :: fb ~ b)-  (Just fa (fc |> aco) |> co6,     co3 :: (Just fa (fc |> aco) |> co6) ~ (Just a c))-  (Right fa fb (fd |> bco) |> co7, co4 :: (Right fa fb (fd |> bco) |> co7) ~ (Right a b d))-  (False,                          co5 :: False ~ False)--where-  co6 :: Maybe fa ~ Maybe a-  co7 :: Either fa fb ~ Either a b--We now process the flattened args in left-to-right order. The first two args-need no further processing. But now consider the third argument. Let f3 = the flattened-result, Just fa (fc |> aco) |> co6.-This f3 flattened argument has kind (Maybe a), due to-(F2). And yet, when we build the application (F fa fb ...), we need this-argument to have kind (Maybe fa), not (Maybe a). We must cast this argument.-The coercion to use is-determined by the kind of F: we see in F's kind that the third argument has-kind Maybe j. Critically, we also know that the argument corresponding to j-(in our example, a) flattened with a coercion co1. We can thus know the-coercion needed for the 3rd argument is (Maybe (sym co1)), thus building-(f3 |> Maybe (sym co1))--More generally, we must use the Lifting Lemma, as implemented in-Coercion.liftCoSubst. As we work left-to-right, any variable that is a-dependent parameter (j and k, in our example) gets mapped in a lifting context-to the coercion that is output from flattening the corresponding argument (co1-and co2, in our example). Then, after flattening later arguments, we lift the-kind of these arguments in the lifting context that we've be building up.-This coercion is then used to keep the result of flattening well-kinded.--Working through our example, this is what happens:--  1. Extend the (empty) LC with [j |-> co1]. No new casting must be done,-     because the binder associated with the first argument has a closed type (no-     variables).--  2. Extend the LC with [k |-> co2]. No casting to do.--  3. Lifting the kind (Maybe j) with our LC-     yields co8 :: Maybe fa ~ Maybe a. Use (f3 |> sym co8) as the argument to-     F.--  4. Lifting the kind (Either j k) with our LC-     yields co9 :: Either fa fb ~ Either a b. Use (f4 |> sym co9) as the 4th-     argument to F, where f4 is the flattened form of argument 4, written above.--  5. We lift Bool with our LC, getting <Bool>;-     casting has no effect.--We're now almost done, but the new application (F fa fb (f3 |> sym co8) (f4 > sym co9) False)-has the wrong kind. Its kind is [fb], instead of the original [b].-So we must use our LC one last time to lift the result kind [k],-getting res_co :: [fb] ~ [b], and we cast our result.--Accordingly, the final result is--  F fa fb (Just fa (fc |> aco) |> Maybe (sym aco) |> sym (Maybe (sym aco)))-          (Right fa fb (fd |> bco) |> Either (sym aco) (sym bco) |> sym (Either (sym aco) (sym bco)))-          False-            |> [sym bco]--The res_co (in this case, [sym bco])-is returned as the third return value from simplifyArgsWorker.--Note [Last case in simplifyArgsWorker]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In writing simplifyArgsWorker's `go`, we know here that args cannot be empty,-because that case is first. We've run out of-binders. But perhaps inner_ki is a tyvar that has been instantiated with a-Π-type.--Here is an example.--  a :: forall (k :: Type). k -> k-  type family Star-  Proxy :: forall j. j -> Type-  axStar :: Star ~ Type-  type family NoWay :: Bool-  axNoWay :: NoWay ~ False-  bo :: Type-  [G] bc :: bo ~ Bool   (in inert set)--  co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star)-  co = forall (j :: sym axStar). (<j> -> sym axStar)--  We are flattening:-  a (forall (j :: Star). (j |> axStar) -> Star)   -- 1-    (Proxy |> co)                                 -- 2-    (bo |> sym axStar)                            -- 3-    (NoWay |> sym bc)                             -- 4-      :: Star--First, we flatten all the arguments (before simplifyArgsWorker), like so:--    (forall j. j -> Type, co1 :: (forall j. j -> Type) ~-                                 (forall (j :: Star). (j |> axStar) -> Star))  -- 1-    (Proxy |> co,         co2 :: (Proxy |> co) ~ (Proxy |> co))                -- 2-    (Bool |> sym axStar,  co3 :: (Bool |> sym axStar) ~ (bo |> sym axStar))    -- 3-    (False |> sym bc,     co4 :: (False |> sym bc) ~ (NoWay |> sym bc))        -- 4--Then we do the process described in Note [simplifyArgsWorker].--1. Lifting Type (the kind of the first arg) gives us a reflexive coercion, so we-   don't use it. But we do build a lifting context [k -> co1] (where co1 is a-   result of flattening an argument, written above).--2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> sym co1).-   This is not a dependent argument, so we don't extend the lifting context.--Now we need to deal with argument (3).-The way we normally proceed is to lift the kind of the binder, to see whether-it's dependent.-But here, the remainder of the kind of `a` that we're left with-after processing two arguments is just `k`.--The way forward is look up k in the lifting context, getting co1. If we're at-all well-typed, co1 will be a coercion between Π-types, with at least one binder.-So, let's-decompose co1 with decomposePiCos. This decomposition needs arguments to use-to instantiate any kind parameters. Look at the type of co1. If we just-decomposed it, we would end up with coercions whose types include j, which is-out of scope here. Accordingly, decomposePiCos takes a list of types whose-kinds are the *right-hand* types in the decomposed coercion. (See comments on-decomposePiCos.) Because the flattened types have unflattened kinds (because-flattening is homogeneous), passing the list of flattened types to decomposePiCos-just won't do: later arguments' kinds won't be as expected. So we need to get-the *unflattened* types to pass to decomposePiCos. We can do this easily enough-by taking the kind of the argument coercions, passed in originally.--(Alternative 1: We could re-engineer decomposePiCos to deal with this situation.-But that function is already gnarly, and taking the right-hand types is correct-at its other call sites, which are much more common than this one.)--(Alternative 2: We could avoid calling decomposePiCos entirely, integrating its-behavior into simplifyArgsWorker. This would work, I think, but then all of the-complication of decomposePiCos would end up layered on top of all the complication-here. Please, no.)--(Alternative 3: We could pass the unflattened arguments into simplifyArgsWorker-so that we don't have to recreate them. But that would complicate the interface-of this function to handle a very dark, dark corner case. Better to keep our-demons to ourselves here instead of exposing them to callers. This decision is-easily reversed if there is ever any performance trouble due to the call of-coercionKind.)--So we now call--  decomposePiCos co1-                 (Pair (forall j. j -> Type) (forall (j :: Star). (j |> axStar) -> Star))-                 [bo |> sym axStar, NoWay |> sym bc]--to get--  co5 :: Star ~ Type-  co6 :: (j |> axStar) ~ (j |> co5), substituted to-                              (bo |> sym axStar |> axStar) ~ (bo |> sym axStar |> co5)-                           == bo ~ bo-  res_co :: Type ~ Star--We then use these casts on (the flattened) (3) and (4) to get--  (Bool |> sym axStar |> co5 :: Type)   -- (C3)-  (False |> sym bc |> co6    :: bo)     -- (C4)--We can simplify to--  Bool                        -- (C3)-  (False |> sym bc :: bo)     -- (C4)--Of course, we still must do the processing in Note [simplifyArgsWorker] to finish-the job. We thus want to recur. Our new function kind is the left-hand type of-co1 (gotten, recall, by lifting the variable k that was the return kind of the-original function). Why the left-hand type (as opposed to the right-hand type)?-Because we have casted all the arguments according to decomposePiCos, which gets-us from the right-hand type to the left-hand one. We thus recur with that new-function kind, zapping our lifting context, because we have essentially applied-it.--This recursive call returns ([Bool, False], [...], Refl). The Bool and False-are the correct arguments we wish to return. But we must be careful about the-result coercion: our new, flattened application will have kind Type, but we-want to make sure that the result coercion casts this back to Star. (Why?-Because we started with an application of kind Star, and flattening is homogeneous.)--So, we have to twiddle the result coercion appropriately.--Let's check whether this is well-typed. We know--  a :: forall (k :: Type). k -> k--  a (forall j. j -> Type) :: (forall j. j -> Type) -> forall j. j -> Type--  a (forall j. j -> Type)-    Proxy-      :: forall j. j -> Type--  a (forall j. j -> Type)-    Proxy-    Bool-      :: Bool -> Type--  a (forall j. j -> Type)-    Proxy-    Bool-    False-      :: Type--  a (forall j. j -> Type)-    Proxy-    Bool-    False-     |> res_co-     :: Star--as desired.--Whew.--Historical note: I (Richard E) once thought that the final part of the kind-had to be a variable k (as in the example above). But it might not be: it could-be an application of a variable. Here is the example:--  let f :: forall (a :: Type) (b :: a -> Type). b (Any @a)-      k :: Type-      x :: k--  flatten (f @Type @((->) k) x)--After instantiating [a |-> Type, b |-> ((->) k)], we see that `b (Any @a)`-is `k -> Any @a`, and thus the third argument of `x :: k` is well-kinded.---}----- This is shared between the flattener and the normaliser in FamInstEnv.--- See Note [simplifyArgsWorker]-{-# INLINE simplifyArgsWorker #-}-simplifyArgsWorker :: [TyCoBinder] -> Kind-                       -- the binders & result kind (not a Π-type) of the function applied to the args-                       -- list of binders can be shorter or longer than the list of args-                   -> TyCoVarSet   -- free vars of the args-                   -> [Role]   -- list of roles, r-                   -> [(Type, Coercion)] -- flattened type arguments, arg-                                         -- each comes with the coercion used to flatten it,-                                         -- with co :: flattened_type ~ original_type-                   -> ([Type], [Coercion], CoercionN)--- Returns (xis, cos, res_co), where each co :: xi ~ arg,--- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args--- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in),--- then (f orig_tys) is well kinded. Note that (f flattened_tys) might *not* be well-kinded.--- Massaging the flattened_tys in order to make (f flattened_tys) well-kinded is what this--- function is all about. That is, (f xis), where xis are the returned arguments, *is*--- well kinded.-simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs-                   orig_roles orig_simplified_args-  = go [] [] orig_lc orig_ki_binders orig_inner_ki orig_roles orig_simplified_args-  where-    orig_lc = emptyLiftingContext $ mkInScopeSet $ orig_fvs--    go :: [Type]      -- Xis accumulator, in reverse order-       -> [Coercion]  -- Coercions accumulator, in reverse order-                      -- These are in 1-to-1 correspondence-       -> LiftingContext  -- mapping from tyvars to flattening coercions-       -> [TyCoBinder]    -- Unsubsted binders of function's kind-       -> Kind        -- Unsubsted result kind of function (not a Pi-type)-       -> [Role]      -- Roles at which to flatten these ...-       -> [(Type, Coercion)]  -- flattened arguments, with their flattening coercions-       -> ([Type], [Coercion], CoercionN)-    go acc_xis acc_cos lc binders inner_ki _ []-      = (reverse acc_xis, reverse acc_cos, kind_co)-      where-        final_kind = mkPiTys binders inner_ki-        kind_co = liftCoSubst Nominal lc final_kind--    go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args)-      = -- By Note [Flattening] in TcFlatten invariant (F2),-         -- tcTypeKind(xi) = tcTypeKind(ty). But, it's possible that xi will be-         -- used as an argument to a function whose kind is different, if-         -- earlier arguments have been flattened to new types. We thus-         -- need a coercion (kind_co :: old_kind ~ new_kind).-         ---         -- The bangs here have been observed to improve performance-         -- significantly in optimized builds.-         let kind_co = mkSymCo $-               liftCoSubst Nominal lc (tyCoBinderType binder)-             !casted_xi = xi `mkCastTy` kind_co-             casted_co =  mkCoherenceLeftCo role xi kind_co co--         -- now, extend the lifting context with the new binding-             !new_lc | Just tv <- tyCoBinderVar_maybe binder-                     = extendLiftingContextAndInScope lc tv casted_co-                     | otherwise-                     = lc-         in-         go (casted_xi : acc_xis)-            (casted_co : acc_cos)-            new_lc-            binders-            inner_ki-            roles-            args---      -- See Note [Last case in simplifyArgsWorker]-    go acc_xis acc_cos lc [] inner_ki roles args-      = let co1 = liftCoSubst Nominal lc inner_ki-            co1_kind              = coercionKind co1-            unflattened_tys       = map (coercionRKind . snd) args-            (arg_cos, res_co)     = decomposePiCos co1 co1_kind unflattened_tys-            casted_args           = ASSERT2( equalLength args arg_cos-                                           , ppr args $$ ppr arg_cos )-                                    [ (casted_xi, casted_co)-                                    | ((xi, co), arg_co, role) <- zip3 args arg_cos roles-                                    , let casted_xi = xi `mkCastTy` arg_co-                                          casted_co = mkCoherenceLeftCo role xi arg_co co ]-               -- In general decomposePiCos can return fewer cos than tys,-               -- but not here; because we're well typed, there will be enough-               -- binders. Note that decomposePiCos does substitutions, so even-               -- if the original substitution results in something ending with-               -- ... -> k, that k will be substituted to perhaps reveal more-               -- binders.-            zapped_lc             = zapLiftingContext lc-            Pair flattened_kind _ = co1_kind-            (bndrs, new_inner)    = splitPiTys flattened_kind--            (xis_out, cos_out, res_co_out)-              = go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_args-        in-        (xis_out, cos_out, res_co_out `mkTransCo` res_co)--    go _ _ _ _ _ _ _ = panic-        "simplifyArgsWorker wandered into deeper water than usual"-           -- This debug information is commented out because leaving it in-           -- causes a ~2% increase in allocations in T9872d.-           -- That's independent of the analogous case in flatten_args_fast-           -- in TcFlatten:-           -- each of these causes a 2% increase on its own, so commenting them-           -- both out gives a 4% decrease in T9872d.-           {---             (vcat [ppr orig_binders,-                    ppr orig_inner_ki,-                    ppr (take 10 orig_roles), -- often infinite!-                    ppr orig_tys])-           -}
− compiler/types/Coercion.hs-boot 
@@ -1,53 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Coercion where--import GhcPrelude--import {-# SOURCE #-} TyCoRep-import {-# SOURCE #-} TyCon--import BasicTypes ( LeftOrRight )-import CoAxiom-import Var-import Pair-import Util--mkReflCo :: Role -> Type -> Coercion-mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion-mkAppCo :: Coercion -> Coercion -> Coercion-mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion-mkFunCo :: Role -> Coercion -> Coercion -> Coercion-mkCoVarCo :: CoVar -> Coercion-mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion-mkPhantomCo :: Coercion -> Type -> Type -> Coercion-mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion-mkSymCo :: Coercion -> Coercion-mkTransCo :: Coercion -> Coercion -> Coercion-mkNthCo :: HasDebugCallStack => Role -> Int -> Coercion -> Coercion-mkLRCo :: LeftOrRight -> Coercion -> Coercion-mkInstCo :: Coercion -> Coercion -> Coercion-mkGReflCo :: Role -> Type -> MCoercionN -> Coercion-mkNomReflCo :: Type -> Coercion-mkKindCo :: Coercion -> Coercion-mkSubCo :: Coercion -> Coercion-mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion-mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion--isGReflCo :: Coercion -> Bool-isReflCo :: Coercion -> Bool-isReflexiveCo :: Coercion -> Bool-decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion)-coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind, Kind, Type, Type, Role)-coVarRole :: CoVar -> Role--mkCoercionType :: Role -> Type -> Type -> Type--data LiftingContext-liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion-seqCo :: Coercion -> ()--coercionKind :: Coercion -> Pair Type-coercionLKind :: Coercion -> Type-coercionRKind :: Coercion -> Type-coercionType :: Coercion -> Type
− compiler/types/FamInstEnv.hs 
@@ -1,1833 +0,0 @@--- (c) The University of Glasgow 2006------ FamInstEnv: Type checked family instance declarations--{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections,-    DeriveFunctor #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--module FamInstEnv (-        FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS,-        famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon,-        pprFamInst, pprFamInsts,-        mkImportedFamInst,--        FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs,-        extendFamInstEnv, extendFamInstEnvList,-        famInstEnvElts, famInstEnvSize, familyInstances,--        -- * CoAxioms-        mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom,-        mkNewTypeCoAxiom,--        FamInstMatch(..),-        lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon,--        isDominatedBy, apartnessCheck,--        -- Injectivity-        InjectivityCheckResult(..),-        lookupFamInstEnvInjectivityConflicts, injectiveBranches,--        -- Normalisation-        topNormaliseType, topNormaliseType_maybe,-        normaliseType, normaliseTcApp, normaliseTcArgs,-        reduceTyFamApp_maybe,--        -- Flattening-        flattenTys-    ) where--#include "HsVersions.h"--import GhcPrelude--import Unify-import Type-import TyCoRep-import TyCon-import Coercion-import CoAxiom-import VarSet-import VarEnv-import Name-import UniqDFM-import Outputable-import Maybes-import GHC.Core.Map-import Unique-import Util-import Var-import SrcLoc-import FastString-import Control.Monad-import Data.List( mapAccumL )-import Data.Array( Array, assocs )--{--************************************************************************-*                                                                      *-          Type checked family instance heads-*                                                                      *-************************************************************************--Note [FamInsts and CoAxioms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* CoAxioms and FamInsts are just like-  DFunIds  and ClsInsts--* A CoAxiom is a System-FC thing: it can relate any two types--* A FamInst is a Haskell source-language thing, corresponding-  to a type/data family instance declaration.-    - The FamInst contains a CoAxiom, which is the evidence-      for the instance--    - The LHS of the CoAxiom is always of form F ty1 .. tyn-      where F is a type family--}--data FamInst  -- See Note [FamInsts and CoAxioms]-  = FamInst { fi_axiom  :: CoAxiom Unbranched -- The new coercion axiom-                                              -- introduced by this family-                                              -- instance-                 -- INVARIANT: apart from freshening (see below)-                 --    fi_tvs = cab_tvs of the (single) axiom branch-                 --    fi_cvs = cab_cvs ...ditto...-                 --    fi_tys = cab_lhs ...ditto...-                 --    fi_rhs = cab_rhs ...ditto...--            , fi_flavor :: FamFlavor--            -- Everything below here is a redundant,-            -- cached version of the two things above-            -- except that the TyVars are freshened-            , fi_fam   :: Name          -- Family name--                -- Used for "rough matching"; same idea as for class instances-                -- See Note [Rough-match field] in InstEnv-            , fi_tcs   :: [Maybe Name]  -- Top of type args-                -- INVARIANT: fi_tcs = roughMatchTcs fi_tys--            -- Used for "proper matching"; ditto-            , fi_tvs :: [TyVar]      -- Template tyvars for full match-            , fi_cvs :: [CoVar]      -- Template covars for full match-                 -- Like ClsInsts, these variables are always fresh-                 -- See Note [Template tyvars are fresh] in InstEnv--            , fi_tys    :: [Type]       --   The LHS type patterns-            -- May be eta-reduced; see Note [Eta reduction for data families]--            , fi_rhs :: Type         --   the RHS, with its freshened vars-            }--data FamFlavor-  = SynFamilyInst         -- A synonym family-  | DataFamilyInst TyCon  -- A data family, with its representation TyCon--{--Note [Arity of data families]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Data family instances might legitimately be over- or under-saturated.--Under-saturation has two potential causes:- U1) Eta reduction. See Note [Eta reduction for data families].- U2) When the user has specified a return kind instead of written out patterns.-     Example:--       data family Sing (a :: k)-       data instance Sing :: Bool -> Type--     The data family tycon Sing has an arity of 2, the k and the a. But-     the data instance has only one pattern, Bool (standing in for k).-     This instance is equivalent to `data instance Sing (a :: Bool)`, but-     without the last pattern, we have an under-saturated data family instance.-     On its own, this example is not compelling enough to add support for-     under-saturation, but U1 makes this feature more compelling.--Over-saturation is also possible:-  O1) If the data family's return kind is a type variable (see also #12369),-      an instance might legitimately have more arguments than the family.-      Example:--        data family Fix :: (Type -> k) -> k-        data instance Fix f = MkFix1 (f (Fix f))-        data instance Fix f x = MkFix2 (f (Fix f x) x)--      In the first instance here, the k in the data family kind is chosen to-      be Type. In the second, it's (Type -> Type).--      However, we require that any over-saturation is eta-reducible. That is,-      we require that any extra patterns be bare unrepeated type variables;-      see Note [Eta reduction for data families]. Accordingly, the FamInst-      is never over-saturated.--Why can we allow such flexibility for data families but not for type families?-Because data families can be decomposed -- that is, they are generative and-injective. A Type family is neither and so always must be applied to all its-arguments.--}---- Obtain the axiom of a family instance-famInstAxiom :: FamInst -> CoAxiom Unbranched-famInstAxiom = fi_axiom---- Split the left-hand side of the FamInst-famInstSplitLHS :: FamInst -> (TyCon, [Type])-famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs })-  = (coAxiomTyCon axiom, lhs)---- Get the RHS of the FamInst-famInstRHS :: FamInst -> Type-famInstRHS = fi_rhs---- Get the family TyCon of the FamInst-famInstTyCon :: FamInst -> TyCon-famInstTyCon = coAxiomTyCon . famInstAxiom---- Return the representation TyCons introduced by data family instances, if any-famInstsRepTyCons :: [FamInst] -> [TyCon]-famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis]---- Extracts the TyCon for this *data* (or newtype) instance-famInstRepTyCon_maybe :: FamInst -> Maybe TyCon-famInstRepTyCon_maybe fi-  = case fi_flavor fi of-       DataFamilyInst tycon -> Just tycon-       SynFamilyInst        -> Nothing--dataFamInstRepTyCon :: FamInst -> TyCon-dataFamInstRepTyCon fi-  = case fi_flavor fi of-       DataFamilyInst tycon -> tycon-       SynFamilyInst        -> pprPanic "dataFamInstRepTyCon" (ppr fi)--{--************************************************************************-*                                                                      *-        Pretty printing-*                                                                      *-************************************************************************--}--instance NamedThing FamInst where-   getName = coAxiomName . fi_axiom--instance Outputable FamInst where-   ppr = pprFamInst--pprFamInst :: FamInst -> SDoc--- Prints the FamInst as a family instance declaration--- NB: This function, FamInstEnv.pprFamInst, is used only for internal,---     debug printing. See GHC.Core.Ppr.TyThing.pprFamInst for printing for the user-pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax-                    , fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs })-  = hang (ppr_tc_sort <+> text "instance"-             <+> pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax))-       2 (whenPprDebug debug_stuff)-  where-    ppr_tc_sort = case flavor of-                     SynFamilyInst             -> text "type"-                     DataFamilyInst tycon-                       | isDataTyCon     tycon -> text "data"-                       | isNewTyCon      tycon -> text "newtype"-                       | isAbstractTyCon tycon -> text "data"-                       | otherwise             -> text "WEIRD" <+> ppr tycon--    debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax-                       , text "Tvs:" <+> ppr tvs-                       , text "LHS:" <+> ppr tys-                       , text "RHS:" <+> ppr rhs ]--pprFamInsts :: [FamInst] -> SDoc-pprFamInsts finsts = vcat (map pprFamInst finsts)--{--Note [Lazy axiom match]-~~~~~~~~~~~~~~~~~~~~~~~-It is Vitally Important that mkImportedFamInst is *lazy* in its axiom-parameter. The axiom is loaded lazily, via a forkM, in GHC.IfaceToCore. Sometime-later, mkImportedFamInst is called using that axiom. However, the axiom-may itself depend on entities which are not yet loaded as of the time-of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the-axiom, a dependency loop spontaneously appears and GHC hangs. The solution-is simply for mkImportedFamInst never, ever to look inside of the axiom-until everything else is good and ready to do so. We can assume that this-readiness has been achieved when some other code pulls on the axiom in the-FamInst. Thus, we pattern match on the axiom lazily (in the where clause,-not in the parameter list) and we assert the consistency of names there-also.--}---- Make a family instance representation from the information found in an--- interface file.  In particular, we get the rough match info from the iface--- (instead of computing it here).-mkImportedFamInst :: Name               -- Name of the family-                  -> [Maybe Name]       -- Rough match info-                  -> CoAxiom Unbranched -- Axiom introduced-                  -> FamInst            -- Resulting family instance-mkImportedFamInst fam mb_tcs axiom-  = FamInst {-      fi_fam    = fam,-      fi_tcs    = mb_tcs,-      fi_tvs    = tvs,-      fi_cvs    = cvs,-      fi_tys    = tys,-      fi_rhs    = rhs,-      fi_axiom  = axiom,-      fi_flavor = flavor }-  where-     -- See Note [Lazy axiom match]-     ~(CoAxBranch { cab_lhs = tys-                  , cab_tvs = tvs-                  , cab_cvs = cvs-                  , cab_rhs = rhs }) = coAxiomSingleBranch axiom--         -- Derive the flavor for an imported FamInst rather disgustingly-         -- Maybe we should store it in the IfaceFamInst?-     flavor = case splitTyConApp_maybe rhs of-                Just (tc, _)-                  | Just ax' <- tyConFamilyCoercion_maybe tc-                  , ax' == axiom-                  -> DataFamilyInst tc-                _ -> SynFamilyInst--{--************************************************************************-*                                                                      *-                FamInstEnv-*                                                                      *-************************************************************************--Note [FamInstEnv]-~~~~~~~~~~~~~~~~~-A FamInstEnv maps a family name to the list of known instances for that family.--The same FamInstEnv includes both 'data family' and 'type family' instances.-Type families are reduced during type inference, but not data families;-the user explains when to use a data family instance by using constructors-and pattern matching.--Nevertheless it is still useful to have data families in the FamInstEnv:-- - For finding overlaps and conflicts-- - For finding the representation type...see FamInstEnv.topNormaliseType-   and its call site in Simplify-- - In standalone deriving instance Eq (T [Int]) we need to find the-   representation type for T [Int]--Note [Varying number of patterns for data family axioms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For data families, the number of patterns may vary between instances.-For example-   data family T a b-   data instance T Int a = T1 a | T2-   data instance T Bool [a] = T3 a--Then we get a data type for each instance, and an axiom:-   data TInt a = T1 a | T2-   data TBoolList a = T3 a--   axiom ax7   :: T Int ~ TInt   -- Eta-reduced-   axiom ax8 a :: T Bool [a] ~ TBoolList a--These two axioms for T, one with one pattern, one with two;-see Note [Eta reduction for data families]--Note [FamInstEnv determinism]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We turn FamInstEnvs into a list in some places that don't directly affect-the ABI. That happens in family consistency checks and when producing output-for `:info`. Unfortunately that nondeterminism is nonlocal and it's hard-to tell what it affects without following a chain of functions. It's also-easy to accidentally make that nondeterminism affect the ABI. Furthermore-the envs should be relatively small, so it should be free to use deterministic-maps here. Testing with nofib and validate detected no difference between-UniqFM and UniqDFM.-See Note [Deterministic UniqFM].--}--type FamInstEnv = UniqDFM FamilyInstEnv  -- Maps a family to its instances-     -- See Note [FamInstEnv]-     -- See Note [FamInstEnv determinism]--type FamInstEnvs = (FamInstEnv, FamInstEnv)-     -- External package inst-env, Home-package inst-env--newtype FamilyInstEnv-  = FamIE [FamInst]     -- The instances for a particular family, in any order--instance Outputable FamilyInstEnv where-  ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs)---- INVARIANTS:---  * The fs_tvs are distinct in each FamInst---      of a range value of the map (so we can safely unify them)--emptyFamInstEnvs :: (FamInstEnv, FamInstEnv)-emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv)--emptyFamInstEnv :: FamInstEnv-emptyFamInstEnv = emptyUDFM--famInstEnvElts :: FamInstEnv -> [FamInst]-famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts]-  -- See Note [FamInstEnv determinism]--famInstEnvSize :: FamInstEnv -> Int-famInstEnvSize = nonDetFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0-  -- It's OK to use nonDetFoldUDFM here since we're just computing the-  -- size.--familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]-familyInstances (pkg_fie, home_fie) fam-  = get home_fie ++ get pkg_fie-  where-    get env = case lookupUDFM env fam of-                Just (FamIE insts) -> insts-                Nothing                      -> []--extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv-extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis--extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv-extendFamInstEnv inst_env-                 ins_item@(FamInst {fi_fam = cls_nm})-  = addToUDFM_C add inst_env cls_nm (FamIE [ins_item])-  where-    add (FamIE items) _ = FamIE (ins_item:items)--{--************************************************************************-*                                                                      *-                Compatibility-*                                                                      *-************************************************************************--Note [Apartness]-~~~~~~~~~~~~~~~~-In dealing with closed type families, we must be able to check that one type-will never reduce to another. This check is called /apartness/. The check-is always between a target (which may be an arbitrary type) and a pattern.-Here is how we do it:--apart(target, pattern) = not (unify(flatten(target), pattern))--where flatten (implemented in flattenTys, below) converts all type-family-applications into fresh variables. (See Note [Flattening].)--Note [Compatibility]-~~~~~~~~~~~~~~~~~~~~-Two patterns are /compatible/ if either of the following conditions hold:-1) The patterns are apart.-2) The patterns unify with a substitution S, and their right hand sides-equal under that substitution.--For open type families, only compatible instances are allowed. For closed-type families, the story is slightly more complicated. Consider the following:--type family F a where-  F Int = Bool-  F a   = Int--g :: Show a => a -> F a-g x = length (show x)--Should that type-check? No. We need to allow for the possibility that 'a'-might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int-only when we can be sure that 'a' is not Int.--To achieve this, after finding a possible match within the equations, we have to-go back to all previous equations and check that, under the-substitution induced by the match, other branches are surely apart. (See-Note [Apartness].) This is similar to what happens with class-instance selection, when we need to guarantee that there is only a match and-no unifiers. The exact algorithm is different here because the-potentially-overlapping group is closed.--As another example, consider this:--type family G x where-  G Int = Bool-  G a   = Double--type family H y--- no instances--Now, we want to simplify (G (H Char)). We can't, because (H Char) might later-simplify to be Int. So, (G (H Char)) is stuck, for now.--While everything above is quite sound, it isn't as expressive as we'd like.-Consider this:--type family J a where-  J Int = Int-  J a   = a--Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if-b is instantiated with Int, but the RHSs coincide there, so it's all OK.--So, the rule is this: when looking up a branch in a closed type family, we-find a branch that matches the target, but then we make sure that the target-is apart from every previous *incompatible* branch. We don't check the-branches that are compatible with the matching branch, because they are either-irrelevant (clause 1 of compatible) or benign (clause 2 of compatible).--Note [Compatibility of eta-reduced axioms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In newtype instances of data families we eta-reduce the axioms,-See Note [Eta reduction for data families] in FamInstEnv. This means that-we sometimes need to test compatibility of two axioms that were eta-reduced to-different degrees, e.g.:---data family D a b c-newtype instance D a Int c = DInt (Maybe a)-  -- D a Int ~ Maybe-  -- lhs = [a, Int]-newtype instance D Bool Int Char = DIntChar Float-  -- D Bool Int Char ~ Float-  -- lhs = [Bool, Int, Char]--These are obviously incompatible. We could detect this by saturating-(eta-expanding) the shorter LHS with fresh tyvars until the lists are of-equal length, but instead we can just remove the tail of the longer list, as-those types will simply unify with the freshly introduced tyvars.--By doing this, in case the LHS are unifiable, the yielded substitution won't-mention the tyvars that appear in the tail we dropped off, and we might try-to test equality RHSes of different kinds, but that's fine since this case-occurs only for data families, where the RHS is a unique tycon and the equality-fails anyway.--}---- See Note [Compatibility]-compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool-compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })-                   (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })-  = let (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2-             -- See Note [Compatibility of eta-reduced axioms]-    in case tcUnifyTysFG (const BindMe) commonlhs1 commonlhs2 of-      SurelyApart -> True-      Unifiable subst-        | Type.substTyAddInScope subst rhs1 `eqType`-          Type.substTyAddInScope subst rhs2-        -> True-      _ -> False---- | Result of testing two type family equations for injectiviy.-data InjectivityCheckResult-   = InjectivityAccepted-    -- ^ Either RHSs are distinct or unification of RHSs leads to unification of-    -- LHSs-   | InjectivityUnified CoAxBranch CoAxBranch-    -- ^ RHSs unify but LHSs don't unify under that substitution.  Relevant for-    -- closed type families where equation after unification might be-    -- overlpapped (in which case it is OK if they don't unify).  Constructor-    -- stores axioms after unification.---- | Check whether two type family axioms don't violate injectivity annotation.-injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch-                  -> InjectivityCheckResult-injectiveBranches injectivity-                  ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })-                  ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })-  -- See Note [Verifying injectivity annotation], case 1.-  = let getInjArgs  = filterByList injectivity-    in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification-       Nothing -> InjectivityAccepted-         -- RHS are different, so equations are injective.-         -- This is case 1A from Note [Verifying injectivity annotation]-       Just subst -> -- RHS unify under a substitution-        let lhs1Subst = Type.substTys subst (getInjArgs lhs1)-            lhs2Subst = Type.substTys subst (getInjArgs lhs2)-        -- If LHSs are equal under the substitution used for RHSs then this pair-        -- of equations does not violate injectivity annotation. If LHSs are not-        -- equal under that substitution then this pair of equations violates-        -- injectivity annotation, but for closed type families it still might-        -- be the case that one LHS after substitution is unreachable.-        in if eqTypes lhs1Subst lhs2Subst  -- check case 1B1 from Note.-           then InjectivityAccepted-           else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1-                                         , cab_rhs = Type.substTy  subst rhs1 })-                                   ( ax2 { cab_lhs = Type.substTys subst lhs2-                                         , cab_rhs = Type.substTy  subst rhs2 })-                -- payload of InjectivityUnified used only for check 1B2, only-                -- for closed type families---- takes a CoAxiom with unknown branch incompatibilities and computes--- the compatibilities--- See Note [Storing compatibility] in CoAxiom-computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch]-computeAxiomIncomps branches-  = snd (mapAccumL go [] branches)-  where-    go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch)-    go prev_brs cur_br-       = (cur_br : prev_brs, new_br)-       where-         new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br }--    mk_incomps :: [CoAxBranch] -> CoAxBranch -> [CoAxBranch]-    mk_incomps prev_brs cur_br-       = filter (not . compatibleBranches cur_br) prev_brs--{--************************************************************************-*                                                                      *-           Constructing axioms-    These functions are here because tidyType / tcUnifyTysFG-    are not available in CoAxiom--    Also computeAxiomIncomps is too sophisticated for CoAxiom-*                                                                      *-************************************************************************--Note [Tidy axioms when we build them]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Like types and classes, we build axioms fully quantified over all-their variables, and tidy them when we build them. For example,-we print out axioms and don't want to print stuff like-    F k k a b = ...-Instead we must tidy those kind variables.  See #7524.--We could instead tidy when we print, but that makes it harder to get-things like injectivity errors to come out right. Danger of-     Type family equation violates injectivity annotation.-     Kind variable ‘k’ cannot be inferred from the right-hand side.-     In the type family equation:-        PolyKindVars @[k1] @[k2] ('[] @k1) = '[] @k2--Note [Always number wildcard types in CoAxBranch]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the following example (from the DataFamilyInstanceLHS test case):--  data family Sing (a :: k)-  data instance Sing (_ :: MyKind) where-      SingA :: Sing A-      SingB :: Sing B--If we're not careful during tidying, then when this program is compiled with--ddump-types, we'll get the following information:--  COERCION AXIOMS-    axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 ::-      Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _--It's misleading to have a wildcard type appearing on the RHS like-that. To avoid this issue, when building a CoAxiom (which is what eventually-gets printed above), we tidy all the variables in an env that already contains-'_'. Thus, any variable named '_' will be renamed, giving us the nicer output-here:--  COERCION AXIOMS-    axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 ::-      Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1--Which is at least legal syntax.--See also Note [CoAxBranch type variables] in CoAxiom; note that we-are tidying (changing OccNames only), not freshening, in accordance with-that Note.--}---- all axiom roles are Nominal, as this is only used with type families-mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars-             -> [TyVar] -- Extra eta tyvars-             -> [CoVar] -- possibly stale covars-             -> [Type]  -- LHS patterns-             -> Type    -- RHS-             -> [Role]-             -> SrcSpan-             -> CoAxBranch-mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc-  = CoAxBranch { cab_tvs     = tvs'-               , cab_eta_tvs = eta_tvs'-               , cab_cvs     = cvs'-               , cab_lhs     = tidyTypes env lhs-               , cab_roles   = roles-               , cab_rhs     = tidyType env rhs-               , cab_loc     = loc-               , cab_incomps = placeHolderIncomps }-  where-    (env1, tvs')     = tidyVarBndrs init_tidy_env tvs-    (env2, eta_tvs') = tidyVarBndrs env1          eta_tvs-    (env,  cvs')     = tidyVarBndrs env2          cvs-    -- See Note [Tidy axioms when we build them]-    -- See also Note [CoAxBranch type variables] in CoAxiom--    init_occ_env = initTidyOccEnv [mkTyVarOcc "_"]-    init_tidy_env = mkEmptyTidyEnv init_occ_env-    -- See Note [Always number wildcard types in CoAxBranch]---- all of the following code is here to avoid mutual dependencies with--- Coercion-mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched-mkBranchedCoAxiom ax_name fam_tc branches-  = CoAxiom { co_ax_unique   = nameUnique ax_name-            , co_ax_name     = ax_name-            , co_ax_tc       = fam_tc-            , co_ax_role     = Nominal-            , co_ax_implicit = False-            , co_ax_branches = manyBranches (computeAxiomIncomps branches) }--mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched-mkUnbranchedCoAxiom ax_name fam_tc branch-  = CoAxiom { co_ax_unique   = nameUnique ax_name-            , co_ax_name     = ax_name-            , co_ax_tc       = fam_tc-            , co_ax_role     = Nominal-            , co_ax_implicit = False-            , co_ax_branches = unbranched (branch { cab_incomps = [] }) }--mkSingleCoAxiom :: Role -> Name-                -> [TyVar] -> [TyVar] -> [CoVar]-                -> TyCon -> [Type] -> Type-                -> CoAxiom Unbranched--- Make a single-branch CoAxiom, including making the branch itself--- Used for both type family (Nominal) and data family (Representational)--- axioms, hence passing in the Role-mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty-  = CoAxiom { co_ax_unique   = nameUnique ax_name-            , co_ax_name     = ax_name-            , co_ax_tc       = fam_tc-            , co_ax_role     = role-            , co_ax_implicit = False-            , co_ax_branches = unbranched (branch { cab_incomps = [] }) }-  where-    branch = mkCoAxBranch tvs eta_tvs cvs lhs_tys rhs_ty-                          (map (const Nominal) tvs)-                          (getSrcSpan ax_name)---- | Create a coercion constructor (axiom) suitable for the given---   newtype 'TyCon'. The 'Name' should be that of a new coercion---   'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and---   the type the appropriate right hand side of the @newtype@, with---   the free variables a subset of those 'TyVar's.-mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched-mkNewTypeCoAxiom name tycon tvs roles rhs_ty-  = CoAxiom { co_ax_unique   = nameUnique name-            , co_ax_name     = name-            , co_ax_implicit = True  -- See Note [Implicit axioms] in TyCon-            , co_ax_role     = Representational-            , co_ax_tc       = tycon-            , co_ax_branches = unbranched (branch { cab_incomps = [] }) }-  where-    branch = mkCoAxBranch tvs [] [] (mkTyVarTys tvs) rhs_ty-                          roles (getSrcSpan name)--{--************************************************************************-*                                                                      *-                Looking up a family instance-*                                                                      *-************************************************************************--@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.-Multiple matches are only possible in case of type families (not data-families), and then, it doesn't matter which match we choose (as the-instances are guaranteed confluent).--We return the matching family instances and the type instance at which it-matches.  For example, if we lookup 'T [Int]' and have a family instance--  data instance T [a] = ..--desugared to--  data :R42T a = ..-  coe :Co:R42T a :: T [a] ~ :R42T a--we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'.--}---- when matching a type family application, we get a FamInst,--- and the list of types the axiom should be applied to-data FamInstMatch = FamInstMatch { fim_instance :: FamInst-                                 , fim_tys      :: [Type]-                                 , fim_cos      :: [Coercion]-                                 }-  -- See Note [Over-saturated matches]--instance Outputable FamInstMatch where-  ppr (FamInstMatch { fim_instance = inst-                    , fim_tys      = tys-                    , fim_cos      = cos })-    = text "match with" <+> parens (ppr inst) <+> ppr tys <+> ppr cos--lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst]-lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc-  = get pkg_ie ++ get home_ie-  where-    get ie = case lookupUDFM ie fam_tc of-               Nothing          -> []-               Just (FamIE fis) -> fis--lookupFamInstEnv-    :: FamInstEnvs-    -> TyCon -> [Type]          -- What we are looking for-    -> [FamInstMatch]           -- Successful matches--- Precondition: the tycon is saturated (or over-saturated)--lookupFamInstEnv-   = lookup_fam_inst_env match-   where-     match _ _ tpl_tys tys = tcMatchTys tpl_tys tys--lookupFamInstEnvConflicts-    :: FamInstEnvs-    -> FamInst          -- Putative new instance-    -> [FamInstMatch]   -- Conflicting matches (don't look at the fim_tys field)--- E.g. when we are about to add---    f : type instance F [a] = a->a--- we do (lookupFamInstConflicts f [b])--- to find conflicting matches------ Precondition: the tycon is saturated (or over-saturated)--lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom })-  = lookup_fam_inst_env my_unify envs fam tys-  where-    (fam, tys) = famInstSplitLHS fam_inst-        -- In example above,   fam tys' = F [b]--    my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _-       = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs,-                  (ppr fam <+> ppr tys) $$-                  (ppr tpl_tvs <+> ppr tpl_tys) )-                -- Unification will break badly if the variables overlap-                -- They shouldn't because we allocate separate uniques for them-         if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch-           then Nothing-           else Just noSubst-      -- Note [Family instance overlap conflicts]--    noSubst = panic "lookupFamInstEnvConflicts noSubst"-    new_branch = coAxiomSingleBranch new_axiom-------------------------------------------------------------------------------------                 Type family injectivity checking bits                      -------------------------------------------------------------------------------------{- Note [Verifying injectivity annotation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Injectivity means that the RHS of a type family uniquely determines the LHS (see-Note [Type inference for type families with injectivity]).  The user informs us about-injectivity using an injectivity annotation and it is GHC's task to verify that-this annotation is correct w.r.t. type family equations. Whenever we see a new-equation of a type family we need to make sure that adding this equation to the-already known equations of a type family does not violate the injectivity annotation-supplied by the user (see Note [Injectivity annotation]).  Of course if the type-family has no injectivity annotation then no check is required.  But if a type-family has injectivity annotation we need to make sure that the following-conditions hold:--1. For each pair of *different* equations of a type family, one of the following-   conditions holds:--   A:  RHSs are different. (Check done in FamInstEnv.injectiveBranches)--   B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution-       then it must be possible to unify the LHSs under the same substitution.-       Example:--          type family FunnyId a = r | r -> a-          type instance FunnyId Int = Int-          type instance FunnyId a = a--       RHSs of these two equations unify under [ a |-> Int ] substitution.-       Under this substitution LHSs are equal therefore these equations don't-       violate injectivity annotation. (Check done in FamInstEnv.injectiveBranches)--   B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some-       substitution then either the LHSs unify under the same substitution or-       the LHS of the latter equation is overlapped by earlier equations.-       Example 1:--          type family SwapIntChar a = r | r -> a where-              SwapIntChar Int  = Char-              SwapIntChar Char = Int-              SwapIntChar a    = a--       Say we are checking the last two equations. RHSs unify under [ a |->-       Int ] substitution but LHSs don't. So we apply the substitution to LHS-       of last equation and check whether it is overlapped by any of previous-       equations. Since it is overlapped by the first equation we conclude-       that pair of last two equations does not violate injectivity-       annotation. (Check done in TcValidity.checkValidCoAxiom#gather_conflicts)--   A special case of B is when RHSs unify with an empty substitution ie. they-   are identical.--   If any of the above two conditions holds we conclude that the pair of-   equations does not violate injectivity annotation. But if we find a pair-   of equations where neither of the above holds we report that this pair-   violates injectivity annotation because for a given RHS we don't have a-   unique LHS. (Note that (B) actually implies (A).)--   Note that we only take into account these LHS patterns that were declared-   as injective.--2. If an RHS of a type family equation is a bare type variable then-   all LHS variables (including implicit kind variables) also have to be bare.-   In other words, this has to be a sole equation of that type family and it has-   to cover all possible patterns.  So for example this definition will be-   rejected:--      type family W1 a = r | r -> a-      type instance W1 [a] = a--   If it were accepted we could call `W1 [W1 Int]`, which would reduce to-   `W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`,-   which is bogus. Checked FamInst.bareTvInRHSViolated.--3. If the RHS of a type family equation is a type family application then the type-   family is rejected as not injective. This is checked by FamInst.isTFHeaded.--4. If a LHS type variable that is declared as injective is not mentioned in an-   injective position in the RHS then the type family is rejected as not-   injective.  "Injective position" means either an argument to a type-   constructor or argument to a type family on injective position.-   There are subtleties here. See Note [Coverage condition for injective type families]-   in FamInst.--Check (1) must be done for all family instances (transitively) imported. Other-checks (2-4) should be done just for locally written equations, as they are checks-involving just a single equation, not about interactions. Doing the other checks for-imported equations led to #17405, as the behavior of check (4) depends on--XUndecidableInstances (see Note [Coverage condition for injective type families] in-FamInst), which may vary between modules.--See also Note [Injective type families] in TyCon--}----- | Check whether an open type family equation can be added to already existing--- instance environment without causing conflicts with supplied injectivity--- annotations.  Returns list of conflicting axioms (type instance--- declarations).-lookupFamInstEnvInjectivityConflicts-    :: [Bool]         -- injectivity annotation for this type family instance-                      -- INVARIANT: list contains at least one True value-    ->  FamInstEnvs   -- all type instances seens so far-    ->  FamInst       -- new type instance that we're checking-    -> [CoAxBranch]   -- conflicting instance declarations-lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie)-                             fam_inst@(FamInst { fi_axiom = new_axiom })-  -- See Note [Verifying injectivity annotation]. This function implements-  -- check (1.B1) for open type families described there.-  = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie-    where-      fam        = famInstTyCon fam_inst-      new_branch = coAxiomSingleBranch new_axiom--      -- filtering function used by `lookup_inj_fam_conflicts` to check whether-      -- a pair of equations conflicts with the injectivity annotation.-      isInjConflict (FamInst { fi_axiom = old_axiom })-          | InjectivityAccepted <--            injectiveBranches injList (coAxiomSingleBranch old_axiom) new_branch-          = False -- no conflict-          | otherwise = True--      lookup_inj_fam_conflicts ie-          | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie fam-          = map (coAxiomSingleBranch . fi_axiom) $-            filter isInjConflict insts-          | otherwise = []--------------------------------------------------------------------------------------                    Type family overlap checking bits                       -------------------------------------------------------------------------------------{--Note [Family instance overlap conflicts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-- In the case of data family instances, any overlap is fundamentally a-  conflict (as these instances imply injective type mappings).--- In the case of type family instances, overlap is admitted as long as-  the right-hand sides of the overlapping rules coincide under the-  overlap substitution.  eg-       type instance F a Int = a-       type instance F Int b = b-  These two overlap on (F Int Int) but then both RHSs are Int,-  so all is well. We require that they are syntactically equal;-  anything else would be difficult to test for at this stage.--}----------------------------------------------------------------- Might be a one-way match or a unifier-type MatchFun =  FamInst                -- The FamInst template-              -> TyVarSet -> [Type]     --   fi_tvs, fi_tys of that FamInst-              -> [Type]                 -- Target to match against-              -> Maybe TCvSubst--lookup_fam_inst_env'          -- The worker, local to this module-    :: MatchFun-    -> FamInstEnv-    -> TyCon -> [Type]        -- What we are looking for-    -> [FamInstMatch]-lookup_fam_inst_env' match_fun ie fam match_tys-  | isOpenFamilyTyCon fam-  , Just (FamIE insts) <- lookupUDFM ie fam-  = find insts    -- The common case-  | otherwise = []-  where--    find [] = []-    find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs-                        , fi_tys = tpl_tys }) : rest)-        -- Fast check for no match, uses the "rough match" fields-      | instanceCantMatch rough_tcs mb_tcs-      = find rest--        -- Proper check-      | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1-      = (FamInstMatch { fim_instance = item-                      , fim_tys      = substTyVars subst tpl_tvs `chkAppend` match_tys2-                      , fim_cos      = ASSERT( all (isJust . lookupCoVar subst) tpl_cvs )-                                       substCoVars subst tpl_cvs-                      })-        : find rest--        -- No match => try next-      | otherwise-      = find rest-      where-        (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys--      -- Precondition: the tycon is saturated (or over-saturated)--    -- Deal with over-saturation-    -- See Note [Over-saturated matches]-    split_tys tpl_tys-      | isTypeFamilyTyCon fam-      = pre_rough_split_tys--      | otherwise-      = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys-            rough_tcs = roughMatchTcs match_tys1-        in (rough_tcs, match_tys1, match_tys2)--    (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys-    pre_rough_split_tys-      = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2)--lookup_fam_inst_env           -- The worker, local to this module-    :: MatchFun-    -> FamInstEnvs-    -> TyCon -> [Type]        -- What we are looking for-    -> [FamInstMatch]         -- Successful matches---- Precondition: the tycon is saturated (or over-saturated)--lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys-  =  lookup_fam_inst_env' match_fun home_ie fam tys-  ++ lookup_fam_inst_env' match_fun pkg_ie  fam tys--{--Note [Over-saturated matches]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's ok to look up an over-saturated type constructor.  E.g.-     type family F a :: * -> *-     type instance F (a,b) = Either (a->b)--The type instance gives rise to a newtype TyCon (at a higher kind-which you can't do in Haskell!):-     newtype FPair a b = FP (Either (a->b))--Then looking up (F (Int,Bool) Char) will return a FamInstMatch-     (FPair, [Int,Bool,Char])-The "extra" type argument [Char] just stays on the end.--We handle data families and type families separately here:-- * For type families, all instances of a type family must have the-   same arity, so we can precompute the split between the match_tys-   and the overflow tys. This is done in pre_rough_split_tys.-- * For data family instances, though, we need to re-split for each-   instance, because the breakdown might be different for each-   instance.  Why?  Because of eta reduction; see-   Note [Eta reduction for data families].--}---- checks if one LHS is dominated by a list of other branches--- in other words, if an application would match the first LHS, it is guaranteed--- to match at least one of the others. The RHSs are ignored.--- This algorithm is conservative:---   True -> the LHS is definitely covered by the others---   False -> no information--- It is currently (Oct 2012) used only for generating errors for--- inaccessible branches. If these errors go unreported, no harm done.--- This is defined here to avoid a dependency from CoAxiom to Unify-isDominatedBy :: CoAxBranch -> [CoAxBranch] -> Bool-isDominatedBy branch branches-  = or $ map match branches-    where-      lhs = coAxBranchLHS branch-      match (CoAxBranch { cab_lhs = tys })-        = isJust $ tcMatchTys tys lhs--{--************************************************************************-*                                                                      *-                Choosing an axiom application-*                                                                      *-************************************************************************--The lookupFamInstEnv function does a nice job for *open* type families,-but we also need to handle closed ones when normalising a type:--}--reduceTyFamApp_maybe :: FamInstEnvs-                     -> Role              -- Desired role of result coercion-                     -> TyCon -> [Type]-                     -> Maybe (Coercion, Type)--- Attempt to do a *one-step* reduction of a type-family application---    but *not* newtypes--- Works on type-synonym families always; data-families only if---     the role we seek is representational--- It does *not* normalise the type arguments first, so this may not---     go as far as you want. If you want normalised type arguments,---     use normaliseTcArgs first.------ The TyCon can be oversaturated.--- Works on both open and closed families------ Always returns a *homogeneous* coercion -- type family reductions are always--- homogeneous-reduceTyFamApp_maybe envs role tc tys-  | Phantom <- role-  = Nothing--  | case role of-      Representational -> isOpenFamilyTyCon     tc-      _                -> isOpenTypeFamilyTyCon tc-       -- If we seek a representational coercion-       -- (e.g. the call in topNormaliseType_maybe) then we can-       -- unwrap data families as well as type-synonym families;-       -- otherwise only type-synonym families-  , FamInstMatch { fim_instance = FamInst { fi_axiom = ax }-                 , fim_tys      = inst_tys-                 , fim_cos      = inst_cos } : _ <- lookupFamInstEnv envs tc tys-      -- NB: Allow multiple matches because of compatible overlap--  = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos-        ty = coercionRKind co-    in Just (co, ty)--  | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc-  , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys-  = let co = mkAxInstCo role ax ind inst_tys inst_cos-        ty = coercionRKind co-    in Just (co, ty)--  | Just ax           <- isBuiltInSynFamTyCon_maybe tc-  , Just (coax,ts,ty) <- sfMatchFam ax tys-  = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)-    in Just (co, ty)--  | otherwise-  = Nothing---- The axiom can be oversaturated. (Closed families only.)-chooseBranch :: CoAxiom Branched -> [Type]-             -> Maybe (BranchIndex, [Type], [Coercion])  -- found match, with args-chooseBranch axiom tys-  = do { let num_pats = coAxiomNumPats axiom-             (target_tys, extra_tys) = splitAt num_pats tys-             branches = coAxiomBranches axiom-       ; (ind, inst_tys, inst_cos)-           <- findBranch (unMkBranches branches) target_tys-       ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) }---- The axiom must *not* be oversaturated-findBranch :: Array BranchIndex CoAxBranch-           -> [Type]-           -> Maybe (BranchIndex, [Type], [Coercion])-    -- coercions relate requested types to returned axiom LHS at role N-findBranch branches target_tys-  = foldr go Nothing (assocs branches)-  where-    go :: (BranchIndex, CoAxBranch)-       -> Maybe (BranchIndex, [Type], [Coercion])-       -> Maybe (BranchIndex, [Type], [Coercion])-    go (index, branch) other-      = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs-                        , cab_lhs = tpl_lhs-                        , cab_incomps = incomps }) = branch-            in_scope = mkInScopeSet (unionVarSets $-                            map (tyCoVarsOfTypes . coAxBranchLHS) incomps)-            -- See Note [Flattening] below-            flattened_target = flattenTys in_scope target_tys-        in case tcMatchTys tpl_lhs target_tys of-        Just subst -- matching worked. now, check for apartness.-          |  apartnessCheck flattened_target branch-          -> -- matching worked & we're apart from all incompatible branches.-             -- success-             ASSERT( all (isJust . lookupCoVar subst) tpl_cvs )-             Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs)--        -- failure. keep looking-        _ -> other---- | Do an apartness check, as described in the "Closed Type Families" paper--- (POPL '14). This should be used when determining if an equation--- ('CoAxBranch') of a closed type family can be used to reduce a certain target--- type family application.-apartnessCheck :: [Type]     -- ^ /flattened/ target arguments. Make sure-                             -- they're flattened! See Note [Flattening].-                             -- (NB: This "flat" is a different-                             -- "flat" than is used in TcFlatten.)-               -> CoAxBranch -- ^ the candidate equation we wish to use-                             -- Precondition: this matches the target-               -> Bool       -- ^ True <=> equation can fire-apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps })-  = all (isSurelyApart-         . tcUnifyTysFG (const BindMe) flattened_target-         . coAxBranchLHS) incomps-  where-    isSurelyApart SurelyApart = True-    isSurelyApart _           = False--{--************************************************************************-*                                                                      *-                Looking up a family instance-*                                                                      *-************************************************************************--Note [Normalising types]-~~~~~~~~~~~~~~~~~~~~~~~~-The topNormaliseType function removes all occurrences of type families-and newtypes from the top-level structure of a type. normaliseTcApp does-the type family lookup and is fairly straightforward. normaliseType is-a little more involved.--The complication comes from the fact that a type family might be used in the-kind of a variable bound in a forall. We wish to remove this type family-application, but that means coming up with a fresh variable (with the new-kind). Thus, we need a substitution to be built up as we recur through the-type. However, an ordinary TCvSubst just won't do: when we hit a type variable-whose kind has changed during normalisation, we need both the new type-variable *and* the coercion. We could conjure up a new VarEnv with just this-property, but a usable substitution environment already exists:-LiftingContexts from the liftCoSubst family of functions, defined in Coercion.-A LiftingContext maps a type variable to a coercion and a coercion variable to-a pair of coercions. Let's ignore coercion variables for now. Because the-coercion a type variable maps to contains the destination type (via-coercionKind), we don't need to store that destination type separately. Thus,-a LiftingContext has what we need: a map from type variables to (Coercion,-Type) pairs.--We also benefit because we can piggyback on the liftCoSubstVarBndr function to-deal with binders. However, I had to modify that function to work with this-application. Thus, we now have liftCoSubstVarBndrUsing, which takes-a function used to process the kind of the binder. We don't wish-to lift the kind, but instead normalise it. So, we pass in a callback function-that processes the kind of the binder.--After that brilliant explanation of all this, I'm sure you've forgotten the-dangling reference to coercion variables. What do we do with those? Nothing at-all. The point of normalising types is to remove type family applications, but-there's no sense in removing these from coercions. We would just get back a-new coercion witnessing the equality between the same types as the original-coercion. Because coercions are irrelevant anyway, there is no point in doing-this. So, whenever we encounter a coercion, we just say that it won't change.-That's what the CoercionTy case is doing within normalise_type.--Note [Normalisation and type synonyms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to be a bit careful about normalising in the presence of type-synonyms (#13035).  Suppose S is a type synonym, and we have-   S t1 t2-If S is family-free (on its RHS) we can just normalise t1 and t2 and-reconstruct (S t1' t2').   Expanding S could not reveal any new redexes-because type families are saturated.--But if S has a type family on its RHS we expand /before/ normalising-the args t1, t2.  If we normalise t1, t2 first, we'll re-normalise them-after expansion, and that can lead to /exponential/ behaviour; see #13035.--Notice, though, that expanding first can in principle duplicate t1,t2,-which might contain redexes. I'm sure you could conjure up an exponential-case by that route too, but it hasn't happened in practice yet!--}--topNormaliseType :: FamInstEnvs -> Type -> Type-topNormaliseType env ty = case topNormaliseType_maybe env ty of-                            Just (_co, ty') -> ty'-                            Nothing         -> ty--topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type)---- ^ Get rid of *outermost* (or toplevel)---      * type function redex---      * data family redex---      * newtypes--- returning an appropriate Representational coercion.  Specifically, if---   topNormaliseType_maybe env ty = Just (co, ty')--- then---   (a) co :: ty ~R ty'---   (b) ty' is not a newtype, and is not a type-family or data-family redex------ However, ty' can be something like (Maybe (F ty)), where--- (F ty) is a redex.------ Always operates homogeneously: the returned type has the same kind as the--- original type, and the returned coercion is always homogeneous.-topNormaliseType_maybe env ty-  = do { ((co, mkind_co), nty) <- topNormaliseTypeX stepper combine ty-       ; return $ case mkind_co of-           MRefl       -> (co, nty)-           MCo kind_co -> let nty_casted = nty `mkCastTy` mkSymCo kind_co-                              final_co   = mkCoherenceRightCo Representational nty-                                                              (mkSymCo kind_co) co-                          in (final_co, nty_casted) }-  where-    stepper = unwrapNewTypeStepper' `composeSteppers` tyFamStepper--    combine (c1, mc1) (c2, mc2) = (c1 `mkTransCo` c2, mc1 `mkTransMCo` mc2)--    unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN)-    unwrapNewTypeStepper' rec_nts tc tys-      = mapStepResult (, MRefl) $ unwrapNewTypeStepper rec_nts tc tys--      -- second coercion below is the kind coercion relating the original type's kind-      -- to the normalised type's kind-    tyFamStepper :: NormaliseStepper (Coercion, MCoercionN)-    tyFamStepper rec_nts tc tys  -- Try to step a type/data family-      = let (args_co, ntys, res_co) = normaliseTcArgs env Representational tc tys in-        case reduceTyFamApp_maybe env Representational tc ntys of-          Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co, MCo res_co)-          _              -> NS_Done------------------normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type)--- See comments on normaliseType for the arguments of this function-normaliseTcApp env role tc tys-  = initNormM env role (tyCoVarsOfTypes tys) $-    normalise_tc_app tc tys---- See Note [Normalising types] about the LiftingContext-normalise_tc_app :: TyCon -> [Type] -> NormM (Coercion, Type)-normalise_tc_app tc tys-  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys-  , not (isFamFreeTyCon tc)  -- Expand and try again-  = -- A synonym with type families in the RHS-    -- Expand and try again-    -- See Note [Normalisation and type synonyms]-    normalise_type (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')--  | isFamilyTyCon tc-  = -- A type-family application-    do { env <- getEnv-       ; role <- getRole-       ; (args_co, ntys, res_co) <- normalise_tc_args tc tys-       ; case reduceTyFamApp_maybe env role tc ntys of-           Just (first_co, ty')-             -> do { (rest_co,nty) <- normalise_type ty'-                   ; return (assemble_result role nty-                                             (args_co `mkTransCo` first_co `mkTransCo` rest_co)-                                             res_co) }-           _ -> -- No unique matching family instance exists;-                -- we do not do anything-                return (assemble_result role (mkTyConApp tc ntys) args_co res_co) }--  | otherwise-  = -- A synonym with no type families in the RHS; or data type etc-    -- Just normalise the arguments and rebuild-    do { (args_co, ntys, res_co) <- normalise_tc_args tc tys-       ; role <- getRole-       ; return (assemble_result role (mkTyConApp tc ntys) args_co res_co) }--  where-    assemble_result :: Role       -- r, ambient role in NormM monad-                    -> Type       -- nty, result type, possibly of changed kind-                    -> Coercion   -- orig_ty ~r nty, possibly heterogeneous-                    -> CoercionN  -- typeKind(orig_ty) ~N typeKind(nty)-                    -> (Coercion, Type)   -- (co :: orig_ty ~r nty_casted, nty_casted)-                                          -- where nty_casted has same kind as orig_ty-    assemble_result r nty orig_to_nty kind_co-      = ( final_co, nty_old_kind )-      where-        nty_old_kind = nty `mkCastTy` mkSymCo kind_co-        final_co     = mkCoherenceRightCo r nty (mkSymCo kind_co) orig_to_nty-------------------- | Normalise arguments to a tycon-normaliseTcArgs :: FamInstEnvs          -- ^ env't with family instances-                -> Role                 -- ^ desired role of output coercion-                -> TyCon                -- ^ tc-                -> [Type]               -- ^ tys-                -> (Coercion, [Type], CoercionN)-                                        -- ^ co :: tc tys ~ tc new_tys-                                        -- NB: co might not be homogeneous-                                        -- last coercion :: kind(tc tys) ~ kind(tc new_tys)-normaliseTcArgs env role tc tys-  = initNormM env role (tyCoVarsOfTypes tys) $-    normalise_tc_args tc tys--normalise_tc_args :: TyCon -> [Type]             -- tc tys-                  -> NormM (Coercion, [Type], CoercionN)-                  -- (co, new_tys), where-                  -- co :: tc tys ~ tc new_tys; might not be homogeneous-                  -- res_co :: typeKind(tc tys) ~N typeKind(tc new_tys)-normalise_tc_args tc tys-  = do { role <- getRole-       ; (args_cos, nargs, res_co) <- normalise_args (tyConKind tc) (tyConRolesX role tc) tys-       ; return (mkTyConAppCo role tc args_cos, nargs, res_co) }------------------normaliseType :: FamInstEnvs-              -> Role  -- desired role of coercion-              -> Type -> (Coercion, Type)-normaliseType env role ty-  = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty--normalise_type :: Type                     -- old type-               -> NormM (Coercion, Type)   -- (coercion, new type), where-                                           -- co :: old-type ~ new_type--- Normalise the input type, by eliminating *all* type-function redexes--- but *not* newtypes (which are visible to the programmer)--- Returns with Refl if nothing happens--- Does nothing to newtypes--- The returned coercion *must* be *homogeneous*--- See Note [Normalising types]--- Try not to disturb type synonyms if possible--normalise_type ty-  = go ty-  where-    go (TyConApp tc tys) = normalise_tc_app tc tys-    go ty@(LitTy {})     = do { r <- getRole-                              ; return (mkReflCo r ty, ty) }--    go (AppTy ty1 ty2) = go_app_tys ty1 [ty2]--    go ty@(FunTy { ft_arg = ty1, ft_res = ty2 })-      = do { (co1, nty1) <- go ty1-           ; (co2, nty2) <- go ty2-           ; r <- getRole-           ; return (mkFunCo r co1 co2, ty { ft_arg = nty1, ft_res = nty2 }) }-    go (ForAllTy (Bndr tcvar vis) ty)-      = do { (lc', tv', h, ki') <- normalise_var_bndr tcvar-           ; (co, nty)          <- withLC lc' $ normalise_type ty-           ; let tv2 = setTyVarKind tv' ki'-           ; return (mkForAllCo tv' h co, ForAllTy (Bndr tv2 vis) nty) }-    go (TyVarTy tv)    = normalise_tyvar tv-    go (CastTy ty co)-      = do { (nco, nty) <- go ty-           ; lc <- getLC-           ; let co' = substRightCo lc co-           ; return (castCoercionKind nco Nominal ty nty co co'-                    , mkCastTy nty co') }-    go (CoercionTy co)-      = do { lc <- getLC-           ; r <- getRole-           ; let right_co = substRightCo lc co-           ; return ( mkProofIrrelCo r-                         (liftCoSubst Nominal lc (coercionType co))-                         co right_co-                    , mkCoercionTy right_co ) }--    go_app_tys :: Type   -- function-               -> [Type] -- args-               -> NormM (Coercion, Type)-    -- cf. TcFlatten.flatten_app_ty_args-    go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys)-    go_app_tys fun_ty arg_tys-      = do { (fun_co, nfun) <- go fun_ty-           ; case tcSplitTyConApp_maybe nfun of-               Just (tc, xis) ->-                 do { (second_co, nty) <- go (mkTyConApp tc (xis ++ arg_tys))-                   -- flatten_app_ty_args avoids redundantly processing the xis,-                   -- but that's a much more performance-sensitive function.-                   -- This type normalisation is not called in a loop.-                    ; return (mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransCo` second_co, nty) }-               Nothing ->-                 do { (args_cos, nargs, res_co) <- normalise_args (typeKind nfun)-                                                                  (repeat Nominal)-                                                                  arg_tys-                    ; role <- getRole-                    ; let nty = mkAppTys nfun nargs-                          nco = mkAppCos fun_co args_cos-                          nty_casted = nty `mkCastTy` mkSymCo res_co-                          final_co = mkCoherenceRightCo role nty (mkSymCo res_co) nco-                    ; return (final_co, nty_casted) } }--normalise_args :: Kind    -- of the function-               -> [Role]  -- roles at which to normalise args-               -> [Type]  -- args-               -> NormM ([Coercion], [Type], Coercion)--- returns (cos, xis, res_co), where each xi is the normalised--- version of the corresponding type, each co is orig_arg ~ xi,--- and the res_co :: kind(f orig_args) ~ kind(f xis)--- NB: The xis might *not* have the same kinds as the input types,--- but the resulting application *will* be well-kinded--- cf. TcFlatten.flatten_args_slow-normalise_args fun_ki roles args-  = do { normed_args <- zipWithM normalise1 roles args-       ; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args-       ; return (map mkSymCo cos, xis, mkSymCo res_co) }-  where-    (ki_binders, inner_ki) = splitPiTys fun_ki-    fvs = tyCoVarsOfTypes args--    -- flattener conventions are different from ours-    impedance_match :: NormM (Coercion, Type) -> NormM (Type, Coercion)-    impedance_match action = do { (co, ty) <- action-                                ; return (ty, mkSymCo co) }--    normalise1 role ty-      = impedance_match $ withRole role $ normalise_type ty--normalise_tyvar :: TyVar -> NormM (Coercion, Type)-normalise_tyvar tv-  = ASSERT( isTyVar tv )-    do { lc <- getLC-       ; r  <- getRole-       ; return $ case liftCoSubstTyVar lc r tv of-           Just co -> (co, coercionRKind co)-           Nothing -> (mkReflCo r ty, ty) }-  where ty = mkTyVarTy tv--normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Coercion, Kind)-normalise_var_bndr tcvar-  -- works for both tvar and covar-  = do { lc1 <- getLC-       ; env <- getEnv-       ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal-       ; return $ liftCoSubstVarBndrUsing callback lc1 tcvar }---- | a monad for the normalisation functions, reading 'FamInstEnvs',--- a 'LiftingContext', and a 'Role'.-newtype NormM a = NormM { runNormM ::-                            FamInstEnvs -> LiftingContext -> Role -> a }-    deriving (Functor)--initNormM :: FamInstEnvs -> Role-          -> TyCoVarSet   -- the in-scope variables-          -> NormM a -> a-initNormM env role vars (NormM thing_inside)-  = thing_inside env lc role-  where-    in_scope = mkInScopeSet vars-    lc       = emptyLiftingContext in_scope--getRole :: NormM Role-getRole = NormM (\ _ _ r -> r)--getLC :: NormM LiftingContext-getLC = NormM (\ _ lc _ -> lc)--getEnv :: NormM FamInstEnvs-getEnv = NormM (\ env _ _ -> env)--withRole :: Role -> NormM a -> NormM a-withRole r thing = NormM $ \ envs lc _old_r -> runNormM thing envs lc r--withLC :: LiftingContext -> NormM a -> NormM a-withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r--instance Monad NormM where-  ma >>= fmb = NormM $ \env lc r ->-               let a = runNormM ma env lc r in-               runNormM (fmb a) env lc r--instance Applicative NormM where-  pure x = NormM $ \ _ _ _ -> x-  (<*>)  = ap--{--************************************************************************-*                                                                      *-              Flattening-*                                                                      *-************************************************************************--Note [Flattening]-~~~~~~~~~~~~~~~~~-As described in "Closed type families with overlapping equations"-http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf-we need to flatten core types before unifying them, when checking for "surely-apart"-against earlier equations of a closed type family.-Flattening means replacing all top-level uses of type functions with-fresh variables, *taking care to preserve sharing*. That is, the type-(Either (F a b) (F a b)) should flatten to (Either c c), never (Either-c d).--Here is a nice example of why it's all necessary:--  type family F a b where-    F Int Bool = Char-    F a   b    = Double-  type family G a         -- open, no instances--How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match,-while the second equation does. But, before reducing, we must make sure that the-target can never become (F Int Bool). Well, no matter what G Float becomes, it-certainly won't become *both* Int and Bool, so indeed we're safe reducing-(F (G Float) (G Float)) to Double.--This is necessary not only to get more reductions (which we might be-willing to give up on), but for substitutivity. If we have (F x x), we-can see that (F x x) can reduce to Double. So, it had better be the-case that (F blah blah) can reduce to Double, no matter what (blah)-is!  Flattening as done below ensures this.--The algorithm works by building up a TypeMap TyVar, mapping-type family applications to fresh variables. This mapping must-be threaded through all the function calls, as any entry in-the mapping must be propagated to all future nodes in the tree.--The algorithm also must track the set of in-scope variables, in-order to make fresh variables as it flattens. (We are far from a-source of fresh Uniques.) See Wrinkle 2, below.--There are wrinkles, of course:--1. The flattening algorithm must account for the possibility-   of inner `forall`s. (A `forall` seen here can happen only-   because of impredicativity. However, the flattening operation-   is an algorithm in Core, which is impredicative.)-   Suppose we have (forall b. F b) -> (forall b. F b). Of course,-   those two bs are entirely unrelated, and so we should certainly-   not flatten the two calls F b to the same variable. Instead, they-   must be treated separately. We thus carry a substitution that-   freshens variables; we must apply this substitution (in-   `coreFlattenTyFamApp`) before looking up an application in the environment.-   Note that the range of the substitution contains only TyVars, never anything-   else.--   For the sake of efficiency, we only apply this substitution when absolutely-   necessary. Namely:--   * We do not perform the substitution at all if it is empty.-   * We only need to worry about the arguments of a type family that are within-     the arity of said type family, so we can get away with not applying the-     substitution to any oversaturated type family arguments.-   * Importantly, we do /not/ achieve this substitution by recursively-     flattening the arguments, as this would be wrong. Consider `F (G a)`,-     where F and G are type families. We might decide that `F (G a)` flattens-     to `beta`. Later, the substitution is non-empty (but does not map `a`) and-     so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course,-     `F gamma` is unknown, and so we flatten it to `delta`, but it really-     should have been `beta`! Argh!--     Moral of the story: instead of flattening the arguments, just substitute-     them directly.--2. There are two different reasons we might add a variable-   to the in-scope set as we work:--     A. We have just invented a new flattening variable.-     B. We have entered a `forall`.--   Annoying here is that in-scope variable source (A) must be-   threaded through the calls. For example, consider (F b -> forall c. F c).-   Suppose that, when flattening F b, we invent a fresh variable c.-   Now, when we encounter (forall c. F c), we need to know c is already in-   scope so that we locally rename c to c'. However, if we don't thread through-   the in-scope set from one argument of (->) to the other, we won't know this-   and might get very confused.--   In contrast, source (B) increases only as we go deeper, as in-scope sets-   normally do. However, even here we must be careful. The TypeMap TyVar that-   contains mappings from type family applications to freshened variables will-   be threaded through both sides of (forall b. F b) -> (forall b. F b). We-   thus must make sure that the two `b`s don't get renamed to the same b1. (If-   they did, then looking up `F b1` would yield the same flatten var for-   each.) So, even though `forall`-bound variables should really be in the-   in-scope set only when they are in scope, we retain these variables even-   outside of their scope. This ensures that, if we encounter a fresh-   `forall`-bound b, we will rename it to b2, not b1. Note that keeping a-   larger in-scope set than strictly necessary is always OK, as in-scope sets-   are only ever used to avoid collisions.--   Sadly, the freshening substitution described in (1) really musn't bind-   variables outside of their scope: note that its domain is the *unrenamed*-   variables. This means that the substitution gets "pushed down" (like a-   reader monad) while the in-scope set gets threaded (like a state monad).-   Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst;-   instead, we just carry a TvSubstEnv down, tying it to the InScopeSet-   traveling separately as necessary.--3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k:--     type family F ty_1 ... ty_k :: res_k--   It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a-   flattening skolem. But we must instead flatten it to-   `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the-   type family.--   Why is this better? Consider the following concrete example from #16995:--     type family Param :: Type -> Type--     type family LookupParam (a :: Type) :: Type where-       LookupParam (f Char) = Bool-       LookupParam x        = Int--     foo :: LookupParam (Param ())-     foo = 42--   In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to-   `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if-   `alpha` is apart from `f Char`, so it won't fall through to the second-   equation. But since the `Param` type family has arity 0, we can instead-   flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is-   apart from `f Char`, permitting the second equation to be reached.--   Not only does this allow more programs to be accepted, it's also important-   for correctness. Not doing this was the root cause of the Core Lint error-   in #16995.--flattenTys is defined here because of module dependencies.--}--data FlattenEnv-  = FlattenEnv { fe_type_map :: TypeMap TyVar-                 -- domain: exactly-saturated type family applications-                 -- range: fresh variables-               , fe_in_scope :: InScopeSet }-                 -- See Note [Flattening]--emptyFlattenEnv :: InScopeSet -> FlattenEnv-emptyFlattenEnv in_scope-  = FlattenEnv { fe_type_map = emptyTypeMap-               , fe_in_scope = in_scope }--updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv-updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) }--flattenTys :: InScopeSet -> [Type] -> [Type]--- See Note [Flattening]--- NB: the returned types may mention fresh type variables,---     arising from the flattening.  We don't return the---     mapping from those fresh vars to the ty-fam---     applications they stand for (we could, but no need)-flattenTys in_scope tys-  = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys--coreFlattenTys :: TvSubstEnv -> FlattenEnv-               -> [Type] -> (FlattenEnv, [Type])-coreFlattenTys subst = mapAccumL (coreFlattenTy subst)--coreFlattenTy :: TvSubstEnv -> FlattenEnv-              -> Type -> (FlattenEnv, Type)-coreFlattenTy subst = go-  where-    go env ty | Just ty' <- coreView ty = go env ty'--    go env (TyVarTy tv)-      | Just ty <- lookupVarEnv subst tv = (env, ty)-      | otherwise                        = let (env', ki) = go env (tyVarKind tv) in-                                           (env', mkTyVarTy $ setTyVarKind tv ki)-    go env (AppTy ty1 ty2) = let (env1, ty1') = go env  ty1-                                 (env2, ty2') = go env1 ty2 in-                             (env2, AppTy ty1' ty2')-    go env (TyConApp tc tys)-         -- NB: Don't just check if isFamilyTyCon: this catches *data* families,-         -- which are generative and thus can be preserved during flattening-      | not (isGenerativeTyCon tc Nominal)-      = coreFlattenTyFamApp subst env tc tys--      | otherwise-      = let (env', tys') = coreFlattenTys subst env tys in-        (env', mkTyConApp tc tys')--    go env ty@(FunTy { ft_arg = ty1, ft_res = ty2 })-      = let (env1, ty1') = go env  ty1-            (env2, ty2') = go env1 ty2 in-        (env2, ty { ft_arg = ty1', ft_res = ty2' })--    go env (ForAllTy (Bndr tv vis) ty)-      = let (env1, subst', tv') = coreFlattenVarBndr subst env tv-            (env2, ty') = coreFlattenTy subst' env1 ty in-        (env2, ForAllTy (Bndr tv' vis) ty')--    go env ty@(LitTy {}) = (env, ty)--    go env (CastTy ty co)-      = let (env1, ty') = go env ty-            (env2, co') = coreFlattenCo subst env1 co in-        (env2, CastTy ty' co')--    go env (CoercionTy co)-      = let (env', co') = coreFlattenCo subst env co in-        (env', CoercionTy co')---- when flattening, we don't care about the contents of coercions.--- so, just return a fresh variable of the right (flattened) type-coreFlattenCo :: TvSubstEnv -> FlattenEnv-              -> Coercion -> (FlattenEnv, Coercion)-coreFlattenCo subst env co-  = (env2, mkCoVarCo covar)-  where-    (env1, kind') = coreFlattenTy subst env (coercionType co)-    covar         = mkFlattenFreshCoVar (fe_in_scope env1) kind'-    -- Add the covar to the FlattenEnv's in-scope set.-    -- See Note [Flattening], wrinkle 2A.-    env2          = updateInScopeSet env1 (flip extendInScopeSet covar)--coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv-                   -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar)-coreFlattenVarBndr subst env tv-  = (env2, subst', tv')-  where-    -- See Note [Flattening], wrinkle 2B.-    kind          = varType tv-    (env1, kind') = coreFlattenTy subst env kind-    tv'           = uniqAway (fe_in_scope env1) (setVarType tv kind')-    subst'        = extendVarEnv subst tv (mkTyVarTy tv')-    env2          = updateInScopeSet env1 (flip extendInScopeSet tv')--coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv-                    -> TyCon         -- type family tycon-                    -> [Type]        -- args, already flattened-                    -> (FlattenEnv, Type)-coreFlattenTyFamApp tv_subst env fam_tc fam_args-  = case lookupTypeMap type_map fam_ty of-      Just tv -> (env', mkAppTys (mkTyVarTy tv) leftover_args')-      Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc-                     tv         = uniqAway in_scope $-                                  mkTyVar tyvar_name (typeKind fam_ty)--                     ty'   = mkAppTys (mkTyVarTy tv) leftover_args'-                     env'' = env' { fe_type_map = extendTypeMap type_map fam_ty tv-                                  , fe_in_scope = extendInScopeSet in_scope tv }-                 in (env'', ty')-  where-    arity = tyConArity fam_tc-    tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv-    (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args )-                                    splitAt arity fam_args-    -- Apply the substitution before looking up an application in the-    -- environment. See Note [Flattening], wrinkle 1.-    -- NB: substTys short-cuts the common case when the substitution is empty.-    sat_fam_args' = substTys tcv_subst sat_fam_args-    (env', leftover_args') = coreFlattenTys tv_subst env leftover_args-    -- `fam_tc` may be over-applied to `fam_args` (see Note [Flattening],-    -- wrinkle 3), so we split it into the arguments needed to saturate it-    -- (sat_fam_args') and the rest (leftover_args')-    fam_ty = mkTyConApp fam_tc sat_fam_args'-    FlattenEnv { fe_type_map = type_map-               , fe_in_scope = in_scope } = env'--mkFlattenFreshTyName :: Uniquable a => a -> Name-mkFlattenFreshTyName unq-  = mkSysTvName (getUnique unq) (fsLit "flt")--mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar-mkFlattenFreshCoVar in_scope kind-  = let uniq = unsafeGetFreshLocalUnique in_scope-        name = mkSystemVarName uniq (fsLit "flc")-    in mkCoVar name kind
− compiler/types/InstEnv.hs 
@@ -1,1030 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[InstEnv]{Utilities for typechecking instance declarations}--The bits common to TcInstDcls and TcDeriv.--}--{-# LANGUAGE CPP, DeriveDataTypeable #-}--module InstEnv (-        DFunId, InstMatch, ClsInstLookupResult,-        OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,-        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,-        instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,-        instanceDFunId, updateClsInstDFun, instanceRoughTcs,-        fuzzyClsInstCmp, orphNamesOfClsInst,--        InstEnvs(..), VisibleOrphanModules, InstEnv,-        emptyInstEnv, extendInstEnv,-        deleteFromInstEnv, deleteDFunFromInstEnv,-        identicalClsInstHead,-        extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses,-        memberInstEnv,-        instIsVisible,-        classInstances, instanceBindFun,-        instanceCantMatch, roughMatchTcs,-        isOverlappable, isOverlapping, isIncoherent-    ) where--#include "HsVersions.h"--import GhcPrelude--import TcType -- InstEnv is really part of the type checker,-              -- and depends on TcType in many ways-import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor )-import Module-import Class-import Var-import VarSet-import Name-import NameSet-import Unify-import Outputable-import ErrUtils-import BasicTypes-import UniqDFM-import Util-import Id-import Data.Data        ( Data )-import Data.Maybe       ( isJust, isNothing )--{--************************************************************************-*                                                                      *-           ClsInst: the data type for type-class instances-*                                                                      *-************************************************************************--}---- | A type-class instance. Note that there is some tricky laziness at work--- here. See Note [ClsInst laziness and the rough-match fields] for more--- details.-data ClsInst-  = ClsInst {   -- Used for "rough matching"; see-                -- Note [ClsInst laziness and the rough-match fields]-                -- INVARIANT: is_tcs = roughMatchTcs is_tys-               is_cls_nm :: Name        -- ^ Class name-             , is_tcs  :: [Maybe Name]  -- ^ Top of type args--               -- | @is_dfun_name = idName . is_dfun@.-               ---               -- We use 'is_dfun_name' for the visibility check,-               -- 'instIsVisible', which needs to know the 'Module' which the-               -- dictionary is defined in. However, we cannot use the 'Module'-               -- attached to 'is_dfun' since doing so would mean we would-               -- potentially pull in an entire interface file unnecessarily.-               -- This was the cause of #12367.-             , is_dfun_name :: Name--                -- Used for "proper matching"; see Note [Proper-match fields]-             , is_tvs  :: [TyVar]       -- Fresh template tyvars for full match-                                        -- See Note [Template tyvars are fresh]-             , is_cls  :: Class         -- The real class-             , is_tys  :: [Type]        -- Full arg types (mentioning is_tvs)-                -- INVARIANT: is_dfun Id has type-                --      forall is_tvs. (...) => is_cls is_tys-                -- (modulo alpha conversion)--             , is_dfun :: DFunId -- See Note [Haddock assumptions]--             , is_flag :: OverlapFlag   -- See detailed comments with-                                        -- the decl of BasicTypes.OverlapFlag-             , is_orphan :: IsOrphan-    }-  deriving Data---- | A fuzzy comparison function for class instances, intended for sorting--- instances before displaying them to the user.-fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering-fuzzyClsInstCmp x y =-    stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend`-    mconcat (map cmp (zip (is_tcs x) (is_tcs y)))-  where-    cmp (Nothing, Nothing) = EQ-    cmp (Nothing, Just _) = LT-    cmp (Just _, Nothing) = GT-    cmp (Just x, Just y) = stableNameCmp x y--isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool-isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i))-isOverlapping  i = hasOverlappingFlag  (overlapMode (is_flag i))-isIncoherent   i = hasIncoherentFlag   (overlapMode (is_flag i))--{--Note [ClsInst laziness and the rough-match fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we load 'instance A.C B.T' from A.hi, but suppose that the type B.T is-otherwise unused in the program. Then it's stupid to load B.hi, the data type-declaration for B.T -- and perhaps further instance declarations!--We avoid this as follows:--* is_cls_nm, is_tcs, is_dfun_name are all Names. We can poke them to our heart's-  content.--* Proper-match fields. is_dfun, and its related fields is_tvs, is_cls, is_tys-  contain TyVars, Class, Type, Class etc, and so are all lazy thunks. When we-  poke any of these fields we'll typecheck the DFunId declaration, and hence-  pull in interfaces that it refers to. See Note [Proper-match fields].--* Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and-  is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking-  inside the DFunId. The rough-match fields allow us to say "definitely does not-  match", based only on Names.--  This laziness is very important; see #12367. Try hard to avoid pulling on-  the structured fields unless you really need the instance.--* Another place to watch is InstEnv.instIsVisible, which needs the module to-  which the ClsInst belongs. We can get this from is_dfun_name.--* In is_tcs,-    Nothing  means that this type arg is a type variable--    (Just n) means that this type arg is a-                TyConApp with a type constructor of n.-                This is always a real tycon, never a synonym!-                (Two different synonyms might match, but two-                different real tycons can't.)-                NB: newtypes are not transparent, though!--}--{--Note [Template tyvars are fresh]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The is_tvs field of a ClsInst has *completely fresh* tyvars.-That is, they are-  * distinct from any other ClsInst-  * distinct from any tyvars free in predicates that may-    be looked up in the class instance environment-Reason for freshness: we use unification when checking for overlap-etc, and that requires the tyvars to be distinct.--The invariant is checked by the ASSERT in lookupInstEnv'.--Note [Proper-match fields]-~~~~~~~~~~~~~~~~~~~~~~~~~-The is_tvs, is_cls, is_tys fields are simply cached values, pulled-out (lazily) from the dfun id. They are cached here simply so-that we don't need to decompose the DFunId each time we want-to match it.  The hope is that the rough-match fields mean-that we often never poke the proper-match fields.--However, note that:- * is_tvs must be a superset of the free vars of is_tys-- * is_tvs, is_tys may be alpha-renamed compared to the ones in-   the dfun Id--Note [Haddock assumptions]-~~~~~~~~~~~~~~~~~~~~~~~~~~-For normal user-written instances, Haddock relies on-- * the SrcSpan of- * the Name of- * the is_dfun of- * an Instance--being equal to--  * the SrcSpan of-  * the instance head type of-  * the InstDecl used to construct the Instance.--}--instanceDFunId :: ClsInst -> DFunId-instanceDFunId = is_dfun--updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst-updateClsInstDFun tidy_dfun ispec-  = ispec { is_dfun = tidy_dfun (is_dfun ispec) }--instanceRoughTcs :: ClsInst -> [Maybe Name]-instanceRoughTcs = is_tcs---instance NamedThing ClsInst where-   getName ispec = getName (is_dfun ispec)--instance Outputable ClsInst where-   ppr = pprInstance--pprInstance :: ClsInst -> SDoc--- Prints the ClsInst as an instance declaration-pprInstance ispec-  = hang (pprInstanceHdr ispec)-       2 (vcat [ text "--" <+> pprDefinedAt (getName ispec)-               , whenPprDebug (ppr (is_dfun ispec)) ])---- * pprInstanceHdr is used in VStudio to populate the ClassView tree-pprInstanceHdr :: ClsInst -> SDoc--- Prints the ClsInst as an instance declaration-pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun })-  = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun)--pprInstances :: [ClsInst] -> SDoc-pprInstances ispecs = vcat (map pprInstance ispecs)--instanceHead :: ClsInst -> ([TyVar], Class, [Type])--- Returns the head, using the fresh tyavs from the ClsInst-instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun })-   = (tvs, cls, tys)-   where-     (_, _, cls, _) = tcSplitDFunTy (idType dfun)---- | Collects the names of concrete types and type constructors that make--- up the head of a class instance. For instance, given `class Foo a b`:------ `instance Foo (Either (Maybe Int) a) Bool` would yield---      [Either, Maybe, Int, Bool]------ Used in the implementation of ":info" in GHCi.------ The 'tcSplitSigmaTy' is because of---      instance Foo a => Baz T where ...--- The decl is an orphan if Baz and T are both not locally defined,---      even if Foo *is* locally defined-orphNamesOfClsInst :: ClsInst -> NameSet-orphNamesOfClsInst (ClsInst { is_cls_nm = cls_nm, is_tys = tys })-  = orphNamesOfTypes tys `unionNameSet` unitNameSet cls_nm--instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type])--- Decomposes the DFunId-instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec))--mkLocalInstance :: DFunId -> OverlapFlag-                -> [TyVar] -> Class -> [Type]-                -> ClsInst--- Used for local instances, where we can safely pull on the DFunId.--- Consider using newClsInst instead; this will also warn if--- the instance is an orphan.-mkLocalInstance dfun oflag tvs cls tys-  = ClsInst { is_flag = oflag, is_dfun = dfun-            , is_tvs = tvs-            , is_dfun_name = dfun_name-            , is_cls = cls, is_cls_nm = cls_name-            , is_tys = tys, is_tcs = roughMatchTcs tys-            , is_orphan = orph-            }-  where-    cls_name = className cls-    dfun_name = idName dfun-    this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name-    is_local name = nameIsLocalOrFrom this_mod name--        -- Compute orphanhood.  See Note [Orphans] in InstEnv-    (cls_tvs, fds) = classTvsFds cls-    arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys]--    -- See Note [When exactly is an instance decl an orphan?]-    orph | is_local cls_name = NotOrphan (nameOccName cls_name)-         | all notOrphan mb_ns  = ASSERT( not (null mb_ns) ) head mb_ns-         | otherwise         = IsOrphan--    notOrphan NotOrphan{} = True-    notOrphan _ = False--    mb_ns :: [IsOrphan]    -- One for each fundep; a locally-defined name-                           -- that is not in the "determined" arguments-    mb_ns | null fds   = [choose_one arg_names]-          | otherwise  = map do_one fds-    do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names-                                            , not (tv `elem` rtvs)]--    choose_one nss = chooseOrphanAnchor (unionNameSets nss)--mkImportedInstance :: Name         -- ^ the name of the class-                   -> [Maybe Name] -- ^ the types which the class was applied to-                   -> Name         -- ^ the 'Name' of the dictionary binding-                   -> DFunId       -- ^ the 'Id' of the dictionary.-                   -> OverlapFlag  -- ^ may this instance overlap?-                   -> IsOrphan     -- ^ is this instance an orphan?-                   -> ClsInst--- Used for imported instances, where we get the rough-match stuff--- from the interface file--- The bound tyvars of the dfun are guaranteed fresh, because--- the dfun has been typechecked out of the same interface file-mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan-  = ClsInst { is_flag = oflag, is_dfun = dfun-            , is_tvs = tvs, is_tys = tys-            , is_dfun_name = dfun_name-            , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs-            , is_orphan = orphan }-  where-    (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)--{--Note [When exactly is an instance decl an orphan?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  (see GHC.Iface.Utils.instanceToIfaceInst, which implements this)-Roughly speaking, an instance is an orphan if its head (after the =>)-mentions nothing defined in this module.--Functional dependencies complicate the situation though. Consider--  module M where { class C a b | a -> b }--and suppose we are compiling module X:--  module X where-        import M-        data T = ...-        instance C Int T where ...--This instance is an orphan, because when compiling a third module Y we-might get a constraint (C Int v), and we'd want to improve v to T.  So-we must make sure X's instances are loaded, even if we do not directly-use anything from X.--More precisely, an instance is an orphan iff--  If there are no fundeps, then at least of the names in-  the instance head is locally defined.--  If there are fundeps, then for every fundep, at least one of the-  names free in a *non-determined* part of the instance head is-  defined in this module.--(Note that these conditions hold trivially if the class is locally-defined.)---************************************************************************-*                                                                      *-                InstEnv, ClsInstEnv-*                                                                      *-************************************************************************--A @ClsInstEnv@ all the instances of that class.  The @Id@ inside a-ClsInstEnv mapping is the dfun for that instance.--If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then--        forall a b, C t1 t2 t3  can be constructed by dfun--or, to put it another way, we have--        instance (...) => C t1 t2 t3,  witnessed by dfun--}------------------------------------------------------{--Note [InstEnv determinism]-~~~~~~~~~~~~~~~~~~~~~~~~~~-We turn InstEnvs into a list in some places that don't directly affect-the ABI. That happens when we create output for `:info`.-Unfortunately that nondeterminism is nonlocal and it's hard to tell what it-affects without following a chain of functions. It's also easy to accidentally-make that nondeterminism affect the ABI. Furthermore the envs should be-relatively small, so it should be free to use deterministic maps here.-Testing with nofib and validate detected no difference between UniqFM and-UniqDFM. See also Note [Deterministic UniqFM]--}--type InstEnv = UniqDFM ClsInstEnv      -- Maps Class to instances for that class-  -- See Note [InstEnv determinism]---- | 'InstEnvs' represents the combination of the global type class instance--- environment, the local type class instance environment, and the set of--- transitively reachable orphan modules (according to what modules have been--- directly imported) used to test orphan instance visibility.-data InstEnvs = InstEnvs {-        ie_global  :: InstEnv,               -- External-package instances-        ie_local   :: InstEnv,               -- Home-package instances-        ie_visible :: VisibleOrphanModules   -- Set of all orphan modules transitively-                                             -- reachable from the module being compiled-                                             -- See Note [Instance lookup and orphan instances]-    }---- | Set of visible orphan modules, according to what modules have been directly--- imported.  This is based off of the dep_orphs field, which records--- transitively reachable orphan modules (modules that define orphan instances).-type VisibleOrphanModules = ModuleSet--newtype ClsInstEnv-  = ClsIE [ClsInst]    -- The instances for a particular class, in any order--instance Outputable ClsInstEnv where-  ppr (ClsIE is) = pprInstances is---- INVARIANTS:---  * The is_tvs are distinct in each ClsInst---      of a ClsInstEnv (so we can safely unify them)---- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:---      [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]--- The "a" in the pattern must be one of the forall'd variables in--- the dfun type.--emptyInstEnv :: InstEnv-emptyInstEnv = emptyUDFM--instEnvElts :: InstEnv -> [ClsInst]-instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts]-  -- See Note [InstEnv determinism]--instEnvClasses :: InstEnv -> [Class]-instEnvClasses ie = [is_cls e | ClsIE (e : _) <- eltsUDFM ie]---- | Test if an instance is visible, by checking that its origin module--- is in 'VisibleOrphanModules'.--- See Note [Instance lookup and orphan instances]-instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool-instIsVisible vis_mods ispec-  -- NB: Instances from the interactive package always are visible. We can't-  -- add interactive modules to the set since we keep creating new ones-  -- as a GHCi session progresses.-  = case nameModule_maybe (is_dfun_name ispec) of-      Nothing -> True-      Just mod | isInteractiveModule mod     -> True-               | IsOrphan <- is_orphan ispec -> mod `elemModuleSet` vis_mods-               | otherwise                   -> True--classInstances :: InstEnvs -> Class -> [ClsInst]-classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls-  = get home_ie ++ get pkg_ie-  where-    get env = case lookupUDFM env cls of-                Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts-                Nothing            -> []---- | Checks for an exact match of ClsInst in the instance environment.--- We use this when we do signature checking in TcRnDriver-memberInstEnv :: InstEnv -> ClsInst -> Bool-memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) =-    maybe False (\(ClsIE items) -> any (identicalDFunType ins_item) items)-          (lookupUDFM inst_env cls_nm)- where-  identicalDFunType cls1 cls2 =-    eqType (varType (is_dfun cls1)) (varType (is_dfun cls2))--extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv-extendInstEnvList inst_env ispecs = foldl' extendInstEnv inst_env ispecs--extendInstEnv :: InstEnv -> ClsInst -> InstEnv-extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })-  = addToUDFM_C add inst_env cls_nm (ClsIE [ins_item])-  where-    add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts)--deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv-deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })-  = adjustUDFM adjust inst_env cls_nm-  where-    adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items)--deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv--- Delete a specific instance fron an InstEnv-deleteDFunFromInstEnv inst_env dfun-  = adjustUDFM adjust inst_env cls-  where-    (_, _, cls, _) = tcSplitDFunTy (idType dfun)-    adjust (ClsIE items) = ClsIE (filterOut same_dfun items)-    same_dfun (ClsInst { is_dfun = dfun' }) = dfun == dfun'--identicalClsInstHead :: ClsInst -> ClsInst -> Bool--- ^ True when when the instance heads are the same--- e.g.  both are   Eq [(a,b)]--- Used for overriding in GHCi--- Obviously should be insensitive to alpha-renaming-identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tys = tys1 })-                     (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tys = tys2 })-  =  cls_nm1 == cls_nm2-  && not (instanceCantMatch rough1 rough2)  -- Fast check for no match, uses the "rough match" fields-  && isJust (tcMatchTys tys1 tys2)-  && isJust (tcMatchTys tys2 tys1)--{--************************************************************************-*                                                                      *-        Looking up an instance-*                                                                      *-************************************************************************--@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match.  Since-the env is kept ordered, the first match must be the only one.  The-thing we are looking up can have an arbitrary "flexi" part.--Note [Instance lookup and orphan instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we are compiling a module M, and we have a zillion packages-loaded, and we are looking up an instance for C (T W).  If we find a-match in module 'X' from package 'p', should be "in scope"; that is,--  is p:X in the transitive closure of modules imported from M?--The difficulty is that the "zillion packages" might include ones loaded-through earlier invocations of the GHC API, or earlier module loads in GHCi.-They might not be in the dependencies of M itself; and if not, the instances-in them should not be visible.  #2182, #8427.--There are two cases:-  * If the instance is *not an orphan*, then module X defines C, T, or W.-    And in order for those types to be involved in typechecking M, it-    must be that X is in the transitive closure of M's imports.  So we-    can use the instance.--  * If the instance *is an orphan*, the above reasoning does not apply.-    So we keep track of the set of orphan modules transitively below M;-    this is the ie_visible field of InstEnvs, of type VisibleOrphanModules.--    If module p:X is in this set, then we can use the instance, otherwise-    we can't.--Note [Rules for instance lookup]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-These functions implement the carefully-written rules in the user-manual section on "overlapping instances". At risk of duplication,-here are the rules.  If the rules change, change this text and the-user manual simultaneously.  The link may be this:-http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap--The willingness to be overlapped or incoherent is a property of the-instance declaration itself, controlled as follows:-- * An instance is "incoherent"-   if it has an INCOHERENT pragma, or-   if it appears in a module compiled with -XIncoherentInstances.-- * An instance is "overlappable"-   if it has an OVERLAPPABLE or OVERLAPS pragma, or-   if it appears in a module compiled with -XOverlappingInstances, or-   if the instance is incoherent.-- * An instance is "overlapping"-   if it has an OVERLAPPING or OVERLAPS pragma, or-   if it appears in a module compiled with -XOverlappingInstances, or-   if the instance is incoherent.-     compiled with -XOverlappingInstances.--Now suppose that, in some client module, we are searching for an instance-of the target constraint (C ty1 .. tyn). The search works like this.--*  Find all instances `I` that *match* the target constraint; that is, the-   target constraint is a substitution instance of `I`. These instance-   declarations are the *candidates*.--*  Eliminate any candidate `IX` for which both of the following hold:--   -  There is another candidate `IY` that is strictly more specific; that-      is, `IY` is a substitution instance of `IX` but not vice versa.--   -  Either `IX` is *overlappable*, or `IY` is *overlapping*. (This-      "either/or" design, rather than a "both/and" design, allow a-      client to deliberately override an instance from a library,-      without requiring a change to the library.)---  If exactly one non-incoherent candidate remains, select it. If all-   remaining candidates are incoherent, select an arbitrary one.-   Otherwise the search fails (i.e. when more than one surviving-   candidate is not incoherent).---  If the selected candidate (from the previous step) is incoherent, the-   search succeeds, returning that candidate.---  If not, find all instances that *unify* with the target constraint,-   but do not *match* it. Such non-candidate instances might match when-   the target constraint is further instantiated. If all of them are-   incoherent, the search succeeds, returning the selected candidate; if-   not, the search fails.--Notice that these rules are not influenced by flag settings in the-client module, where the instances are *used*. These rules make it-possible for a library author to design a library that relies on-overlapping instances without the client having to know.--Note [Overlapping instances]   (NB: these notes are quite old)-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Overlap is permitted, but only in such a way that one can make-a unique choice when looking up.  That is, overlap is only permitted if-one template matches the other, or vice versa.  So this is ok:--  [a]  [Int]--but this is not--  (Int,a)  (b,Int)--If overlap is permitted, the list is kept most specific first, so that-the first lookup is the right choice.---For now we just use association lists.--\subsection{Avoiding a problem with overlapping}--Consider this little program:--\begin{pseudocode}-     class C a        where c :: a-     class C a => D a where d :: a--     instance C Int where c = 17-     instance D Int where d = 13--     instance C a => C [a] where c = [c]-     instance ({- C [a], -} D a) => D [a] where d = c--     instance C [Int] where c = [37]--     main = print (d :: [Int])-\end{pseudocode}--What do you think `main' prints  (assuming we have overlapping instances, and-all that turned on)?  Well, the instance for `D' at type `[a]' is defined to-be `c' at the same type, and we've got an instance of `C' at `[Int]', so the-answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because-the `C [Int]' instance is more specific).--Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong.  That-was easy ;-)  Let's just consult hugs for good measure.  Wait - if I use old-hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it-doesn't even compile!  What's going on!?--What hugs complains about is the `D [a]' instance decl.--\begin{pseudocode}-     ERROR "mj.hs" (line 10): Cannot build superclass instance-     *** Instance            : D [a]-     *** Context supplied    : D a-     *** Required superclass : C [a]-\end{pseudocode}--You might wonder what hugs is complaining about.  It's saying that you-need to add `C [a]' to the context of the `D [a]' instance (as appears-in comments).  But there's that `C [a]' instance decl one line above-that says that I can reduce the need for a `C [a]' instance to the-need for a `C a' instance, and in this case, I already have the-necessary `C a' instance (since we have `D a' explicitly in the-context, and `C' is a superclass of `D').--Unfortunately, the above reasoning indicates a premature commitment to the-generic `C [a]' instance.  I.e., it prematurely rules out the more specific-instance `C [Int]'.  This is the mistake that ghc-4.06 makes.  The fix is to-add the context that hugs suggests (uncomment the `C [a]'), effectively-deferring the decision about which instance to use.--Now, interestingly enough, 4.04 has this same bug, but it's covered up-in this case by a little known `optimization' that was disabled in-4.06.  Ghc-4.04 silently inserts any missing superclass context into-an instance declaration.  In this case, it silently inserts the `C-[a]', and everything happens to work out.--(See `basicTypes/MkId:mkDictFunId' for the code in question.  Search for-`Mark Jones', although Mark claims no credit for the `optimization' in-question, and would rather it stopped being called the `Mark Jones-optimization' ;-)--So, what's the fix?  I think hugs has it right.  Here's why.  Let's try-something else out with ghc-4.04.  Let's add the following line:--    d' :: D a => [a]-    d' = c--Everyone raise their hand who thinks that `d :: [Int]' should give a-different answer from `d' :: [Int]'.  Well, in ghc-4.04, it does.  The-`optimization' only applies to instance decls, not to regular-bindings, giving inconsistent behavior.--Old hugs had this same bug.  Here's how we fixed it: like GHC, the-list of instances for a given class is ordered, so that more specific-instances come before more generic ones.  For example, the instance-list for C might contain:-    ..., C Int, ..., C a, ...-When we go to look for a `C Int' instance we'll get that one first.-But what if we go looking for a `C b' (`b' is unconstrained)?  We'll-pass the `C Int' instance, and keep going.  But if `b' is-unconstrained, then we don't know yet if the more specific instance-will eventually apply.  GHC keeps going, and matches on the generic `C-a'.  The fix is to, at each step, check to see if there's a reverse-match, and if so, abort the search.  This prevents hugs from-prematurely choosing a generic instance when a more specific one-exists.----Jeff--BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in-this test.  Suppose the instance envt had-    ..., forall a b. C a a b, ..., forall a b c. C a b c, ...-(still most specific first)-Now suppose we are looking for (C x y Int), where x and y are unconstrained.-        C x y Int  doesn't match the template {a,b} C a a b-but neither does-        C a a b  match the template {x,y} C x y Int-But still x and y might subsequently be unified so they *do* match.--Simple story: unify, don't match.--}--type DFunInstType = Maybe Type-        -- Just ty   => Instantiate with this type-        -- Nothing   => Instantiate with any type of this tyvar's kind-        -- See Note [DFunInstType: instantiating types]--type InstMatch = (ClsInst, [DFunInstType])--type ClsInstLookupResult-     = ( [InstMatch]     -- Successful matches-       , [ClsInst]       -- These don't match but do unify-       , [InstMatch] )   -- Unsafe overlapped instances under Safe Haskell-                         -- (see Note [Safe Haskell Overlapping Instances] in-                         -- TcSimplify).--{--Note [DFunInstType: instantiating types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A successful match is a ClsInst, together with the types at which-        the dfun_id in the ClsInst should be instantiated-The instantiating types are (Either TyVar Type)s because the dfun-might have some tyvars that *only* appear in arguments-        dfun :: forall a b. C a b, Ord b => D [a]-When we match this against D [ty], we return the instantiating types-        [Just ty, Nothing]-where the 'Nothing' indicates that 'b' can be freely instantiated.-(The caller instantiates it to a flexi type variable, which will- presumably later become fixed via functional dependencies.)--}---- |Look up an instance in the given instance environment. The given class application must match exactly--- one instance and the match may not contain any flexi type variables.  If the lookup is unsuccessful,--- yield 'Left errorMessage'.-lookupUniqueInstEnv :: InstEnvs-                    -> Class -> [Type]-                    -> Either MsgDoc (ClsInst, [Type])-lookupUniqueInstEnv instEnv cls tys-  = case lookupInstEnv False instEnv cls tys of-      ([(inst, inst_tys)], _, _)-             | noFlexiVar -> Right (inst, inst_tys')-             | otherwise  -> Left $ text "flexible type variable:" <+>-                                    (ppr $ mkTyConApp (classTyCon cls) tys)-             where-               inst_tys'  = [ty | Just ty <- inst_tys]-               noFlexiVar = all isJust inst_tys-      _other -> Left $ text "instance not found" <+>-                       (ppr $ mkTyConApp (classTyCon cls) tys)--lookupInstEnv' :: InstEnv          -- InstEnv to look in-               -> VisibleOrphanModules   -- But filter against this-               -> Class -> [Type]  -- What we are looking for-               -> ([InstMatch],    -- Successful matches-                   [ClsInst])      -- These don't match but do unify-                                   -- (no incoherent ones in here)--- The second component of the result pair happens when we look up---      Foo [a]--- in an InstEnv that has entries for---      Foo [Int]---      Foo [b]--- Then which we choose would depend on the way in which 'a'--- is instantiated.  So we report that Foo [b] is a match (mapping b->a)--- but Foo [Int] is a unifier.  This gives the caller a better chance of--- giving a suitable error message--lookupInstEnv' ie vis_mods cls tys-  = lookup ie-  where-    rough_tcs  = roughMatchTcs tys-    all_tvs    = all isNothing rough_tcs--    ---------------    lookup env = case lookupUDFM env cls of-                   Nothing -> ([],[])   -- No instances for this class-                   Just (ClsIE insts) -> find [] [] insts--    ---------------    find ms us [] = (ms, us)-    find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs-                              , is_tys = tpl_tys }) : rest)-      | not (instIsVisible vis_mods item)-      = find ms us rest  -- See Note [Instance lookup and orphan instances]--        -- Fast check for no match, uses the "rough match" fields-      | instanceCantMatch rough_tcs mb_tcs-      = find ms us rest--      | Just subst <- tcMatchTys tpl_tys tys-      = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest--        -- Does not match, so next check whether the things unify-        -- See Note [Overlapping instances]-        -- Ignore ones that are incoherent: Note [Incoherent instances]-      | isIncoherent item-      = find ms us rest--      | otherwise-      = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set,-                 (ppr cls <+> ppr tys <+> ppr all_tvs) $$-                 (ppr tpl_tvs <+> ppr tpl_tys)-                )-                -- Unification will break badly if the variables overlap-                -- They shouldn't because we allocate separate uniques for them-                -- See Note [Template tyvars are fresh]-        case tcUnifyTys instanceBindFun tpl_tys tys of-            Just _   -> find ms (item:us) rest-            Nothing  -> find ms us        rest-      where-        tpl_tv_set = mkVarSet tpl_tvs-------------------- This is the common way to call this function.-lookupInstEnv :: Bool              -- Check Safe Haskell overlap restrictions-              -> InstEnvs          -- External and home package inst-env-              -> Class -> [Type]   -- What we are looking for-              -> ClsInstLookupResult--- ^ See Note [Rules for instance lookup]--- ^ See Note [Safe Haskell Overlapping Instances] in TcSimplify--- ^ See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify-lookupInstEnv check_overlap_safe-              (InstEnvs { ie_global = pkg_ie-                        , ie_local = home_ie-                        , ie_visible = vis_mods })-              cls-              tys-  = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $-    (final_matches, final_unifs, unsafe_overlapped)-  where-    (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys-    (pkg_matches,  pkg_unifs)  = lookupInstEnv' pkg_ie  vis_mods cls tys-    all_matches = home_matches ++ pkg_matches-    all_unifs   = home_unifs   ++ pkg_unifs-    final_matches = foldr insert_overlapping [] all_matches-        -- Even if the unifs is non-empty (an error situation)-        -- we still prune the matches, so that the error message isn't-        -- misleading (complaining of multiple matches when some should be-        -- overlapped away)--    unsafe_overlapped-       = case final_matches of-           [match] -> check_safe match-           _       -> []--    -- If the selected match is incoherent, discard all unifiers-    final_unifs = case final_matches of-                    (m:_) | isIncoherent (fst m) -> []-                    _                            -> all_unifs--    -- NOTE [Safe Haskell isSafeOverlap]-    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    -- We restrict code compiled in 'Safe' mode from overriding code-    -- compiled in any other mode. The rationale is that code compiled-    -- in 'Safe' mode is code that is untrusted by the ghc user. So-    -- we shouldn't let that code change the behaviour of code the-    -- user didn't compile in 'Safe' mode since that's the code they-    -- trust. So 'Safe' instances can only overlap instances from the-    -- same module. A same instance origin policy for safe compiled-    -- instances.-    check_safe (inst,_)-        = case check_overlap_safe && unsafeTopInstance inst of-                -- make sure it only overlaps instances from the same module-                True -> go [] all_matches-                -- most specific is from a trusted location.-                False -> []-        where-            go bad [] = bad-            go bad (i@(x,_):unchecked) =-                if inSameMod x || isOverlappable x-                    then go bad unchecked-                    else go (i:bad) unchecked--            inSameMod b =-                let na = getName $ getName inst-                    la = isInternalName na-                    nb = getName $ getName b-                    lb = isInternalName nb-                in (la && lb) || (nameModule na == nameModule nb)--    -- We consider the most specific instance unsafe when it both:-    --   (1) Comes from a module compiled as `Safe`-    --   (2) Is an orphan instance, OR, an instance for a MPTC-    unsafeTopInstance inst = isSafeOverlap (is_flag inst) &&-        (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1)------------------insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch]--- ^ Add a new solution, knocking out strictly less specific ones--- See Note [Rules for instance lookup]-insert_overlapping new_item [] = [new_item]-insert_overlapping new_item@(new_inst,_) (old_item@(old_inst,_) : old_items)-  | new_beats_old        -- New strictly overrides old-  , not old_beats_new-  , new_inst `can_override` old_inst-  = insert_overlapping new_item old_items--  | old_beats_new        -- Old strictly overrides new-  , not new_beats_old-  , old_inst `can_override` new_inst-  = old_item : old_items--  -- Discard incoherent instances; see Note [Incoherent instances]-  | isIncoherent old_inst      -- Old is incoherent; discard it-  = insert_overlapping new_item old_items-  | isIncoherent new_inst      -- New is incoherent; discard it-  = old_item : old_items--  -- Equal or incomparable, and neither is incoherent; keep both-  | otherwise-  = old_item : insert_overlapping new_item old_items-  where--    new_beats_old = new_inst `more_specific_than` old_inst-    old_beats_new = old_inst `more_specific_than` new_inst--    -- `instB` can be instantiated to match `instA`-    -- or the two are equal-    instA `more_specific_than` instB-      = isJust (tcMatchTys (is_tys instB) (is_tys instA))--    instA `can_override` instB-       = isOverlapping instA || isOverlappable instB-       -- Overlap permitted if either the more specific instance-       -- is marked as overlapping, or the more general one is-       -- marked as overlappable.-       -- Latest change described in: #9242.-       -- Previous change: #3877, Dec 10.--{--Note [Incoherent instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-For some classes, the choice of a particular instance does not matter, any one-is good. E.g. consider--        class D a b where { opD :: a -> b -> String }-        instance D Int b where ...-        instance D a Int where ...--        g (x::Int) = opD x x  -- Wanted: D Int Int--For such classes this should work (without having to add an "instance D Int-Int", and using -XOverlappingInstances, which would then work). This is what--XIncoherentInstances is for: Telling GHC "I don't care which instance you use;-if you can use one, use it."--Should this logic only work when *all* candidates have the incoherent flag, or-even when all but one have it? The right choice is the latter, which can be-justified by comparing the behaviour with how -XIncoherentInstances worked when-it was only about the unify-check (note [Overlapping instances]):--Example:-        class C a b c where foo :: (a,b,c)-        instance C [a] b Int-        instance [incoherent] [Int] b c-        instance [incoherent] C a Int c-Thanks to the incoherent flags,-        [Wanted]  C [a] b Int-works: Only instance one matches, the others just unify, but are marked-incoherent.--So I can write-        (foo :: ([a],b,Int)) :: ([Int], Int, Int).-but if that works then I really want to be able to write-        foo :: ([Int], Int, Int)-as well. Now all three instances from above match. None is more specific than-another, so none is ruled out by the normal overlapping rules. One of them is-not incoherent, but we still want this to compile. Hence the-"all-but-one-logic".--The implementation is in insert_overlapping, where we remove matching-incoherent instances as long as there are others.----************************************************************************-*                                                                      *-        Binding decisions-*                                                                      *-************************************************************************--}--instanceBindFun :: TyCoVar -> BindFlag-instanceBindFun tv | isOverlappableTyVar tv = Skolem-                   | otherwise              = BindMe-   -- Note [Binding when looking up instances]--{--Note [Binding when looking up instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When looking up in the instance environment, or family-instance environment,-we are careful about multiple matches, as described above in-Note [Overlapping instances]--The key_tys can contain skolem constants, and we can guarantee that those-are never going to be instantiated to anything, so we should not involve-them in the unification test.  Example:-        class Foo a where { op :: a -> Int }-        instance Foo a => Foo [a]       -- NB overlap-        instance Foo [Int]              -- NB overlap-        data T = forall a. Foo a => MkT a-        f :: T -> Int-        f (MkT x) = op [x,x]-The op [x,x] means we need (Foo [a]).  Without the filterVarSet we'd-complain, saying that the choice of instance depended on the instantiation-of 'a'; but of course it isn't *going* to be instantiated.--We do this only for isOverlappableTyVar skolems.  For example we reject-        g :: forall a => [a] -> Int-        g x = op x-on the grounds that the correct instance depends on the instantiation of 'a'--}
− compiler/types/OptCoercion.hs 
@@ -1,1206 +0,0 @@--- (c) The University of Glasgow 2006--{-# LANGUAGE CPP #-}--module OptCoercion ( optCoercion, checkAxInstCo ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Driver.Session-import TyCoRep-import TyCoSubst-import Coercion-import Type hiding( substTyVarBndr, substTy )-import TcType       ( exactTyCoVarsOfType )-import TyCon-import CoAxiom-import VarSet-import VarEnv-import Outputable-import FamInstEnv ( flattenTys )-import Pair-import ListSetOps ( getNth )-import Util-import Unify-import InstEnv-import Control.Monad   ( zipWithM )--{--%************************************************************************-%*                                                                      *-                 Optimising coercions-%*                                                                      *-%************************************************************************--Note [Optimising coercion optimisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Looking up a coercion's role or kind is linear in the size of the-coercion. Thus, doing this repeatedly during the recursive descent-of coercion optimisation is disastrous. We must be careful to avoid-doing this if at all possible.--Because it is generally easy to know a coercion's components' roles-from the role of the outer coercion, we pass down the known role of-the input in the algorithm below. We also keep functions opt_co2-and opt_co3 separate from opt_co4, so that the former two do Phantom-checks that opt_co4 can avoid. This is a big win because Phantom coercions-rarely appear within non-phantom coercions -- only in some TyConAppCos-and some AxiomInstCos. We handle these cases specially by calling-opt_co2.--Note [Optimising InstCo]-~~~~~~~~~~~~~~~~~~~~~~~~-(1) tv is a type variable-When we have (InstCo (ForAllCo tv h g) g2), we want to optimise.--Let's look at the typing rules.--h : k1 ~ k2-tv:k1 |- g : t1 ~ t2-------------------------------ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h])--g1 : (all tv:k1.t1') ~ (all tv:k2.t2')-g2 : s1 ~ s2----------------------InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2]--We thus want some coercion proving this:--  (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h])--If we substitute the *type* tv for the *coercion*-(g2 ; t2 ~ t2 |> sym h) in g, we'll get this result exactly.-This is bizarre,-though, because we're substituting a type variable with a coercion. However,-this operation already exists: it's called *lifting*, and defined in Coercion.-We just need to enhance the lifting operation to be able to deal with-an ambient substitution, which is why a LiftingContext stores a TCvSubst.--(2) cv is a coercion variable-Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise.--h : (t1 ~r t2) ~N (t3 ~r t4)-cv : t1 ~r t2 |- g : t1' ~r2 t2'-n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3-n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4--------------------------------------------------ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2-                  (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2])--g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2')-g2 : h1 ~N h2-h1 : t1 ~r t2-h2 : t3 ~r t4--------------------------------------------------InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2]--We thus want some coercion proving this:--  t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2]--So we substitute the coercion variable c for the coercion-(h1 ~N (n1; h2; sym n2)) in g.--}--optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo--- ^ optCoercion applies a substitution to a coercion,---   *and* optimises it to reduce its size-optCoercion dflags env co-  | hasNoOptCoercion dflags = substCo env co-  | otherwise               = optCoercion' env co--optCoercion' :: TCvSubst -> Coercion -> NormalCo-optCoercion' env co-  | debugIsOn-  = let out_co = opt_co1 lc False co-        (Pair in_ty1  in_ty2,  in_role)  = coercionKindRole co-        (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co-    in-    ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 &&-             substTyUnchecked env in_ty2 `eqType` out_ty2 &&-             in_role == out_role-           , text "optCoercion changed types!"-             $$ hang (text "in_co:") 2 (ppr co)-             $$ hang (text "in_ty1:") 2 (ppr in_ty1)-             $$ hang (text "in_ty2:") 2 (ppr in_ty2)-             $$ hang (text "out_co:") 2 (ppr out_co)-             $$ hang (text "out_ty1:") 2 (ppr out_ty1)-             $$ hang (text "out_ty2:") 2 (ppr out_ty2)-             $$ hang (text "subst:") 2 (ppr env) )-    out_co--  | otherwise         = opt_co1 lc False co-  where-    lc = mkSubstLiftingContext env--type NormalCo    = Coercion-  -- Invariants:-  --  * The substitution has been fully applied-  --  * For trans coercions (co1 `trans` co2)-  --       co1 is not a trans, and neither co1 nor co2 is identity--type NormalNonIdCo = NormalCo  -- Extra invariant: not the identity---- | Do we apply a @sym@ to the result?-type SymFlag = Bool---- | Do we force the result to be representational?-type ReprFlag = Bool---- | Optimize a coercion, making no assumptions. All coercions in--- the lifting context are already optimized (and sym'd if nec'y)-opt_co1 :: LiftingContext-        -> SymFlag-        -> Coercion -> NormalCo-opt_co1 env sym co = opt_co2 env sym (coercionRole co) co---- See Note [Optimising coercion optimisation]--- | Optimize a coercion, knowing the coercion's role. No other assumptions.-opt_co2 :: LiftingContext-        -> SymFlag-        -> Role   -- ^ The role of the input coercion-        -> Coercion -> NormalCo-opt_co2 env sym Phantom co = opt_phantom env sym co-opt_co2 env sym r       co = opt_co3 env sym Nothing r co---- See Note [Optimising coercion optimisation]--- | Optimize a coercion, knowing the coercion's non-Phantom role.-opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo-opt_co3 env sym (Just Phantom)          _ co = opt_phantom env sym co-opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True  r co-  -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore-opt_co3 env sym _                       r co = opt_co4_wrap env sym False r co---- See Note [Optimising coercion optimisation]--- | Optimize a non-phantom coercion.-opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo--opt_co4_wrap = opt_co4-{--opt_co4_wrap env sym rep r co-  = pprTrace "opt_co4_wrap {"-    ( vcat [ text "Sym:" <+> ppr sym-           , text "Rep:" <+> ppr rep-           , text "Role:" <+> ppr r-           , text "Co:" <+> ppr co ]) $-    ASSERT( r == coercionRole co )-    let result = opt_co4 env sym rep r co in-    pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $-    result--}--opt_co4 env _   rep r (Refl ty)-  = ASSERT2( r == Nominal, text "Expected role:" <+> ppr r    $$-                           text "Found role:" <+> ppr Nominal $$-                           text "Type:" <+> ppr ty )-    liftCoSubst (chooseRole rep r) env ty--opt_co4 env _   rep r (GRefl _r ty MRefl)-  = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$-                      text "Found role:" <+> ppr _r   $$-                      text "Type:" <+> ppr ty )-    liftCoSubst (chooseRole rep r) env ty--opt_co4 env sym  rep r (GRefl _r ty (MCo co))-  = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$-                      text "Found role:" <+> ppr _r   $$-                      text "Type:" <+> ppr ty )-    if isGReflCo co || isGReflCo co'-    then liftCoSubst r' env ty-    else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty)-  where-    r'  = chooseRole rep r-    ty' = substTy (lcSubstLeft env) ty-    co' = opt_co4 env False False Nominal co--opt_co4 env sym rep r (SymCo co)  = opt_co4_wrap env (not sym) rep r co-  -- surprisingly, we don't have to do anything to the env here. This is-  -- because any "lifting" substitutions in the env are tied to ForAllCos,-  -- which treat their left and right sides differently. We don't want to-  -- exchange them.--opt_co4 env sym rep r g@(TyConAppCo _r tc cos)-  = ASSERT( r == _r )-    case (rep, r) of-      (True, Nominal) ->-        mkTyConAppCo Representational tc-                     (zipWith3 (opt_co3 env sym)-                               (map Just (tyConRolesRepresentational tc))-                               (repeat Nominal)-                               cos)-      (False, Nominal) ->-        mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos)-      (_, Representational) ->-                      -- must use opt_co2 here, because some roles may be P-                      -- See Note [Optimising coercion optimisation]-        mkTyConAppCo r tc (zipWith (opt_co2 env sym)-                                   (tyConRolesRepresentational tc)  -- the current roles-                                   cos)-      (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g)--opt_co4 env sym rep r (AppCo co1 co2)-  = mkAppCo (opt_co4_wrap env sym rep r co1)-            (opt_co4_wrap env sym False Nominal co2)--opt_co4 env sym rep r (ForAllCo tv k_co co)-  = case optForAllCoBndr env sym tv k_co of-      (env', tv', k_co') -> mkForAllCo tv' k_co' $-                            opt_co4_wrap env' sym rep r co-     -- Use the "mk" functions to check for nested Refls--opt_co4 env sym rep r (FunCo _r co1 co2)-  = ASSERT( r == _r )-    if rep-    then mkFunCo Representational co1' co2'-    else mkFunCo r co1' co2'-  where-    co1' = opt_co4_wrap env sym rep r co1-    co2' = opt_co4_wrap env sym rep r co2--opt_co4 env sym rep r (CoVarCo cv)-  | Just co <- lookupCoVar (lcTCvSubst env) cv-  = opt_co4_wrap (zapLiftingContext env) sym rep r co--  | ty1 `eqType` ty2   -- See Note [Optimise CoVarCo to Refl]-  = mkReflCo (chooseRole rep r) ty1--  | otherwise-  = ASSERT( isCoVar cv1 )-    wrapRole rep r $ wrapSym sym $-    CoVarCo cv1--  where-    Pair ty1 ty2 = coVarTypes cv1--    cv1 = case lookupInScope (lcInScopeSet env) cv of-             Just cv1 -> cv1-             Nothing  -> WARN( True, text "opt_co: not in scope:"-                                     <+> ppr cv $$ ppr env)-                         cv-          -- cv1 might have a substituted kind!--opt_co4 _ _ _ _ (HoleCo h)-  = pprPanic "opt_univ fell into a hole" (ppr h)--opt_co4 env sym rep r (AxiomInstCo con ind cos)-    -- Do *not* push sym inside top-level axioms-    -- e.g. if g is a top-level axiom-    --   g a : f a ~ a-    -- then (sym (g ty)) /= g (sym ty) !!-  = ASSERT( r == coAxiomRole con )-    wrapRole rep (coAxiomRole con) $-    wrapSym sym $-                       -- some sub-cos might be P: use opt_co2-                       -- See Note [Optimising coercion optimisation]-    AxiomInstCo con ind (zipWith (opt_co2 env False)-                                 (coAxBranchRoles (coAxiomNthBranch con ind))-                                 cos)-      -- Note that the_co does *not* have sym pushed into it--opt_co4 env sym rep r (UnivCo prov _r t1 t2)-  = ASSERT( r == _r )-    opt_univ env sym prov (chooseRole rep r) t1 t2--opt_co4 env sym rep r (TransCo co1 co2)-                      -- sym (g `o` h) = sym h `o` sym g-  | sym       = opt_trans in_scope co2' co1'-  | otherwise = opt_trans in_scope co1' co2'-  where-    co1' = opt_co4_wrap env sym rep r co1-    co2' = opt_co4_wrap env sym rep r co2-    in_scope = lcInScopeSet env--opt_co4 env _sym rep r (NthCo _r n co)-  | Just (ty, _) <- isReflCo_maybe co-  , Just (_tc, args) <- ASSERT( r == _r )-                        splitTyConApp_maybe ty-  = liftCoSubst (chooseRole rep r) env (args `getNth` n)-  | Just (ty, _) <- isReflCo_maybe co-  , n == 0-  , Just (tv, _) <- splitForAllTy_maybe ty-      -- works for both tyvar and covar-  = liftCoSubst (chooseRole rep r) env (varType tv)--opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos))-  = ASSERT( r == r1 )-    opt_co4_wrap env sym rep r (cos `getNth` n)--opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _))-      -- works for both tyvar and covar-  = ASSERT( r == _r )-    ASSERT( n == 0 )-    opt_co4_wrap env sym rep Nominal eta--opt_co4 env sym rep r (NthCo _r n co)-  | TyConAppCo _ _ cos <- co'-  , let nth_co = cos `getNth` n-  = if rep && (r == Nominal)-      -- keep propagating the SubCo-    then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co-    else nth_co--  | ForAllCo _ eta _ <- co'-  = if rep-    then opt_co4_wrap (zapLiftingContext env) False True Nominal eta-    else eta--  | otherwise-  = wrapRole rep r $ NthCo r n co'-  where-    co' = opt_co1 env sym co--opt_co4 env sym rep r (LRCo lr co)-  | Just pr_co <- splitAppCo_maybe co-  = ASSERT( r == Nominal )-    opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co)-  | Just pr_co <- splitAppCo_maybe co'-  = ASSERT( r == Nominal )-    if rep-    then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co)-    else pick_lr lr pr_co-  | otherwise-  = wrapRole rep Nominal $ LRCo lr co'-  where-    co' = opt_co4_wrap env sym False Nominal co--    pick_lr CLeft  (l, _) = l-    pick_lr CRight (_, r) = r---- See Note [Optimising InstCo]-opt_co4 env sym rep r (InstCo co1 arg)-    -- forall over type...-  | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1-  = opt_co4_wrap (extendLiftingContext env tv-                    (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg))-                   -- mkSymCo kind_co :: k1 ~ k2-                   -- sym_arg :: (t1 :: k1) ~ (t2 :: k2)-                   -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1)-                 sym rep r co_body--    -- forall over coercion...-  | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1-  , CoercionTy h1 <- t1-  , CoercionTy h2 <- t2-  = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2-    in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body--    -- See if it is a forall after optimization-    -- If so, do an inefficient one-variable substitution, then re-optimize--    -- forall over type...-  | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1'-  = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv'-                    (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg'))-            False False r' co_body'--    -- forall over coercion...-  | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1'-  , CoercionTy h1' <- t1'-  , CoercionTy h2' <- t2'-  = let new_co = mk_new_co cv' kind_co' h1' h2'-    in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co)-                    False False r' co_body'--  | otherwise = InstCo co1' arg'-  where-    co1'    = opt_co4_wrap env sym rep r co1-    r'      = chooseRole rep r-    arg'    = opt_co4_wrap env sym False Nominal arg-    sym_arg = wrapSym sym arg'--    -- Performance note: don't be alarmed by the two calls to coercionKind-    -- here, as only one call to coercionKind is actually demanded per guard.-    -- t1/t2 are used when checking if co1 is a forall, and t1'/t2' are used-    -- when checking if co1' (i.e., co1 post-optimization) is a forall.-    ---    -- t1/t2 must come from sym_arg, not arg', since it's possible that arg'-    -- might have an extra Sym at the front (after being optimized) that co1-    -- lacks, so we need to use sym_arg to balance the number of Syms. (#15725)-    Pair t1  t2  = coercionKind sym_arg-    Pair t1' t2' = coercionKind arg'--    mk_new_co cv kind_co h1 h2-      = let -- h1 :: (t1 ~ t2)-            -- h2 :: (t3 ~ t4)-            -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4)-            -- n1 :: t1 ~ t3-            -- n2 :: t2 ~ t4-            -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2)-            r2  = coVarRole cv-            kind_co' = downgradeRole r2 Nominal kind_co-            n1 = mkNthCo r2 2 kind_co'-            n2 = mkNthCo r2 3 kind_co'-         in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1-                           (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2))--opt_co4 env sym _rep r (KindCo co)-  = ASSERT( r == Nominal )-    let kco' = promoteCoercion co in-    case kco' of-      KindCo co' -> promoteCoercion (opt_co1 env sym co')-      _          -> opt_co4_wrap env sym False Nominal kco'-  -- This might be able to be optimized more to do the promotion-  -- and substitution/optimization at the same time--opt_co4 env sym _ r (SubCo co)-  = ASSERT( r == Representational )-    opt_co4_wrap env sym True Nominal co---- This could perhaps be optimized more.-opt_co4 env sym rep r (AxiomRuleCo co cs)-  = ASSERT( r == coaxrRole co )-    wrapRole rep r $-    wrapSym sym $-    AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs)--{- Note [Optimise CoVarCo to Refl]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have (c :: t~t) we can optimise it to Refl. That increases the-chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t)--We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo]-in Coercion.--}------------------ | Optimize a phantom coercion. The input coercion may not necessarily--- be a phantom, but the output sure will be.-opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo-opt_phantom env sym co-  = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2-  where-    Pair ty1 ty2 = coercionKind co--{- Note [Differing kinds]-   ~~~~~~~~~~~~~~~~~~~~~~-The two types may not have the same kind (although that would be very unusual).-But even if they have the same kind, and the same type constructor, the number-of arguments in a `CoTyConApp` can differ. Consider--  Any :: forall k. k--  Any * Int                      :: *-  Any (*->*) Maybe Int  :: *--Hence the need to compare argument lengths; see #13658- -}--opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role-         -> Type -> Type -> Coercion-opt_univ env sym (PhantomProv h) _r ty1 ty2-  | sym       = mkPhantomCo h' ty2' ty1'-  | otherwise = mkPhantomCo h' ty1' ty2'-  where-    h' = opt_co4 env sym False Nominal h-    ty1' = substTy (lcSubstLeft  env) ty1-    ty2' = substTy (lcSubstRight env) ty2--opt_univ env sym prov role oty1 oty2-  | Just (tc1, tys1) <- splitTyConApp_maybe oty1-  , Just (tc2, tys2) <- splitTyConApp_maybe oty2-  , tc1 == tc2-  , equalLength tys1 tys2 -- see Note [Differing kinds]-      -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom);-      -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps-  = let roles    = tyConRolesX role tc1-        arg_cos  = zipWith3 (mkUnivCo prov') roles tys1 tys2-        arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos-    in-    mkTyConAppCo role tc1 arg_cos'--  -- can't optimize the AppTy case because we can't build the kind coercions.--  | Just (tv1, ty1) <- splitForAllTy_ty_maybe oty1-  , Just (tv2, ty2) <- splitForAllTy_ty_maybe oty2-      -- NB: prov isn't interesting here either-  = let k1   = tyVarKind tv1-        k2   = tyVarKind tv2-        eta  = mkUnivCo prov' Nominal k1 k2-          -- eta gets opt'ed soon, but not yet.-        ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2--        (env', tv1', eta') = optForAllCoBndr env sym tv1 eta-    in-    mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2')--  | Just (cv1, ty1) <- splitForAllTy_co_maybe oty1-  , Just (cv2, ty2) <- splitForAllTy_co_maybe oty2-      -- NB: prov isn't interesting here either-  = let k1    = varType cv1-        k2    = varType cv2-        r'    = coVarRole cv1-        eta   = mkUnivCo prov' Nominal k1 k2-        eta_d = downgradeRole r' Nominal eta-          -- eta gets opt'ed soon, but not yet.-        n_co  = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo`-                (mkCoVarCo cv1) `mkTransCo`-                (mkNthCo r' 3 eta_d)-        ty2'  = substTyWithCoVars [cv2] [n_co] ty2--        (env', cv1', eta') = optForAllCoBndr env sym cv1 eta-    in-    mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2')--  | otherwise-  = let ty1 = substTyUnchecked (lcSubstLeft  env) oty1-        ty2 = substTyUnchecked (lcSubstRight env) oty2-        (a, b) | sym       = (ty2, ty1)-               | otherwise = (ty1, ty2)-    in-    mkUnivCo prov' role a b--  where-    prov' = case prov of-      PhantomProv kco    -> PhantomProv $ opt_co4_wrap env sym False Nominal kco-      ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco-      PluginProv _       -> prov----------------opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]-opt_transList is = zipWith (opt_trans is)--opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo-opt_trans is co1 co2-  | isReflCo co1 = co2-    -- optimize when co1 is a Refl Co-  | otherwise    = opt_trans1 is co1 co2--opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo--- First arg is not the identity-opt_trans1 is co1 co2-  | isReflCo co2 = co1-    -- optimize when co2 is a Refl Co-  | otherwise    = opt_trans2 is co1 co2--opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo--- Neither arg is the identity-opt_trans2 is (TransCo co1a co1b) co2-    -- Don't know whether the sub-coercions are the identity-  = opt_trans is co1a (opt_trans is co1b co2)--opt_trans2 is co1 co2-  | Just co <- opt_trans_rule is co1 co2-  = co--opt_trans2 is co1 (TransCo co2a co2b)-  | Just co1_2a <- opt_trans_rule is co1 co2a-  = if isReflCo co1_2a-    then co2b-    else opt_trans1 is co1_2a co2b--opt_trans2 _ co1 co2-  = mkTransCo co1 co2----------- Optimize coercions with a top-level use of transitivity.-opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo--opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2))-  = ASSERT( r1 == r2 )-    fireTransRule "GRefl" in_co1 in_co2 $-    mkGReflRightCo r1 t1 (opt_trans is co1 co2)---- Push transitivity through matching destructors-opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2)-  | d1 == d2-  , coercionRole co1 == coercionRole co2-  , co1 `compatible_co` co2-  = ASSERT( r1 == r2 )-    fireTransRule "PushNth" in_co1 in_co2 $-    mkNthCo r1 d1 (opt_trans is co1 co2)--opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)-  | d1 == d2-  , co1 `compatible_co` co2-  = fireTransRule "PushLR" in_co1 in_co2 $-    mkLRCo d1 (opt_trans is co1 co2)---- Push transitivity inside instantiation-opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)-  | ty1 `eqCoercion` ty2-  , co1 `compatible_co` co2-  = fireTransRule "TrPushInst" in_co1 in_co2 $-    mkInstCo (opt_trans is co1 co2) ty1--opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1)-                  in_co2@(UnivCo p2 r2 _tyl2 tyr2)-  | Just prov' <- opt_trans_prov p1 p2-  = ASSERT( r1 == r2 )-    fireTransRule "UnivCo" in_co1 in_co2 $-    mkUnivCo prov' r1 tyl1 tyr2-  where-    -- if the provenances are different, opt'ing will be very confusing-    opt_trans_prov (PhantomProv kco1)    (PhantomProv kco2)-      = Just $ PhantomProv $ opt_trans is kco1 kco2-    opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2)-      = Just $ ProofIrrelProv $ opt_trans is kco1 kco2-    opt_trans_prov (PluginProv str1)     (PluginProv str2)     | str1 == str2 = Just p1-    opt_trans_prov _ _ = Nothing---- Push transitivity down through matching top-level constructors.-opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2)-  | tc1 == tc2-  = ASSERT( r1 == r2 )-    fireTransRule "PushTyConApp" in_co1 in_co2 $-    mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2)--opt_trans_rule is in_co1@(FunCo r1 co1a co1b) in_co2@(FunCo r2 co2a co2b)-  = ASSERT( r1 == r2 )   -- Just like the TyConAppCo/TyConAppCo case-    fireTransRule "PushFun" in_co1 in_co2 $-    mkFunCo r1 (opt_trans is co1a co2a) (opt_trans is co1b co2b)--opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)-  -- Must call opt_trans_rule_app; see Note [EtaAppCo]-  = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b]---- Eta rules-opt_trans_rule is co1@(TyConAppCo r tc cos1) co2-  | Just cos2 <- etaTyConAppCo_maybe tc co2-  = ASSERT( cos1 `equalLength` cos2 )-    fireTransRule "EtaCompL" co1 co2 $-    mkTyConAppCo r tc (opt_transList is cos1 cos2)--opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)-  | Just cos1 <- etaTyConAppCo_maybe tc co1-  = ASSERT( cos1 `equalLength` cos2 )-    fireTransRule "EtaCompR" co1 co2 $-    mkTyConAppCo r tc (opt_transList is cos1 cos2)--opt_trans_rule is co1@(AppCo co1a co1b) co2-  | Just (co2a,co2b) <- etaAppCo_maybe co2-  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]--opt_trans_rule is co1 co2@(AppCo co2a co2b)-  | Just (co1a,co1b) <- etaAppCo_maybe co1-  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]---- Push transitivity inside forall--- forall over types.-opt_trans_rule is co1 co2-  | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1-  , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2-  = push_trans tv1 eta1 r1 tv2 eta2 r2--  | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2-  , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1-  = push_trans tv1 eta1 r1 tv2 eta2 r2--  where-  push_trans tv1 eta1 r1 tv2 eta2 r2-    -- Given:-    --   co1 = /\ tv1 : eta1. r1-    --   co2 = /\ tv2 : eta2. r2-    -- Wanted:-    --   /\tv1 : (eta1;eta2).  (r1; r2[tv2 |-> tv1 |> eta1])-    = fireTransRule "EtaAllTy_ty" co1 co2 $-      mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2')-    where-      is' = is `extendInScopeSet` tv1-      r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2---- Push transitivity inside forall--- forall over coercions.-opt_trans_rule is co1 co2-  | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1-  , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2-  = push_trans cv1 eta1 r1 cv2 eta2 r2--  | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2-  , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1-  = push_trans cv1 eta1 r1 cv2 eta2 r2--  where-  push_trans cv1 eta1 r1 cv2 eta2 r2-    -- Given:-    --   co1 = /\ cv1 : eta1. r1-    --   co2 = /\ cv2 : eta2. r2-    -- Wanted:-    --   n1 = nth 2 eta1-    --   n2 = nth 3 eta1-    --   nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2])-    = fireTransRule "EtaAllTy_co" co1 co2 $-      mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2')-    where-      is'  = is `extendInScopeSet` cv1-      role = coVarRole cv1-      eta1' = downgradeRole role Nominal eta1-      n1   = mkNthCo role 2 eta1'-      n2   = mkNthCo role 3 eta1'-      r2'  = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo`-                                        (mkCoVarCo cv1) `mkTransCo` n2])-                    r2---- Push transitivity inside axioms-opt_trans_rule is co1 co2--  -- See Note [Why call checkAxInstCo during optimisation]-  -- TrPushSymAxR-  | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe-  , True <- sym-  , Just cos2 <- matchAxiom sym con ind co2-  , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1)-  , Nothing <- checkAxInstCo newAxInst-  = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst--  -- TrPushAxR-  | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe-  , False <- sym-  , Just cos2 <- matchAxiom sym con ind co2-  , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)-  , Nothing <- checkAxInstCo newAxInst-  = fireTransRule "TrPushAxR" co1 co2 newAxInst--  -- TrPushSymAxL-  | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe-  , True <- sym-  , Just cos1 <- matchAxiom (not sym) con ind co1-  , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1))-  , Nothing <- checkAxInstCo newAxInst-  = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst--  -- TrPushAxL-  | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe-  , False <- sym-  , Just cos1 <- matchAxiom (not sym) con ind co1-  , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)-  , Nothing <- checkAxInstCo newAxInst-  = fireTransRule "TrPushAxL" co1 co2 newAxInst--  -- TrPushAxSym/TrPushSymAx-  | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe-  , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe-  , con1 == con2-  , ind1 == ind2-  , sym1 == not sym2-  , let branch = coAxiomNthBranch con1 ind1-        qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch-        lhs  = coAxNthLHS con1 ind1-        rhs  = coAxBranchRHS branch-        pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs)-  , all (`elemVarSet` pivot_tvs) qtvs-  = fireTransRule "TrPushAxSym" co1 co2 $-    if sym2-       -- TrPushAxSym-    then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs-       -- TrPushSymAx-    else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs-  where-    co1_is_axiom_maybe = isAxiom_maybe co1-    co2_is_axiom_maybe = isAxiom_maybe co2-    role = coercionRole co1 -- should be the same as coercionRole co2!--opt_trans_rule _ co1 co2        -- Identity rule-  | let ty1 = coercionLKind co1-        r   = coercionRole co1-        ty2 = coercionRKind co2-  , ty1 `eqType` ty2-  = fireTransRule "RedTypeDirRefl" co1 co2 $-    mkReflCo r ty2--opt_trans_rule _ _ _ = Nothing---- See Note [EtaAppCo]-opt_trans_rule_app :: InScopeSet-                   -> Coercion   -- original left-hand coercion (printing only)-                   -> Coercion   -- original right-hand coercion (printing only)-                   -> Coercion   -- left-hand coercion "function"-                   -> [Coercion] -- left-hand coercion "args"-                   -> Coercion   -- right-hand coercion "function"-                   -> [Coercion] -- right-hand coercion "args"-                   -> Maybe Coercion-opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs-  | AppCo co1aa co1ab <- co1a-  , Just (co2aa, co2ab) <- etaAppCo_maybe co2a-  = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)--  | AppCo co2aa co2ab <- co2a-  , Just (co1aa, co1ab) <- etaAppCo_maybe co1a-  = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)--  | otherwise-  = ASSERT( co1bs `equalLength` co2bs )-    fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $-    let rt1a = coercionRKind co1a--        lt2a = coercionLKind co2a-        rt2a = coercionRole  co2a--        rt1bs = map coercionRKind co1bs-        lt2bs = map coercionLKind co2bs-        rt2bs = map coercionRole co2bs--        kcoa = mkKindCo $ buildCoercion lt2a rt1a-        kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs--        co2a'   = mkCoherenceLeftCo rt2a lt2a kcoa co2a-        co2bs'  = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs-        co2bs'' = zipWith mkTransCo co2bs' co2bs-    in-    mkAppCos (opt_trans is co1a co2a')-             (zipWith (opt_trans is) co1bs co2bs'')--fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion-fireTransRule _rule _co1 _co2 res-  = Just res--{--Note [Conflict checking with AxiomInstCo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the following type family and axiom:--type family Equal (a :: k) (b :: k) :: Bool-type instance where-  Equal a a = True-  Equal a b = False----Equal :: forall k::*. k -> k -> Bool-axEqual :: { forall k::*. forall a::k. Equal k a a ~ True-           ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False }--We wish to disallow (axEqual[1] <*> <Int> <Int). (Recall that the index is-0-based, so this is the second branch of the axiom.) The problem is that, on-the surface, it seems that (axEqual[1] <*> <Int> <Int>) :: (Equal * Int Int ~-False) and that all is OK. But, all is not OK: we want to use the first branch-of the axiom in this case, not the second. The problem is that the parameters-of the first branch can unify with the supplied coercions, thus meaning that-the first branch should be taken. See also Note [Apartness] in-types/FamInstEnv.hs.--Note [Why call checkAxInstCo during optimisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It is possible that otherwise-good-looking optimisations meet with disaster-in the presence of axioms with multiple equations. Consider--type family Equal (a :: *) (b :: *) :: Bool where-  Equal a a = True-  Equal a b = False-type family Id (a :: *) :: * where-  Id a = a--axEq :: { [a::*].       Equal a a ~ True-        ; [a::*, b::*]. Equal a b ~ False }-axId :: [a::*]. Id a ~ a--co1 = Equal (axId[0] Int) (axId[0] Bool)-  :: Equal (Id Int) (Id Bool) ~  Equal Int Bool-co2 = axEq[1] <Int> <Bool>-  :: Equal Int Bool ~ False--We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that-co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what-happens when we push the coercions inside? We get--co3 = axEq[1] (axId[0] Int) (axId[0] Bool)-  :: Equal (Id Int) (Id Bool) ~ False--which is bogus! This is because the type system isn't smart enough to know-that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type-families. At the time of writing, I (Richard Eisenberg) couldn't think of-a way of detecting this any more efficient than just building the optimised-coercion and checking.--Note [EtaAppCo]-~~~~~~~~~~~~~~~-Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd-like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that-the resultant coercions might not be well kinded. Here is an example (things-labeled with x don't matter in this example):--  k1 :: Type-  k2 :: Type--  a :: k1 -> Type-  b :: k1--  h :: k1 ~ k2--  co1a :: x1 ~ (a |> (h -> <Type>)-  co1b :: x2 ~ (b |> h)--  co2a :: a ~ x3-  co2b :: b ~ x4--First, convince yourself of the following:--  co1a co1b :: x1 x2 ~ (a |> (h -> <Type>)) (b |> h)-  co2a co2b :: a b   ~ x3 x4--  (a |> (h -> <Type>)) (b |> h) `eqType` a b--That last fact is due to Note [Non-trivial definitional equality] in TyCoRep,-where we ignore coercions in types as long as two types' kinds are the same.-In our case, we meet this last condition, because--  (a |> (h -> <Type>)) (b |> h) :: Type-    and-  a b :: Type--So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the-suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the-kinds don't match up.--The solution here is to twiddle the kinds in the output coercions. First, we-need to find coercions--  ak :: kind(a |> (h -> <Type>)) ~ kind(a)-  bk :: kind(b |> h)             ~ kind(b)--This can be done with mkKindCo and buildCoercion. The latter assumes two-types are identical modulo casts and builds a coercion between them.--Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the-output coercions. These are well-kinded.--Also, note that all of this is done after accumulated any nested AppCo-parameters. This step is to avoid quadratic behavior in calling coercionKind.--The problem described here was first found in dependent/should_compile/dynamic-paper.---}---- | Check to make sure that an AxInstCo is internally consistent.--- Returns the conflicting branch, if it exists--- See Note [Conflict checking with AxiomInstCo]-checkAxInstCo :: Coercion -> Maybe CoAxBranch--- defined here to avoid dependencies in Coercion--- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism] in GHC.Core.Lint-checkAxInstCo (AxiomInstCo ax ind cos)-  = let branch       = coAxiomNthBranch ax ind-        tvs          = coAxBranchTyVars branch-        cvs          = coAxBranchCoVars branch-        incomps      = coAxBranchIncomps branch-        (tys, cotys) = splitAtList tvs (map coercionLKind cos)-        co_args      = map stripCoercionTy cotys-        subst        = zipTvSubst tvs tys `composeTCvSubst`-                       zipCvSubst cvs co_args-        target   = Type.substTys subst (coAxBranchLHS branch)-        in_scope = mkInScopeSet $-                   unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps)-        flattened_target = flattenTys in_scope target in-    check_no_conflict flattened_target incomps-  where-    check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch-    check_no_conflict _    [] = Nothing-    check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest)-         -- See Note [Apartness] in FamInstEnv-      | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp-      = check_no_conflict flat rest-      | otherwise-      = Just b-checkAxInstCo _ = Nothing---------------wrapSym :: SymFlag -> Coercion -> Coercion-wrapSym sym co | sym       = mkSymCo co-               | otherwise = co---- | Conditionally set a role to be representational-wrapRole :: ReprFlag-         -> Role         -- ^ current role-         -> Coercion -> Coercion-wrapRole False _       = id-wrapRole True  current = downgradeRole Representational current---- | If we require a representational role, return that. Otherwise,--- return the "default" role provided.-chooseRole :: ReprFlag-           -> Role    -- ^ "default" role-           -> Role-chooseRole True _ = Representational-chooseRole _    r = r--------------isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion])-isAxiom_maybe (SymCo co)-  | Just (sym, con, ind, cos) <- isAxiom_maybe co-  = Just (not sym, con, ind, cos)-isAxiom_maybe (AxiomInstCo con ind cos)-  = Just (False, con, ind, cos)-isAxiom_maybe _ = Nothing--matchAxiom :: Bool -- True = match LHS, False = match RHS-           -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion]-matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co-  | CoAxBranch { cab_tvs = qtvs-               , cab_cvs = []   -- can't infer these, so fail if there are any-               , cab_roles = roles-               , cab_lhs = lhs-               , cab_rhs = rhs } <- coAxiomNthBranch ax ind-  , Just subst <- liftCoMatch (mkVarSet qtvs)-                              (if sym then (mkTyConApp tc lhs) else rhs)-                              co-  , all (`isMappedByLC` subst) qtvs-  = zipWithM (liftCoSubstTyVar subst) roles qtvs--  | otherwise-  = Nothing----------------compatible_co :: Coercion -> Coercion -> Bool--- Check whether (co1 . co2) will be well-kinded-compatible_co co1 co2-  = x1 `eqType` x2-  where-    x1 = coercionRKind co1-    x2 = coercionLKind co2----------------{--etaForAllCo-~~~~~~~~~~~~~~~~~-(1) etaForAllCo_ty_maybe-Suppose we have--  g : all a1:k1.t1  ~  all a2:k2.t2--but g is *not* a ForAllCo. We want to eta-expand it. So, we do this:--  g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g))--Call the kind coercion h1 and the body coercion h2. We can see that--  h2 : t1 ~ t2[a2 |-> (a1 |> h1)]--According to the typing rule for ForAllCo, we get that--  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1])--or--  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> a1])--as desired.--(2) etaForAllCo_co_maybe-Suppose we have--  g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2--Similarly, we do this--  g' = all c1:h1. h2-     : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)]-                                              [c1 |-> eta1;c1;sym eta2]--Here,--  h1   = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4)-  eta1 = mkNthCo r 2 h1      :: (s1 ~ s3)-  eta2 = mkNthCo r 3 h1      :: (s2 ~ s4)-  h2   = mkInstCo g (cv1 ~ (sym eta1;c1;eta2))--}-etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)--- Try to make the coercion be of form (forall tv:kind_co. co)-etaForAllCo_ty_maybe co-  | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co-  = Just (tv, kind_co, r)--  | Pair ty1 ty2  <- coercionKind co-  , Just (tv1, _) <- splitForAllTy_ty_maybe ty1-  , isForAllTy_ty ty2-  , let kind_co = mkNthCo Nominal 0 co-  = Just ( tv1, kind_co-         , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co))--  | otherwise-  = Nothing--etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)--- Try to make the coercion be of form (forall cv:kind_co. co)-etaForAllCo_co_maybe co-  | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co-  = Just (cv, kind_co, r)--  | Pair ty1 ty2  <- coercionKind co-  , Just (cv1, _) <- splitForAllTy_co_maybe ty1-  , isForAllTy_co ty2-  = let kind_co  = mkNthCo Nominal 0 co-        r        = coVarRole cv1-        l_co     = mkCoVarCo cv1-        kind_co' = downgradeRole r Nominal kind_co-        r_co     = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo`-                   l_co `mkTransCo`-                   (mkNthCo r 3 kind_co')-    in Just ( cv1, kind_co-            , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co))--  | otherwise-  = Nothing--etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion)--- If possible, split a coercion---   g :: t1a t1b ~ t2a t2b--- into a pair of coercions (left g, right g)-etaAppCo_maybe co-  | Just (co1,co2) <- splitAppCo_maybe co-  = Just (co1,co2)-  | (Pair ty1 ty2, Nominal) <- coercionKindRole co-  , Just (_,t1) <- splitAppTy_maybe ty1-  , Just (_,t2) <- splitAppTy_maybe ty2-  , let isco1 = isCoercionTy t1-  , let isco2 = isCoercionTy t2-  , isco1 == isco2-  = Just (LRCo CLeft co, LRCo CRight co)-  | otherwise-  = Nothing--etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]--- If possible, split a coercion---       g :: T s1 .. sn ~ T t1 .. tn--- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ]-etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)-  = ASSERT( tc == tc2 ) Just cos2--etaTyConAppCo_maybe tc co-  | not (mustBeSaturated tc)-  , (Pair ty1 ty2, r) <- coercionKindRole co-  , Just (tc1, tys1)  <- splitTyConApp_maybe ty1-  , Just (tc2, tys2)  <- splitTyConApp_maybe ty2-  , tc1 == tc2-  , isInjectiveTyCon tc r  -- See Note [NthCo and newtypes] in TyCoRep-  , let n = length tys1-  , tys2 `lengthIs` n      -- This can fail in an erroneous program-                           -- E.g. T a ~# T a b-                           -- #14607-  = ASSERT( tc == tc1 )-    Just (decomposeCo n co (tyConRolesX r tc1))-    -- NB: n might be <> tyConArity tc-    -- e.g.   data family T a :: * -> *-    --        g :: T a b ~ T c d--  | otherwise-  = Nothing--{--Note [Eta for AppCo]-~~~~~~~~~~~~~~~~~~~~-Suppose we have-   g :: s1 t1 ~ s2 t2--Then we can't necessarily make-   left  g :: s1 ~ s2-   right g :: t1 ~ t2-because it's possible that-   s1 :: * -> *         t1 :: *-   s2 :: (*->*) -> *    t2 :: * -> *-and in that case (left g) does not have the same-kind on either side.--It's enough to check that-  kind t1 = kind t2-because if g is well-kinded then-  kind (s1 t2) = kind (s2 t2)-and these two imply-  kind s1 = kind s2---}--optForAllCoBndr :: LiftingContext -> Bool-                -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion)-optForAllCoBndr env sym-  = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env
− compiler/types/TyCoFVs.hs 
@@ -1,984 +0,0 @@-{-# LANGUAGE CPP #-}--module TyCoFVs-  (     shallowTyCoVarsOfType, shallowTyCoVarsOfTypes,-        tyCoVarsOfType,        tyCoVarsOfTypes,-        tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet,--        tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs,-        tyCoFVsOfType, tyCoVarsOfTypeList,-        tyCoFVsOfTypes, tyCoVarsOfTypesList,-        deepTcvFolder,--        shallowTyCoVarsOfTyVarEnv, shallowTyCoVarsOfCoVarEnv,--        shallowTyCoVarsOfCo, shallowTyCoVarsOfCos,-        tyCoVarsOfCo,        tyCoVarsOfCos,-        coVarsOfType, coVarsOfTypes,-        coVarsOfCo, coVarsOfCos,-        tyCoVarsOfCoDSet,-        tyCoFVsOfCo, tyCoFVsOfCos,-        tyCoVarsOfCoList,--        almostDevoidCoVarOfCo,--        -- Injective free vars-        injectiveVarsOfType, injectiveVarsOfTypes,-        invisibleVarsOfType, invisibleVarsOfTypes,--        -- No Free vars-        noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo,--        -- * Well-scoped free variables-        scopedSort, tyCoVarsOfTypeWellScoped,-        tyCoVarsOfTypesWellScoped,--        -- * Closing over kinds-        closeOverKindsDSet, closeOverKindsList,-        closeOverKinds,--        -- * Raw materials-        Endo(..), runTyCoVars-  ) where--#include "HsVersions.h"--import GhcPrelude--import {-# SOURCE #-} Type   (coreView, partitionInvisibleTypes)--import Data.Monoid as DM ( Endo(..), All(..) )-import TyCoRep-import TyCon-import Var-import FV--import UniqFM-import VarSet-import VarEnv-import Util-import Panic--{--%************************************************************************-%*                                                                      *-                 Free variables of types and coercions-%*                                                                      *-%************************************************************************--}--{- Note [Shallow and deep free variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Definitions--* Shallow free variables of a type: the variables-  affected by substitution. Specifically, the (TyVarTy tv)-  and (CoVar cv) that appear-    - In the type and coercions appearing in the type-    - In shallow free variables of the kind of a Forall binder-  but NOT in the kind of the /occurrences/ of a type variable.--* Deep free variables of a type: shallow free variables, plus-  the deep free variables of the kinds of those variables.-  That is,  deepFVs( t ) = closeOverKinds( shallowFVs( t ) )--Examples:--  Type                     Shallow     Deep-  ----------------------------------  (a : (k:Type))           {a}        {a,k}-  forall (a:(k:Type)). a   {k}        {k}-  (a:k->Type) (b:k)        {a,b}      {a,b,k}--}---{- Note [Free variables of types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns-a VarSet that is closed over the types of its variables.  More precisely,-  if    S = tyCoVarsOfType( t )-  and   (a:k) is in S-  then  tyCoVarsOftype( k ) is a subset of S--Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}.--We could /not/ close over the kinds of the variable occurrences, and-instead do so at call sites, but it seems that we always want to do-so, so it's easiest to do it here.--It turns out that getting the free variables of types is performance critical,-so we profiled several versions, exploring different implementation strategies.--1. Baseline version: uses FV naively. Essentially:--   tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty--   This is not nice, because FV introduces some overhead to implement-   determinism, and through its "interesting var" function, neither of which-   we need here, so they are a complete waste.--2. UnionVarSet version: instead of reusing the FV-based code, we simply used-   VarSets directly, trying to avoid the overhead of FV. E.g.:--   -- FV version:-   tyCoFVsOfType (AppTy fun arg)    a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c--   -- UnionVarSet version:-   tyCoVarsOfType (AppTy fun arg)    = (tyCoVarsOfType fun `unionVarSet` tyCoVarsOfType arg)--   This looks deceptively similar, but while FV internally builds a list- and-   set-generating function, the VarSet functions manipulate sets directly, and-   the latter performs a lot worse than the naive FV version.--3. Accumulator-style VarSet version: this is what we use now. We do use VarSet-   as our data structure, but delegate the actual work to a new-   ty_co_vars_of_...  family of functions, which use accumulator style and the-   "in-scope set" filter found in the internals of FV, but without the-   determinism overhead.--See #14880.--Note [Closing over free variable kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-tyCoVarsOfType and tyCoFVsOfType, while traversing a type, will also close over-free variable kinds. In previous GHC versions, this happened naively: whenever-we would encounter an occurrence of a free type variable, we would close over-its kind. This, however is wrong for two reasons (see #14880):--1. Efficiency. If we have Proxy (a::k) -> Proxy (a::k) -> Proxy (a::k), then-   we don't want to have to traverse k more than once.--2. Correctness. Imagine we have forall k. b -> k, where b has-   kind k, for some k bound in an outer scope. If we look at b's kind inside-   the forall, we'll collect that k is free and then remove k from the set of-   free variables. This is plain wrong. We must instead compute that b is free-   and then conclude that b's kind is free.--An obvious first approach is to move the closing-over-kinds from the-occurrences of a type variable to after finding the free vars - however, this-turns out to introduce performance regressions, and isn't even entirely-correct.--In fact, it isn't even important *when* we close over kinds; what matters is-that we handle each type var exactly once, and that we do it in the right-context.--So the next approach we tried was to use the "in-scope set" part of FV or the-equivalent argument in the accumulator-style `ty_co_vars_of_type` function, to-say "don't bother with variables we have already closed over". This should work-fine in theory, but the code is complicated and doesn't perform well.--But there is a simpler way, which is implemented here. Consider the two points-above:--1. Efficiency: we now have an accumulator, so the second time we encounter 'a',-   we'll ignore it, certainly not looking at its kind - this is why-   pre-checking set membership before inserting ends up not only being faster,-   but also being correct.--2. Correctness: we have an "in-scope set" (I think we should call it it a-  "bound-var set"), specifying variables that are bound by a forall in the type-  we are traversing; we simply ignore these variables, certainly not looking at-  their kind.--So now consider:--    forall k. b -> k--where b :: k->Type is free; but of course, it's a different k! When looking at-b -> k we'll have k in the bound-var set. So we'll ignore the k. But suppose-this is our first encounter with b; we want the free vars of its kind. But we-want to behave as if we took the free vars of its kind at the end; that is,-with no bound vars in scope.--So the solution is easy. The old code was this:--  ty_co_vars_of_type (TyVarTy v) is acc-    | v `elemVarSet` is  = acc-    | v `elemVarSet` acc = acc-    | otherwise          = ty_co_vars_of_type (tyVarKind v) is (extendVarSet acc v)--Now all we need to do is take the free vars of tyVarKind v *with an empty-bound-var set*, thus:--ty_co_vars_of_type (TyVarTy v) is acc-  | v `elemVarSet` is  = acc-  | v `elemVarSet` acc = acc-  | otherwise          = ty_co_vars_of_type (tyVarKind v) emptyVarSet (extendVarSet acc v)-                                                          ^^^^^^^^^^^--And that's it. This works because a variable is either bound or free. If it is bound,-then we won't look at it at all. If it is free, then all the variables free in its-kind are free -- regardless of whether some local variable has the same Unique.-So if we're looking at a variable occurrence at all, then all variables in its-kind are free.--}--{- *********************************************************************-*                                                                      *-          Endo for free variables-*                                                                      *-********************************************************************* -}--{- Note [Acumulating parameter free variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We can use foldType to build an accumulating-parameter version of a-free-var finder, thus:--    fvs :: Type -> TyCoVarSet-    fvs ty = appEndo (foldType folder ty) emptyVarSet--Recall that-    foldType :: TyCoFolder env a -> env -> Type -> a--    newtype Endo a = Endo (a -> a)   -- In Data.Monoid-    instance Monoid a => Monoid (Endo a) where-       (Endo f) `mappend` (Endo g) = Endo (f.g)--    appEndo :: Endo a -> a -> a-    appEndo (Endo f) x = f x--So `mappend` for Endos is just function composition.--It's very important that, after optimisation, we end up with-* an arity-three function-* that is strict in the accumulator--   fvs env (TyVarTy v) acc-      | v `elemVarSet` env = acc-      | v `elemVarSet` acc = acc-      | otherwise          = acc `extendVarSet` v-   fvs env (AppTy t1 t2)   = fvs env t1 (fvs env t2 acc)-   ...--The "strict in the accumulator" part is to ensure that in the-AppTy equation we don't build a thunk for (fvs env t2 acc).--The optimiser does do all this, but not very robustly. It depends-critially on the basic arity-2 function not being exported, so that-all its calls are visibly to three arguments. This analysis is-done by the Call Arity pass.--TL;DR: check this regularly!--}--runTyCoVars :: Endo TyCoVarSet -> TyCoVarSet-{-# INLINE runTyCoVars #-}-runTyCoVars f = appEndo f emptyVarSet--noView :: Type -> Maybe Type-noView _ = Nothing--{- *********************************************************************-*                                                                      *-          Deep free variables-          See Note [Shallow and deep free variables]-*                                                                      *-********************************************************************* -}--tyCoVarsOfType :: Type -> TyCoVarSet-tyCoVarsOfType ty = runTyCoVars (deep_ty ty)--- Alternative:---   tyCoVarsOfType ty = closeOverKinds (shallowTyCoVarsOfType ty)--tyCoVarsOfTypes :: [Type] -> TyCoVarSet-tyCoVarsOfTypes tys = runTyCoVars (deep_tys tys)--- Alternative:---   tyCoVarsOfTypes tys = closeOverKinds (shallowTyCoVarsOfTypes tys)--tyCoVarsOfCo :: Coercion -> TyCoVarSet--- See Note [Free variables of Coercions]-tyCoVarsOfCo co = runTyCoVars (deep_co co)--tyCoVarsOfCos :: [Coercion] -> TyCoVarSet-tyCoVarsOfCos cos = runTyCoVars (deep_cos cos)--deep_ty  :: Type       -> Endo TyCoVarSet-deep_tys :: [Type]     -> Endo TyCoVarSet-deep_co  :: Coercion   -> Endo TyCoVarSet-deep_cos :: [Coercion] -> Endo TyCoVarSet-(deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet--deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)-deepTcvFolder = TyCoFolder { tcf_view = noView-                           , tcf_tyvar = do_tcv, tcf_covar = do_tcv-                           , tcf_hole  = do_hole, tcf_tycobinder = do_bndr }-  where-    do_tcv is v = Endo do_it-      where-        do_it acc | v `elemVarSet` is  = acc-                  | v `elemVarSet` acc = acc-                  | otherwise          = appEndo (deep_ty (varType v)) $-                                         acc `extendVarSet` v--    do_bndr is tcv _ = extendVarSet is tcv-    do_hole is hole  = do_tcv is (coHoleCoVar hole)-                       -- See Note [CoercionHoles and coercion free variables]-                       -- in TyCoRep--{- *********************************************************************-*                                                                      *-          Shallow free variables-          See Note [Shallow and deep free variables]-*                                                                      *-********************************************************************* -}---shallowTyCoVarsOfType :: Type -> TyCoVarSet--- See Note [Free variables of types]-shallowTyCoVarsOfType ty = runTyCoVars (shallow_ty ty)--shallowTyCoVarsOfTypes :: [Type] -> TyCoVarSet-shallowTyCoVarsOfTypes tys = runTyCoVars (shallow_tys tys)--shallowTyCoVarsOfCo :: Coercion -> TyCoVarSet-shallowTyCoVarsOfCo co = runTyCoVars (shallow_co co)--shallowTyCoVarsOfCos :: [Coercion] -> TyCoVarSet-shallowTyCoVarsOfCos cos = runTyCoVars (shallow_cos cos)---- | Returns free variables of types, including kind variables as--- a non-deterministic set. For type synonyms it does /not/ expand the--- synonym.-shallowTyCoVarsOfTyVarEnv :: TyVarEnv Type -> TyCoVarSet--- See Note [Free variables of types]-shallowTyCoVarsOfTyVarEnv tys = shallowTyCoVarsOfTypes (nonDetEltsUFM tys)-  -- It's OK to use nonDetEltsUFM here because we immediately-  -- forget the ordering by returning a set--shallowTyCoVarsOfCoVarEnv :: CoVarEnv Coercion -> TyCoVarSet-shallowTyCoVarsOfCoVarEnv cos = shallowTyCoVarsOfCos (nonDetEltsUFM cos)-  -- It's OK to use nonDetEltsUFM here because we immediately-  -- forget the ordering by returning a set--shallow_ty  :: Type       -> Endo TyCoVarSet-shallow_tys :: [Type]     -> Endo TyCoVarSet-shallow_co  :: Coercion   -> Endo TyCoVarSet-shallow_cos :: [Coercion] -> Endo TyCoVarSet-(shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet--shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)-shallowTcvFolder = TyCoFolder { tcf_view = noView-                              , tcf_tyvar = do_tcv, tcf_covar = do_tcv-                              , tcf_hole  = do_hole, tcf_tycobinder = do_bndr }-  where-    do_tcv is v = Endo do_it-      where-        do_it acc | v `elemVarSet` is  = acc-                  | v `elemVarSet` acc = acc-                  | otherwise          = acc `extendVarSet` v--    do_bndr is tcv _ = extendVarSet is tcv-    do_hole _ _  = mempty   -- Ignore coercion holes---{- *********************************************************************-*                                                                      *-          Free coercion variables-*                                                                      *-********************************************************************* -}---{- Note [Finding free coercion varibles]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Here we are only interested in the free /coercion/ variables.-We can achieve this through a slightly differnet TyCo folder.--Notice that we look deeply, into kinds.--See #14880.--}--coVarsOfType  :: Type       -> CoVarSet-coVarsOfTypes :: [Type]     -> CoVarSet-coVarsOfCo    :: Coercion   -> CoVarSet-coVarsOfCos   :: [Coercion] -> CoVarSet--coVarsOfType  ty  = runTyCoVars (deep_cv_ty ty)-coVarsOfTypes tys = runTyCoVars (deep_cv_tys tys)-coVarsOfCo    co  = runTyCoVars (deep_cv_co co)-coVarsOfCos   cos = runTyCoVars (deep_cv_cos cos)--deep_cv_ty  :: Type       -> Endo CoVarSet-deep_cv_tys :: [Type]     -> Endo CoVarSet-deep_cv_co  :: Coercion   -> Endo CoVarSet-deep_cv_cos :: [Coercion] -> Endo CoVarSet-(deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos) = foldTyCo deepCoVarFolder emptyVarSet--deepCoVarFolder :: TyCoFolder TyCoVarSet (Endo CoVarSet)-deepCoVarFolder = TyCoFolder { tcf_view = noView-                             , tcf_tyvar = do_tyvar, tcf_covar = do_covar-                             , tcf_hole  = do_hole, tcf_tycobinder = do_bndr }-  where-    do_tyvar _ _  = mempty-      -- This do_tyvar means we won't see any CoVars in this-      -- TyVar's kind.   This may be wrong; but it's the way it's-      -- always been.  And its awkward to change, because-      -- the tyvar won't end up in the accumulator, so-      -- we'd look repeatedly.  Blargh.--    do_covar is v = Endo do_it-      where-        do_it acc | v `elemVarSet` is  = acc-                  | v `elemVarSet` acc = acc-                  | otherwise          = appEndo (deep_cv_ty (varType v)) $-                                         acc `extendVarSet` v--    do_bndr is tcv _ = extendVarSet is tcv-    do_hole is hole  = do_covar is (coHoleCoVar hole)-                       -- See Note [CoercionHoles and coercion free variables]-                       -- in TyCoRep---{- *********************************************************************-*                                                                      *-          Closing over kinds-*                                                                      *-********************************************************************* -}--------------- Closing over kinds -------------------closeOverKinds :: TyCoVarSet -> TyCoVarSet--- For each element of the input set,--- add the deep free variables of its kind-closeOverKinds vs = nonDetFoldVarSet do_one vs vs-  where-    do_one v acc = appEndo (deep_ty (varType v)) acc--{- --------------- Alternative version 1 (using FV) -------------closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet--}--{- ---------------- Alternative version 2 ----------------- | Add the kind variables free in the kinds of the tyvars in the given set.--- Returns a non-deterministic set.-closeOverKinds :: TyCoVarSet -> TyCoVarSet-closeOverKinds vs-   = go vs vs-  where-    go :: VarSet   -- Work list-       -> VarSet   -- Accumulator, always a superset of wl-       -> VarSet-    go wl acc-      | isEmptyVarSet wl = acc-      | otherwise        = go wl_kvs (acc `unionVarSet` wl_kvs)-      where-        k v inner_acc = ty_co_vars_of_type (varType v) acc inner_acc-        wl_kvs = nonDetFoldVarSet k emptyVarSet wl-        -- wl_kvs = union of shallow free vars of the kinds of wl-        --          but don't bother to collect vars in acc---}--{- ---------------- Alternative version 3 ---------------- | Add the kind variables free in the kinds of the tyvars in the given set.--- Returns a non-deterministic set.-closeOverKinds :: TyVarSet -> TyVarSet-closeOverKinds vs = close_over_kinds vs emptyVarSet---close_over_kinds :: TyVarSet  -- Work list-                 -> TyVarSet  -- Accumulator-                 -> TyVarSet--- Precondition: in any call (close_over_kinds wl acc)---  for every tv in acc, the shallow kind-vars of tv---  are either in the work list wl, or in acc--- Postcondition: result is the deep free vars of (wl `union` acc)-close_over_kinds wl acc-  = nonDetFoldVarSet do_one acc wl-  where-    do_one :: Var -> TyVarSet -> TyVarSet-    -- (do_one v acc) adds v and its deep free-vars to acc-    do_one v acc | v `elemVarSet` acc-                 = acc-                 | otherwise-                 = close_over_kinds (shallowTyCoVarsOfType (varType v)) $-                   acc `extendVarSet` v--}---{- *********************************************************************-*                                                                      *-          The FV versions return deterministic results-*                                                                      *-********************************************************************* -}---- | Given a list of tyvars returns a deterministic FV computation that--- returns the given tyvars with the kind variables free in the kinds of the--- given tyvars.-closeOverKindsFV :: [TyVar] -> FV-closeOverKindsFV tvs =-  mapUnionFV (tyCoFVsOfType . tyVarKind) tvs `unionFV` mkFVs tvs---- | Add the kind variables free in the kinds of the tyvars in the given set.--- Returns a deterministically ordered list.-closeOverKindsList :: [TyVar] -> [TyVar]-closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs---- | Add the kind variables free in the kinds of the tyvars in the given set.--- Returns a deterministic set.-closeOverKindsDSet :: DTyVarSet -> DTyVarSet-closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems---- | `tyCoFVsOfType` that returns free variables of a type in a deterministic--- set. For explanation of why using `VarSet` is not deterministic see--- Note [Deterministic FV] in FV.-tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet--- See Note [Free variables of types]-tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty---- | `tyCoFVsOfType` that returns free variables of a type in deterministic--- order. For explanation of why using `VarSet` is not deterministic see--- Note [Deterministic FV] in FV.-tyCoVarsOfTypeList :: Type -> [TyCoVar]--- See Note [Free variables of types]-tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty---- | Returns free variables of types, including kind variables as--- a deterministic set. For type synonyms it does /not/ expand the--- synonym.-tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet--- See Note [Free variables of types]-tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys---- | Returns free variables of types, including kind variables as--- a deterministically ordered list. For type synonyms it does /not/ expand the--- synonym.-tyCoVarsOfTypesList :: [Type] -> [TyCoVar]--- See Note [Free variables of types]-tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys---- | The worker for `tyCoFVsOfType` and `tyCoFVsOfTypeList`.--- The previous implementation used `unionVarSet` which is O(n+m) and can--- make the function quadratic.--- It's exported, so that it can be composed with--- other functions that compute free variables.--- See Note [FV naming conventions] in FV.------ Eta-expanded because that makes it run faster (apparently)--- See Note [FV eta expansion] in FV for explanation.-tyCoFVsOfType :: Type -> FV--- See Note [Free variables of types]-tyCoFVsOfType (TyVarTy v)        f bound_vars (acc_list, acc_set)-  | not (f v) = (acc_list, acc_set)-  | v `elemVarSet` bound_vars = (acc_list, acc_set)-  | v `elemVarSet` acc_set = (acc_list, acc_set)-  | otherwise = tyCoFVsOfType (tyVarKind v) f-                               emptyVarSet   -- See Note [Closing over free variable kinds]-                               (v:acc_list, extendVarSet acc_set v)-tyCoFVsOfType (TyConApp _ tys)   f bound_vars acc = tyCoFVsOfTypes tys f bound_vars acc-tyCoFVsOfType (LitTy {})         f bound_vars acc = emptyFV f bound_vars acc-tyCoFVsOfType (AppTy fun arg)    f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc-tyCoFVsOfType (FunTy _ arg res)  f bound_vars acc = (tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc-tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty)  f bound_vars acc-tyCoFVsOfType (CastTy ty co)     f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc-tyCoFVsOfType (CoercionTy co)    f bound_vars acc = tyCoFVsOfCo co f bound_vars acc--tyCoFVsBndr :: TyCoVarBinder -> FV -> FV--- Free vars of (forall b. <thing with fvs>)-tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs--tyCoFVsVarBndrs :: [Var] -> FV -> FV-tyCoFVsVarBndrs vars fvs = foldr tyCoFVsVarBndr fvs vars--tyCoFVsVarBndr :: Var -> FV -> FV-tyCoFVsVarBndr var fvs-  = tyCoFVsOfType (varType var)   -- Free vars of its type/kind-    `unionFV` delFV var fvs       -- Delete it from the thing-inside--tyCoFVsOfTypes :: [Type] -> FV--- See Note [Free variables of types]-tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc-tyCoFVsOfTypes []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc---- | Get a deterministic set of the vars free in a coercion-tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet--- See Note [Free variables of types]-tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co--tyCoVarsOfCoList :: Coercion -> [TyCoVar]--- See Note [Free variables of types]-tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co--tyCoFVsOfMCo :: MCoercion -> FV-tyCoFVsOfMCo MRefl    = emptyFV-tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co--tyCoFVsOfCo :: Coercion -> FV--- Extracts type and coercion variables from a coercion--- See Note [Free variables of types]-tyCoFVsOfCo (Refl ty) fv_cand in_scope acc-  = tyCoFVsOfType ty fv_cand in_scope acc-tyCoFVsOfCo (GRefl _ ty mco) fv_cand in_scope acc-  = (tyCoFVsOfType ty `unionFV` tyCoFVsOfMCo mco) fv_cand in_scope acc-tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc-tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc-  = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc-tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc-  = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc-tyCoFVsOfCo (FunCo _ co1 co2)    fv_cand in_scope acc-  = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc-tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc-  = tyCoFVsOfCoVar v fv_cand in_scope acc-tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc-  = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc-    -- See Note [CoercionHoles and coercion free variables]-tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc-tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc-  = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1-                     `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc-tyCoFVsOfCo (SymCo co)          fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc-tyCoFVsOfCo (TransCo co1 co2)   fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc-tyCoFVsOfCo (NthCo _ _ co)      fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc-tyCoFVsOfCo (LRCo _ co)         fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc-tyCoFVsOfCo (InstCo co arg)     fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc-tyCoFVsOfCo (KindCo co)         fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc-tyCoFVsOfCo (SubCo co)          fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc-tyCoFVsOfCo (AxiomRuleCo _ cs)  fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc--tyCoFVsOfCoVar :: CoVar -> FV-tyCoFVsOfCoVar v fv_cand in_scope acc-  = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc--tyCoFVsOfProv :: UnivCoProvenance -> FV-tyCoFVsOfProv (PhantomProv co)    fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc-tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc-tyCoFVsOfProv (PluginProv _)      fv_cand in_scope acc = emptyFV fv_cand in_scope acc--tyCoFVsOfCos :: [Coercion] -> FV-tyCoFVsOfCos []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc-tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc-------- Whether a covar is /Almost Devoid/ in a type or coercion -------- | Given a covar and a coercion, returns True if covar is almost devoid in--- the coercion. That is, covar can only appear in Refl and GRefl.--- See last wrinkle in Note [Unused coercion variable in ForAllCo] in Coercion-almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool-almostDevoidCoVarOfCo cv co =-  almost_devoid_co_var_of_co co cv--almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool-almost_devoid_co_var_of_co (Refl {}) _ = True   -- covar is allowed in Refl and-almost_devoid_co_var_of_co (GRefl {}) _ = True  -- GRefl, so we don't look into-                                                -- the coercions-almost_devoid_co_var_of_co (TyConAppCo _ _ cos) cv-  = almost_devoid_co_var_of_cos cos cv-almost_devoid_co_var_of_co (AppCo co arg) cv-  = almost_devoid_co_var_of_co co cv-  && almost_devoid_co_var_of_co arg cv-almost_devoid_co_var_of_co (ForAllCo v kind_co co) cv-  = almost_devoid_co_var_of_co kind_co cv-  && (v == cv || almost_devoid_co_var_of_co co cv)-almost_devoid_co_var_of_co (FunCo _ co1 co2) cv-  = almost_devoid_co_var_of_co co1 cv-  && almost_devoid_co_var_of_co co2 cv-almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv-almost_devoid_co_var_of_co (HoleCo h)  cv = (coHoleCoVar h) /= cv-almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv-  = almost_devoid_co_var_of_cos cos cv-almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv-  = almost_devoid_co_var_of_prov p cv-  && almost_devoid_co_var_of_type t1 cv-  && almost_devoid_co_var_of_type t2 cv-almost_devoid_co_var_of_co (SymCo co) cv-  = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_co (TransCo co1 co2) cv-  = almost_devoid_co_var_of_co co1 cv-  && almost_devoid_co_var_of_co co2 cv-almost_devoid_co_var_of_co (NthCo _ _ co) cv-  = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_co (LRCo _ co) cv-  = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_co (InstCo co arg) cv-  = almost_devoid_co_var_of_co co cv-  && almost_devoid_co_var_of_co arg cv-almost_devoid_co_var_of_co (KindCo co) cv-  = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_co (SubCo co) cv-  = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_co (AxiomRuleCo _ cs) cv-  = almost_devoid_co_var_of_cos cs cv--almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool-almost_devoid_co_var_of_cos [] _ = True-almost_devoid_co_var_of_cos (co:cos) cv-  = almost_devoid_co_var_of_co co cv-  && almost_devoid_co_var_of_cos cos cv--almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool-almost_devoid_co_var_of_prov (PhantomProv co) cv-  = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_prov (ProofIrrelProv co) cv-  = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_prov (PluginProv _) _ = True--almost_devoid_co_var_of_type :: Type -> CoVar -> Bool-almost_devoid_co_var_of_type (TyVarTy _) _ = True-almost_devoid_co_var_of_type (TyConApp _ tys) cv-  = almost_devoid_co_var_of_types tys cv-almost_devoid_co_var_of_type (LitTy {}) _ = True-almost_devoid_co_var_of_type (AppTy fun arg) cv-  = almost_devoid_co_var_of_type fun cv-  && almost_devoid_co_var_of_type arg cv-almost_devoid_co_var_of_type (FunTy _ arg res) cv-  = almost_devoid_co_var_of_type arg cv-  && almost_devoid_co_var_of_type res cv-almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv-  = almost_devoid_co_var_of_type (varType v) cv-  && (v == cv || almost_devoid_co_var_of_type ty cv)-almost_devoid_co_var_of_type (CastTy ty co) cv-  = almost_devoid_co_var_of_type ty cv-  && almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_type (CoercionTy co) cv-  = almost_devoid_co_var_of_co co cv--almost_devoid_co_var_of_types :: [Type] -> CoVar -> Bool-almost_devoid_co_var_of_types [] _ = True-almost_devoid_co_var_of_types (ty:tys) cv-  = almost_devoid_co_var_of_type ty cv-  && almost_devoid_co_var_of_types tys cv----{- *********************************************************************-*                                                                      *-                 Injective free vars-*                                                                      *-********************************************************************* -}---- | Returns the free variables of a 'Type' that are in injective positions.--- Specifically, it finds the free variables while:------ * Expanding type synonyms------ * Ignoring the coercion in @(ty |> co)@------ * Ignoring the non-injective fields of a 'TyConApp'--------- For example, if @F@ is a non-injective type family, then:------ @--- injectiveTyVarsOf( Either c (Maybe (a, F b c)) ) = {a,c}--- @------ If @'injectiveVarsOfType' ty = itvs@, then knowing @ty@ fixes @itvs@.--- More formally, if--- @a@ is in @'injectiveVarsOfType' ty@--- and  @S1(ty) ~ S2(ty)@,--- then @S1(a)  ~ S2(a)@,--- where @S1@ and @S2@ are arbitrary substitutions.------ See @Note [When does a tycon application need an explicit kind signature?]@.-injectiveVarsOfType :: Bool   -- ^ Should we look under injective type families?-                              -- See Note [Coverage condition for injective type families]-                              -- in FamInst.-                    -> Type -> FV-injectiveVarsOfType look_under_tfs = go-  where-    go ty                 | Just ty' <- coreView ty-                          = go ty'-    go (TyVarTy v)        = unitFV v `unionFV` go (tyVarKind v)-    go (AppTy f a)        = go f `unionFV` go a-    go (FunTy _ ty1 ty2)  = go ty1 `unionFV` go ty2-    go (TyConApp tc tys)  =-      case tyConInjectivityInfo tc of-        Injective inj-          |  look_under_tfs || not (isTypeFamilyTyCon tc)-          -> mapUnionFV go $-             filterByList (inj ++ repeat True) tys-                         -- Oversaturated arguments to a tycon are-                         -- always injective, hence the repeat True-        _ -> emptyFV-    go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `unionFV` delFV tv (go ty)-    go LitTy{}                   = emptyFV-    go (CastTy ty _)             = go ty-    go CoercionTy{}              = emptyFV---- | Returns the free variables of a 'Type' that are in injective positions.--- Specifically, it finds the free variables while:------ * Expanding type synonyms------ * Ignoring the coercion in @(ty |> co)@------ * Ignoring the non-injective fields of a 'TyConApp'------ See @Note [When does a tycon application need an explicit kind signature?]@.-injectiveVarsOfTypes :: Bool -- ^ look under injective type families?-                             -- See Note [Coverage condition for injective type families]-                             -- in FamInst.-                     -> [Type] -> FV-injectiveVarsOfTypes look_under_tfs = mapUnionFV (injectiveVarsOfType look_under_tfs)---{- *********************************************************************-*                                                                      *-                 Invisible vars-*                                                                      *-********************************************************************* -}----- | Returns the set of variables that are used invisibly anywhere within--- the given type. A variable will be included even if it is used both visibly--- and invisibly. An invisible use site includes:---   * In the kind of a variable---   * In the kind of a bound variable in a forall---   * In a coercion---   * In a Specified or Inferred argument to a function--- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep-invisibleVarsOfType :: Type -> FV-invisibleVarsOfType = go-  where-    go ty                 | Just ty' <- coreView ty-                          = go ty'-    go (TyVarTy v)        = go (tyVarKind v)-    go (AppTy f a)        = go f `unionFV` go a-    go (FunTy _ ty1 ty2)  = go ty1 `unionFV` go ty2-    go (TyConApp tc tys)  = tyCoFVsOfTypes invisibles `unionFV`-                            invisibleVarsOfTypes visibles-      where (invisibles, visibles) = partitionInvisibleTypes tc tys-    go (ForAllTy tvb ty)  = tyCoFVsBndr tvb $ go ty-    go LitTy{}            = emptyFV-    go (CastTy ty co)     = tyCoFVsOfCo co `unionFV` go ty-    go (CoercionTy co)    = tyCoFVsOfCo co---- | Like 'invisibleVarsOfType', but for many types.-invisibleVarsOfTypes :: [Type] -> FV-invisibleVarsOfTypes = mapUnionFV invisibleVarsOfType---{- *********************************************************************-*                                                                      *-                 No free vars-*                                                                      *-********************************************************************* -}--nfvFolder :: TyCoFolder TyCoVarSet DM.All-nfvFolder = TyCoFolder { tcf_view = noView-                       , tcf_tyvar = do_tcv, tcf_covar = do_tcv-                       , tcf_hole = do_hole, tcf_tycobinder = do_bndr }-  where-    do_tcv is tv = All (tv `elemVarSet` is)-    do_hole _ _  = All True    -- I'm unsure; probably never happens-    do_bndr is tv _ = is `extendVarSet` tv--nfv_ty  :: Type       -> DM.All-nfv_tys :: [Type]     -> DM.All-nfv_co  :: Coercion   -> DM.All-(nfv_ty, nfv_tys, nfv_co, _) = foldTyCo nfvFolder emptyVarSet--noFreeVarsOfType :: Type -> Bool-noFreeVarsOfType ty = DM.getAll (nfv_ty ty)--noFreeVarsOfTypes :: [Type] -> Bool-noFreeVarsOfTypes tys = DM.getAll (nfv_tys tys)--noFreeVarsOfCo :: Coercion -> Bool-noFreeVarsOfCo co = getAll (nfv_co co)---{- *********************************************************************-*                                                                      *-                 scopedSort-*                                                                      *-********************************************************************* -}--{- Note [ScopedSort]-~~~~~~~~~~~~~~~~~~~~-Consider--  foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> ()--This function type is implicitly generalised over [a, b, k, k2]. These-variables will be Specified; that is, they will be available for visible-type application. This is because they are written in the type signature-by the user.--However, we must ask: what order will they appear in? In cases without-dependency, this is easy: we just use the lexical left-to-right ordering-of first occurrence. With dependency, we cannot get off the hook so-easily.--We thus state:-- * These variables appear in the order as given by ScopedSort, where-   the input to ScopedSort is the left-to-right order of first occurrence.--Note that this applies only to *implicit* quantification, without a-`forall`. If the user writes a `forall`, then we just use the order given.--ScopedSort is defined thusly (as proposed in #15743):-  * Work left-to-right through the input list, with a cursor.-  * If variable v at the cursor is depended on by any earlier variable w,-    move v immediately before the leftmost such w.--INVARIANT: The prefix of variables before the cursor form a valid telescope.--Note that ScopedSort makes sense only after type inference is done and all-types/kinds are fully settled and zonked.---}---- | Do a topological sort on a list of tyvars,---   so that binders occur before occurrences--- E.g. given  [ a::k, k::*, b::k ]--- it'll return a well-scoped list [ k::*, a::k, b::k ]------ This is a deterministic sorting operation--- (that is, doesn't depend on Uniques).------ It is also meant to be stable: that is, variables should not--- be reordered unnecessarily. This is specified in Note [ScopedSort]--- See also Note [Ordering of implicit variables] in GHC.Rename.Types--scopedSort :: [TyCoVar] -> [TyCoVar]-scopedSort = go [] []-  where-    go :: [TyCoVar] -- already sorted, in reverse order-       -> [TyCoVarSet] -- each set contains all the variables which must be placed-                       -- before the tv corresponding to the set; they are accumulations-                       -- of the fvs in the sorted tvs' kinds--                       -- This list is in 1-to-1 correspondence with the sorted tyvars-                       -- INVARIANT:-                       --   all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list)-                       -- That is, each set in the list is a superset of all later sets.--       -> [TyCoVar] -- yet to be sorted-       -> [TyCoVar]-    go acc _fv_list [] = reverse acc-    go acc  fv_list (tv:tvs)-      = go acc' fv_list' tvs-      where-        (acc', fv_list') = insert tv acc fv_list--    insert :: TyCoVar       -- var to insert-           -> [TyCoVar]     -- sorted list, in reverse order-           -> [TyCoVarSet]  -- list of fvs, as above-           -> ([TyCoVar], [TyCoVarSet])   -- augmented lists-    insert tv []     []         = ([tv], [tyCoVarsOfType (tyVarKind tv)])-    insert tv (a:as) (fvs:fvss)-      | tv `elemVarSet` fvs-      , (as', fvss') <- insert tv as fvss-      = (a:as', fvs `unionVarSet` fv_tv : fvss')--      | otherwise-      = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss)-      where-        fv_tv = tyCoVarsOfType (tyVarKind tv)--       -- lists not in correspondence-    insert _ _ _ = panic "scopedSort"---- | Get the free vars of a type in scoped order-tyCoVarsOfTypeWellScoped :: Type -> [TyVar]-tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList---- | Get the free vars of types in scoped order-tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]-tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList-
− compiler/types/TyCoPpr.hs 
@@ -1,340 +0,0 @@--- | Pretty-printing types and coercions.-module TyCoPpr-  (-        -- * Precedence-        PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,--        -- * Pretty-printing types-        pprType, pprParendType, pprTidiedType, pprPrecType, pprPrecTypeX,-        pprTypeApp, pprTCvBndr, pprTCvBndrs,-        pprSigmaType,-        pprTheta, pprParendTheta, pprForAll, pprUserForAll,-        pprTyVar, pprTyVars,-        pprThetaArrowTy, pprClassPred,-        pprKind, pprParendKind, pprTyLit,-        pprDataCons, pprWithExplicitKindsWhen,-        pprWithTYPE, pprSourceTyCon,---        -- * Pretty-printing coercions-        pprCo, pprParendCo,--        debugPprType,--        -- * Pretty-printing 'TyThing's-        pprTyThingCategory, pprShortTyThing,-  ) where--import GhcPrelude--import {-# SOURCE #-} GHC.CoreToIface-   ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr-   , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX )--import {-# SOURCE #-} DataCon( dataConFullSig-                             , dataConUserTyVarBinders-                             , DataCon )--import {-# SOURCE #-} Type( isLiftedTypeKind )--import TyCon-import TyCoRep-import TyCoTidy-import TyCoFVs-import Class-import Var--import GHC.Iface.Type--import VarSet-import VarEnv--import Outputable-import BasicTypes ( PprPrec(..), topPrec, sigPrec, opPrec-                  , funPrec, appPrec, maybeParen )--{--%************************************************************************-%*                                                                      *-                   Pretty-printing types--       Defined very early because of debug printing in assertions-%*                                                                      *-%************************************************************************--@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is-defined to use this.  @pprParendType@ is the same, except it puts-parens around the type, except for the atomic cases.  @pprParendType@-works just by setting the initial context precedence very high.--Note that any function which pretty-prints a @Type@ first converts the @Type@-to an @IfaceType@. See Note [IfaceType and pretty-printing] in GHC.Iface.Type.--See Note [Precedence in types] in BasicTypes.--}------------------------------------------------------------- When pretty-printing types, we convert to IfaceType,---   and pretty-print that.--- See Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing-----------------------------------------------------------pprType, pprParendType, pprTidiedType :: Type -> SDoc-pprType       = pprPrecType topPrec-pprParendType = pprPrecType appPrec---- already pre-tidied-pprTidiedType = pprIfaceType . toIfaceTypeX emptyVarSet--pprPrecType :: PprPrec -> Type -> SDoc-pprPrecType = pprPrecTypeX emptyTidyEnv--pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc-pprPrecTypeX env prec ty-  = getPprStyle $ \sty ->-    if debugStyle sty           -- Use debugPprType when in-    then debug_ppr_ty prec ty   -- when in debug-style-    else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty)-    -- NB: debug-style is used for -dppr-debug-    --     dump-style  is used for -ddump-tc-trace etc--pprTyLit :: TyLit -> SDoc-pprTyLit = pprIfaceTyLit . toIfaceTyLit--pprKind, pprParendKind :: Kind -> SDoc-pprKind       = pprType-pprParendKind = pprParendType--tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType-tidyToIfaceTypeStyX env ty sty-  | userStyle sty = tidyToIfaceTypeX env ty-  | otherwise     = toIfaceTypeX (tyCoVarsOfType ty) ty-     -- in latter case, don't tidy, as we'll be printing uniques.--tidyToIfaceType :: Type -> IfaceType-tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv--tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType--- It's vital to tidy before converting to an IfaceType--- or nested binders will become indistinguishable!------ Also for the free type variables, tell toIfaceTypeX to--- leave them as IfaceFreeTyVar.  This is super-important--- for debug printing.-tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty)-  where-    env'      = tidyFreeTyCoVars env free_tcvs-    free_tcvs = tyCoVarsOfTypeWellScoped ty---------------pprCo, pprParendCo :: Coercion -> SDoc-pprCo       co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty)-pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty)--tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion-tidyToIfaceCoSty co sty-  | userStyle sty = tidyToIfaceCo co-  | otherwise     = toIfaceCoercionX (tyCoVarsOfCo co) co-     -- in latter case, don't tidy, as we'll be printing uniques.--tidyToIfaceCo :: Coercion -> IfaceCoercion--- It's vital to tidy before converting to an IfaceType--- or nested binders will become indistinguishable!------ Also for the free type variables, tell toIfaceCoercionX to--- leave them as IfaceFreeCoVar.  This is super-important--- for debug printing.-tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co)-  where-    env       = tidyFreeTyCoVars emptyTidyEnv free_tcvs-    free_tcvs = scopedSort $ tyCoVarsOfCoList co--------------pprClassPred :: Class -> [Type] -> SDoc-pprClassPred clas tys = pprTypeApp (classTyCon clas) tys---------------pprTheta :: ThetaType -> SDoc-pprTheta = pprIfaceContext topPrec . map tidyToIfaceType--pprParendTheta :: ThetaType -> SDoc-pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType--pprThetaArrowTy :: ThetaType -> SDoc-pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType---------------------pprSigmaType :: Type -> SDoc-pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType--pprForAll :: [TyCoVarBinder] -> SDoc-pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs)---- | Print a user-level forall; see Note [When to print foralls] in this module.-pprUserForAll :: [TyCoVarBinder] -> SDoc-pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr--pprTCvBndrs :: [TyCoVarBinder] -> SDoc-pprTCvBndrs tvs = sep (map pprTCvBndr tvs)--pprTCvBndr :: TyCoVarBinder -> SDoc-pprTCvBndr = pprTyVar . binderVar--pprTyVars :: [TyVar] -> SDoc-pprTyVars tvs = sep (map pprTyVar tvs)--pprTyVar :: TyVar -> SDoc--- Print a type variable binder with its kind (but not if *)--- Here we do not go via IfaceType, because the duplication with--- pprIfaceTvBndr is minimal, and the loss of uniques etc in--- debug printing is disastrous-pprTyVar tv-  | isLiftedTypeKind kind = ppr tv-  | otherwise             = parens (ppr tv <+> dcolon <+> ppr kind)-  where-    kind = tyVarKind tv--------------------debugPprType :: Type -> SDoc--- ^ debugPprType is a simple pretty printer that prints a type--- without going through IfaceType.  It does not format as prettily--- as the normal route, but it's much more direct, and that can--- be useful for debugging.  E.g. with -dppr-debug it prints the--- kind on type-variable /occurrences/ which the normal route--- fundamentally cannot do.-debugPprType ty = debug_ppr_ty topPrec ty--debug_ppr_ty :: PprPrec -> Type -> SDoc-debug_ppr_ty _ (LitTy l)-  = ppr l--debug_ppr_ty _ (TyVarTy tv)-  = ppr tv  -- With -dppr-debug we get (tv :: kind)--debug_ppr_ty prec (FunTy { ft_af = af, ft_arg = arg, ft_res = res })-  = maybeParen prec funPrec $-    sep [debug_ppr_ty funPrec arg, arrow <+> debug_ppr_ty prec res]-  where-    arrow = case af of-              VisArg   -> text "->"-              InvisArg -> text "=>"--debug_ppr_ty prec (TyConApp tc tys)-  | null tys  = ppr tc-  | otherwise = maybeParen prec appPrec $-                hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys))--debug_ppr_ty _ (AppTy t1 t2)-  = hang (debug_ppr_ty appPrec t1)  -- Print parens so we see ((a b) c)-       2 (debug_ppr_ty appPrec t2)  -- so that we can distinguish-                                    -- TyConApp from AppTy--debug_ppr_ty prec (CastTy ty co)-  = maybeParen prec topPrec $-    hang (debug_ppr_ty topPrec ty)-       2 (text "|>" <+> ppr co)--debug_ppr_ty _ (CoercionTy co)-  = parens (text "CO" <+> ppr co)--debug_ppr_ty prec ty@(ForAllTy {})-  | (tvs, body) <- split ty-  = maybeParen prec funPrec $-    hang (text "forall" <+> fsep (map ppr tvs) <> dot)-         -- The (map ppr tvs) will print kind-annotated-         -- tvs, because we are (usually) in debug-style-       2 (ppr body)-  where-    split ty | ForAllTy tv ty' <- ty-             , (tvs, body) <- split ty'-             = (tv:tvs, body)-             | otherwise-             = ([], ty)--{--Note [When to print foralls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Mostly we want to print top-level foralls when (and only when) the user specifies--fprint-explicit-foralls.  But when kind polymorphism is at work, that suppresses-too much information; see #9018.--So I'm trying out this rule: print explicit foralls if-  a) User specifies -fprint-explicit-foralls, or-  b) Any of the quantified type variables has a kind-     that mentions a kind variable--This catches common situations, such as a type siguature-     f :: m a-which means-      f :: forall k. forall (m :: k->*) (a :: k). m a-We really want to see both the "forall k" and the kind signatures-on m and a.  The latter comes from pprTCvBndr.--Note [Infix type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-With TypeOperators you can say--   f :: (a ~> b) -> b--and the (~>) is considered a type variable.  However, the type-pretty-printer in this module will just see (a ~> b) as--   App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b")--So it'll print the type in prefix form.  To avoid confusion we must-remember to parenthesise the operator, thus--   (~>) a b -> b--See #2766.--}--pprDataCons :: TyCon -> SDoc-pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons-  where-    sepWithVBars [] = empty-    sepWithVBars docs = sep (punctuate (space <> vbar) docs)--pprDataConWithArgs :: DataCon -> SDoc-pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]-  where-    (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc-    user_bndrs = dataConUserTyVarBinders dc-    forAllDoc  = pprUserForAll user_bndrs-    thetaDoc   = pprThetaArrowTy theta-    argsDoc    = hsep (fmap pprParendType arg_tys)---pprTypeApp :: TyCon -> [Type] -> SDoc-pprTypeApp tc tys-  = pprIfaceTypeApp topPrec (toIfaceTyCon tc)-                            (toIfaceTcArgs tc tys)-    -- TODO: toIfaceTcArgs seems rather wasteful here----------------------- | Display all kind information (with @-fprint-explicit-kinds@) when the--- provided 'Bool' argument is 'True'.--- See @Note [Kind arguments in error messages]@ in TcErrors.-pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc-pprWithExplicitKindsWhen b-  = updSDocContext $ \ctx ->-      if b then ctx { sdocPrintExplicitKinds = True }-           else ctx---- | This variant preserves any use of TYPE in a type, effectively--- locally setting -fprint-explicit-runtime-reps.-pprWithTYPE :: Type -> SDoc-pprWithTYPE ty = updSDocContext (\ctx -> ctx { sdocPrintExplicitRuntimeReps = True }) $-                 ppr ty---- | Pretty prints a 'TyCon', using the family instance in case of a--- representation tycon.  For example:------ > data T [a] = ...------ In that case we want to print @T [a]@, where @T@ is the family 'TyCon'-pprSourceTyCon :: TyCon -> SDoc-pprSourceTyCon tycon-  | Just (fam_tc, tys) <- tyConFamInst_maybe tycon-  = ppr $ fam_tc `TyConApp` tys        -- can't be FunTyCon-  | otherwise-  = ppr tycon
− compiler/types/TyCoPpr.hs-boot 
@@ -1,10 +0,0 @@-module TyCoPpr where--import {-# SOURCE #-} TyCoRep (Type, Kind, Coercion, TyLit)-import Outputable--pprType :: Type -> SDoc-pprKind :: Kind -> SDoc-pprCo :: Coercion -> SDoc-pprTyLit :: TyLit -> SDoc-
− compiler/types/TyCoRep.hs 
@@ -1,1848 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1998-\section[TyCoRep]{Type and Coercion - friends' interface}--Note [The Type-related module hierarchy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  Class-  CoAxiom-  TyCon    imports Class, CoAxiom-  TyCoRep  imports Class, CoAxiom, TyCon-  TyCoPpr  imports TyCoRep-  TyCoFVs  imports TyCoRep-  TyCoSubst imports TyCoRep, TyCoFVs, TyCoPpr-  TyCoTidy imports TyCoRep, TyCoFVs-  TysPrim  imports TyCoRep ( including mkTyConTy )-  Coercion imports Type--}---- We expose the relevant stuff from this module via the Type module-{-# OPTIONS_HADDOCK not-home #-}-{-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf, PatternSynonyms, BangPatterns #-}--module TyCoRep (-        TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing,--        -- * Types-        Type( TyVarTy, AppTy, TyConApp, ForAllTy-            , LitTy, CastTy, CoercionTy-            , FunTy, ft_arg, ft_res, ft_af-            ),  -- Export the type synonym FunTy too--        TyLit(..),-        KindOrType, Kind,-        KnotTied,-        PredType, ThetaType,      -- Synonyms-        ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..),--        -- * Coercions-        Coercion(..),-        UnivCoProvenance(..),-        CoercionHole(..), coHoleCoVar, setCoHoleCoVar,-        CoercionN, CoercionR, CoercionP, KindCoercion,-        MCoercion(..), MCoercionR, MCoercionN,--        -- * Functions over types-        mkTyConTy, mkTyVarTy, mkTyVarTys,-        mkTyCoVarTy, mkTyCoVarTys,-        mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys,-        mkForAllTy, mkForAllTys,-        mkPiTy, mkPiTys,--        -- * Functions over binders-        TyCoBinder(..), TyCoVarBinder, TyBinder,-        binderVar, binderVars, binderType, binderArgFlag,-        delBinderVar,-        isInvisibleArgFlag, isVisibleArgFlag,-        isInvisibleBinder, isVisibleBinder,-        isTyBinder, isNamedBinder,--        -- * Functions over coercions-        pickLR,--        -- ** Analyzing types-        TyCoFolder(..), foldTyCo,--        -- * Sizes-        typeSize, coercionSize, provSize-    ) where--#include "HsVersions.h"--import GhcPrelude--import {-# SOURCE #-} TyCoPpr ( pprType, pprCo, pprTyLit )--   -- Transitively pulls in a LOT of stuff, better to break the loop--import {-# SOURCE #-} ConLike ( ConLike(..), conLikeName )---- friends:-import GHC.Iface.Type-import Var-import VarSet-import Name hiding ( varName )-import TyCon-import CoAxiom---- others-import BasicTypes ( LeftOrRight(..), pickLR )-import Outputable-import FastString-import Util---- libraries-import qualified Data.Data as Data hiding ( TyCon )-import Data.IORef ( IORef )   -- for CoercionHole--{--%************************************************************************-%*                                                                      *-                        TyThing-%*                                                                      *-%************************************************************************--Despite the fact that DataCon has to be imported via a hi-boot route,-this module seems the right place for TyThing, because it's needed for-funTyCon and all the types in TysPrim.--It is also SOURCE-imported into Name.hs---Note [ATyCon for classes]-~~~~~~~~~~~~~~~~~~~~~~~~~-Both classes and type constructors are represented in the type environment-as ATyCon.  You can tell the difference, and get to the class, with-   isClassTyCon :: TyCon -> Bool-   tyConClass_maybe :: TyCon -> Maybe Class-The Class and its associated TyCon have the same Name.--}---- | A global typecheckable-thing, essentially anything that has a name.--- Not to be confused with a 'TcTyThing', which is also a typecheckable--- thing but in the *local* context.  See 'TcEnv' for how to retrieve--- a 'TyThing' given a 'Name'.-data TyThing-  = AnId     Id-  | AConLike ConLike-  | ATyCon   TyCon       -- TyCons and classes; see Note [ATyCon for classes]-  | ACoAxiom (CoAxiom Branched)--instance Outputable TyThing where-  ppr = pprShortTyThing--instance NamedThing TyThing where       -- Can't put this with the type-  getName (AnId id)     = getName id    -- decl, because the DataCon instance-  getName (ATyCon tc)   = getName tc    -- isn't visible there-  getName (ACoAxiom cc) = getName cc-  getName (AConLike cl) = conLikeName cl--pprShortTyThing :: TyThing -> SDoc--- c.f. GHC.Core.Ppr.TyThing.pprTyThing, which prints all the details-pprShortTyThing thing-  = pprTyThingCategory thing <+> quotes (ppr (getName thing))--pprTyThingCategory :: TyThing -> SDoc-pprTyThingCategory = text . capitalise . tyThingCategory--tyThingCategory :: TyThing -> String-tyThingCategory (ATyCon tc)-  | isClassTyCon tc = "class"-  | otherwise       = "type constructor"-tyThingCategory (ACoAxiom _) = "coercion axiom"-tyThingCategory (AnId   _)   = "identifier"-tyThingCategory (AConLike (RealDataCon _)) = "data constructor"-tyThingCategory (AConLike (PatSynCon _))  = "pattern synonym"---{- **********************************************************************-*                                                                       *-                        Type-*                                                                       *-********************************************************************** -}---- | The key representation of types within the compiler--type KindOrType = Type -- See Note [Arguments to type constructors]---- | The key type representing kinds in the compiler.-type Kind = Type---- If you edit this type, you may need to update the GHC formalism--- See Note [GHC Formalism] in GHC.Core.Lint-data Type-  -- See Note [Non-trivial definitional equality]-  = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable)--  | AppTy-        Type-        Type            -- ^ Type application to something other than a 'TyCon'. Parameters:-                        ---                        --  1) Function: must /not/ be a 'TyConApp' or 'CastTy',-                        --     must be another 'AppTy', or 'TyVarTy'-                        --     See Note [Respecting definitional equality] (EQ1) about the-                        --     no 'CastTy' requirement-                        ---                        --  2) Argument type--  | TyConApp-        TyCon-        [KindOrType]    -- ^ Application of a 'TyCon', including newtypes /and/ synonyms.-                        -- Invariant: saturated applications of 'FunTyCon' must-                        -- use 'FunTy' and saturated synonyms must use their own-                        -- constructors. However, /unsaturated/ 'FunTyCon's-                        -- do appear as 'TyConApp's.-                        -- Parameters:-                        ---                        -- 1) Type constructor being applied to.-                        ---                        -- 2) Type arguments. Might not have enough type arguments-                        --    here to saturate the constructor.-                        --    Even type synonyms are not necessarily saturated;-                        --    for example unsaturated type synonyms-                        --    can appear as the right hand side of a type synonym.--  | ForAllTy-        {-# UNPACK #-} !TyCoVarBinder-        Type            -- ^ A Π type.--  | FunTy      -- ^ t1 -> t2   Very common, so an important special case-                -- See Note [Function types]-     { ft_af  :: AnonArgFlag  -- Is this (->) or (=>)?-     , ft_arg :: Type           -- Argument type-     , ft_res :: Type }         -- Result type--  | LitTy TyLit     -- ^ Type literals are similar to type constructors.--  | CastTy-        Type-        KindCoercion  -- ^ A kind cast. The coercion is always nominal.-                      -- INVARIANT: The cast is never refl.-                      -- INVARIANT: The Type is not a CastTy (use TransCo instead)-                      -- See Note [Respecting definitional equality] (EQ2) and (EQ3)--  | CoercionTy-        Coercion    -- ^ Injection of a Coercion into a type-                    -- This should only ever be used in the RHS of an AppTy,-                    -- in the list of a TyConApp, when applying a promoted-                    -- GADT data constructor--  deriving Data.Data--instance Outputable Type where-  ppr = pprType---- NOTE:  Other parts of the code assume that type literals do not contain--- types or type variables.-data TyLit-  = NumTyLit Integer-  | StrTyLit FastString-  deriving (Eq, Ord, Data.Data)--instance Outputable TyLit where-   ppr = pprTyLit--{- Note [Function types]-~~~~~~~~~~~~~~~~~~~~~~~~-FFunTy is the constructor for a function type.  Lots of things to say-about it!--* FFunTy is the data constructor, meaning "full function type".--* The function type constructor (->) has kind-     (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> Type LiftedRep-  mkTyConApp ensure that we convert a saturated application-    TyConApp (->) [r1,r2,t1,t2] into FunTy t1 t2-  dropping the 'r1' and 'r2' arguments; they are easily recovered-  from 't1' and 't2'.--* The ft_af field says whether or not this is an invisible argument-     VisArg:   t1 -> t2    Ordinary function type-     InvisArg: t1 => t2    t1 is guaranteed to be a predicate type,-                           i.e. t1 :: Constraint-  See Note [Types for coercions, predicates, and evidence]--  This visibility info makes no difference in Core; it matters-  only when we regard the type as a Haskell source type.--* FunTy is a (unidirectional) pattern synonym that allows-  positional pattern matching (FunTy arg res), ignoring the-  ArgFlag.--}--{- ------------------------      Commented out until the pattern match-      checker can handle it; see #16185--      For now we use the CPP macro #define FunTy FFunTy _-      (see HsVersions.h) to allow pattern matching on a-      (positional) FunTy constructor.--{-# COMPLETE FunTy, TyVarTy, AppTy, TyConApp-           , ForAllTy, LitTy, CastTy, CoercionTy :: Type #-}---- | 'FunTy' is a (uni-directional) pattern synonym for the common--- case where we want to match on the argument/result type, but--- ignoring the AnonArgFlag-pattern FunTy :: Type -> Type -> Type-pattern FunTy arg res <- FFunTy { ft_arg = arg, ft_res = res }--       End of commented out block----------------------------------- -}--{- Note [Types for coercions, predicates, and evidence]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We treat differently:--  (a) Predicate types-        Test: isPredTy-        Binders: DictIds-        Kind: Constraint-        Examples: (Eq a), and (a ~ b)--  (b) Coercion types are primitive, unboxed equalities-        Test: isCoVarTy-        Binders: CoVars (can appear in coercions)-        Kind: TYPE (TupleRep [])-        Examples: (t1 ~# t2) or (t1 ~R# t2)--  (c) Evidence types is the type of evidence manipulated by-      the type constraint solver.-        Test: isEvVarType-        Binders: EvVars-        Kind: Constraint or TYPE (TupleRep [])-        Examples: all coercion types and predicate types--Coercion types and predicate types are mutually exclusive,-but evidence types are a superset of both.--When treated as a user type,--  - Predicates (of kind Constraint) are invisible and are-    implicitly instantiated--  - Coercion types, and non-pred evidence types (i.e. not-    of kind Constrain), are just regular old types, are-    visible, and are not implicitly instantiated.--In a FunTy { ft_af = InvisArg }, the argument type is always-a Predicate type.--Note [Constraints in kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Do we allow a type constructor to have a kind like-   S :: Eq a => a -> Type--No, we do not.  Doing so would mean would need a TyConApp like-   S @k @(d :: Eq k) (ty :: k)- and we have no way to build, or decompose, evidence like- (d :: Eq k) at the type level.--But we admit one exception: equality.  We /do/ allow, say,-   MkT :: (a ~ b) => a -> b -> Type a b--Why?  Because we can, without much difficulty.  Moreover-we can promote a GADT data constructor (see TyCon-Note [Promoted data constructors]), like-  data GT a b where-    MkGT : a -> a -> GT a a-so programmers might reasonably expect to be able to-promote MkT as well.--How does this work?--* In TcValidity.checkConstraintsOK we reject kinds that-  have constraints other than (a~b) and (a~~b).--* In Inst.tcInstInvisibleTyBinder we instantiate a call-  of MkT by emitting-     [W] co :: alpha ~# beta-  and producing the elaborated term-     MkT @alpha @beta (Eq# alpha beta co)-  We don't generate a boxed "Wanted"; we generate only a-  regular old /unboxed/ primitive-equality Wanted, and build-  the box on the spot.--* How can we get such a MkT?  By promoting a GADT-style data-  constructor-     data T a b where-       MkT :: (a~b) => a -> b -> T a b-  See DataCon.mkPromotedDataCon-  and Note [Promoted data constructors] in TyCon--* We support both homogeneous (~) and heterogeneous (~~)-  equality.  (See Note [The equality types story]-  in TysPrim for a primer on these equality types.)--* How do we prevent a MkT having an illegal constraint like-  Eq a?  We check for this at use-sites; see TcHsType.tcTyVar,-  specifically dc_theta_illegal_constraint.--* Notice that nothing special happens if-    K :: (a ~# b) => blah-  because (a ~# b) is not a predicate type, and is never-  implicitly instantiated. (Mind you, it's not clear how you-  could creates a type constructor with such a kind.) See-  Note [Types for coercions, predicates, and evidence]--* The existence of promoted MkT with an equality-constraint-  argument is the (only) reason that the AnonTCB constructor-  of TyConBndrVis carries an AnonArgFlag (VisArg/InvisArg).-  For example, when we promote the data constructor-     MkT :: forall a b. (a~b) => a -> b -> T a b-  we get a PromotedDataCon with tyConBinders-      Bndr (a :: Type)  (NamedTCB Inferred)-      Bndr (b :: Type)  (NamedTCB Inferred)-      Bndr (_ :: a ~ b) (AnonTCB InvisArg)-      Bndr (_ :: a)     (AnonTCB VisArg))-      Bndr (_ :: b)     (AnonTCB VisArg))--* One might reasonably wonder who *unpacks* these boxes once they are-  made. After all, there is no type-level `case` construct. The-  surprising answer is that no one ever does. Instead, if a GADT-  constructor is used on the left-hand side of a type family equation,-  that occurrence forces GHC to unify the types in question. For-  example:--  data G a where-    MkG :: G Bool--  type family F (x :: G a) :: a where-    F MkG = False--  When checking the LHS `F MkG`, GHC sees the MkG constructor and then must-  unify F's implicit parameter `a` with Bool. This succeeds, making the equation--    F Bool (MkG @Bool <Bool>) = False--  Note that we never need unpack the coercion. This is because type-  family equations are *not* parametric in their kind variables. That-  is, we could have just said--  type family H (x :: G a) :: a where-    H _ = False--  The presence of False on the RHS also forces `a` to become Bool,-  giving us--    H Bool _ = False--  The fact that any of this works stems from the lack of phase-  separation between types and kinds (unlike the very present phase-  separation between terms and types).--  Once we have the ability to pattern-match on types below top-level,-  this will no longer cut it, but it seems fine for now.---Note [Arguments to type constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because of kind polymorphism, in addition to type application we now-have kind instantiation. We reuse the same notations to do so.--For example:--  Just (* -> *) Maybe-  Right * Nat Zero--are represented by:--  TyConApp (PromotedDataCon Just) [* -> *, Maybe]-  TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)]--Important note: Nat is used as a *kind* and not as a type. This can be-confusing, since type-level Nat and kind-level Nat are identical. We-use the kind of (PromotedDataCon Right) to know if its arguments are-kinds or types.--This kind instantiation only happens in TyConApp currently.--Note [Non-trivial definitional equality]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Is Int |> <*> the same as Int? YES! In order to reduce headaches,-we decide that any reflexive casts in types are just ignored.-(Indeed they must be. See Note [Respecting definitional equality].)-More generally, the `eqType` function, which defines Core's type equality-relation, ignores casts and coercion arguments, as long as the-two types have the same kind. This allows us to be a little sloppier-in keeping track of coercions, which is a good thing. It also means-that eqType does not depend on eqCoercion, which is also a good thing.--Why is this sensible? That is, why is something different than α-equivalence-appropriate for the implementation of eqType?--Anything smaller than ~ and homogeneous is an appropriate definition for-equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any-expression of type τ can be transmuted to one of type σ at any point by-casting. The same is true of expressions of type σ. So in some sense, τ and σ-are interchangeable.--But let's be more precise. If we examine the typing rules of FC (say, those in-https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf)-there are several places where the same metavariable is used in two different-premises to a rule. (For example, see Ty_App.) There is an implicit equality-check here. What definition of equality should we use? By convention, we use-α-equivalence. Take any rule with one (or more) of these implicit equality-checks. Then there is an admissible rule that uses ~ instead of the implicit-check, adding in casts as appropriate.--The only problem here is that ~ is heterogeneous. To make the kinds work out-in the admissible rule that uses ~, it is necessary to homogenize the-coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η;-we use η |> kind η, which is homogeneous.--The effect of this all is that eqType, the implementation of the implicit-equality check, can use any homogeneous relation that is smaller than ~, as-those rules must also be admissible.--A more drawn out argument around all of this is presented in Section 7.2 of-Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf).--What would go wrong if we insisted on the casts matching? See the beginning of-Section 8 in the unpublished paper above. Theoretically, nothing at all goes-wrong. But in practical terms, getting the coercions right proved to be-nightmarish. And types would explode: during kind-checking, we often produce-reflexive kind coercions. When we try to cast by these, mkCastTy just discards-them. But if we used an eqType that distinguished between Int and Int |> <*>,-then we couldn't discard -- the output of kind-checking would be enormous,-and we would need enormous casts with lots of CoherenceCo's to straighten-them out.--Would anything go wrong if eqType respected type families? No, not at all. But-that makes eqType rather hard to implement.--Thus, the guideline for eqType is that it should be the largest-easy-to-implement relation that is still smaller than ~ and homogeneous. The-precise choice of relation is somewhat incidental, as long as the smart-constructors and destructors in Type respect whatever relation is chosen.--Another helpful principle with eqType is this:-- (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere.--This principle also tells us that eqType must relate only types with the-same kinds.--Note [Respecting definitional equality]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Note [Non-trivial definitional equality] introduces the property (EQ).-How is this upheld?--Any function that pattern matches on all the constructors will have to-consider the possibility of CastTy. Presumably, those functions will handle-CastTy appropriately and we'll be OK.--More dangerous are the splitXXX functions. Let's focus on splitTyConApp.-We don't want it to fail on (T a b c |> co). Happily, if we have-  (T a b c |> co) `eqType` (T d e f)-then co must be reflexive. Why? eqType checks that the kinds are equal, as-well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f).-By the kind check, we know that (T a b c |> co) and (T d e f) have the same-kind. So the only way that co could be non-reflexive is for (T a b c) to have-a different kind than (T d e f). But because T's kind is closed (all tycon kinds-are closed), the only way for this to happen is that one of the arguments has-to differ, leading to a contradiction. Thus, co is reflexive.--Accordingly, by eliminating reflexive casts, splitTyConApp need not worry-about outermost casts to uphold (EQ). Eliminating reflexive casts is done-in mkCastTy.--Unforunately, that's not the end of the story. Consider comparing-  (T a b c)      =?       (T a b |> (co -> <Type>)) (c |> co)-These two types have the same kind (Type), but the left type is a TyConApp-while the right type is not. To handle this case, we say that the right-hand-type is ill-formed, requiring an AppTy never to have a casted TyConApp-on its left. It is easy enough to pull around the coercions to maintain-this invariant, as done in Type.mkAppTy. In the example above, trying to-form the right-hand type will instead yield (T a b (c |> co |> sym co) |> <Type>).-Both the casts there are reflexive and will be dropped. Huzzah.--This idea of pulling coercions to the right works for splitAppTy as well.--However, there is one hiccup: it's possible that a coercion doesn't relate two-Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@,-then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't-be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not-`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate-our (EQ) property.--Lastly, in order to detect reflexive casts reliably, we must make sure not-to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)).--In sum, in order to uphold (EQ), we need the following three invariants:--  (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable-        cast is one that relates either a FunTy to a FunTy or a-        ForAllTy to a ForAllTy.-  (EQ2) No reflexive casts in CastTy.-  (EQ3) No nested CastTys.-  (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body).-        See Note [Weird typing rule for ForAllTy] in Type.--These invariants are all documented above, in the declaration for Type.--Note [Unused coercion variable in ForAllTy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-  \(co:t1 ~ t2). e--What type should we give to this expression?-  (1) forall (co:t1 ~ t2) -> t-  (2) (t1 ~ t2) -> t--If co is used in t, (1) should be the right choice.-if co is not used in t, we would like to have (1) and (2) equivalent.--However, we want to keep eqType simple and don't want eqType (1) (2) to return-True in any case.--We decide to always construct (2) if co is not used in t.--Thus in mkLamType, we check whether the variable is a coercion-variable (of type (t1 ~# t2), and whether it is un-used in the-body. If so, it returns a FunTy instead of a ForAllTy.--There are cases we want to skip the check. For example, the check is-unnecessary when it is known from the context that the input variable-is a type variable.  In those cases, we use mkForAllTy.---}---- | A type labeled 'KnotTied' might have knot-tied tycons in it. See--- Note [Type checking recursive type and class declarations] in--- TcTyClsDecls-type KnotTied ty = ty--{- **********************************************************************-*                                                                       *-                  TyCoBinder and ArgFlag-*                                                                       *-********************************************************************** -}---- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be--- dependent ('Named') or nondependent ('Anon'). They may also be visible or--- not. See Note [TyCoBinders]-data TyCoBinder-  = Named TyCoVarBinder    -- A type-lambda binder-  | Anon AnonArgFlag Type  -- A term-lambda binder. Type here can be CoercionTy.-                           -- Visibility is determined by the AnonArgFlag-  deriving Data.Data--instance Outputable TyCoBinder where-  ppr (Anon af ty) = ppr af <+> ppr ty-  ppr (Named (Bndr v Required))  = ppr v-  ppr (Named (Bndr v Specified)) = char '@' <> ppr v-  ppr (Named (Bndr v Inferred))  = braces (ppr v)----- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder'--- in the 'Named' field.-type TyBinder = TyCoBinder---- | Remove the binder's variable from the set, if the binder has--- a variable.-delBinderVar :: VarSet -> TyCoVarBinder -> VarSet-delBinderVar vars (Bndr tv _) = vars `delVarSet` tv---- | Does this binder bind an invisible argument?-isInvisibleBinder :: TyCoBinder -> Bool-isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis-isInvisibleBinder (Anon InvisArg _)    = True-isInvisibleBinder (Anon VisArg   _)    = False---- | Does this binder bind a visible argument?-isVisibleBinder :: TyCoBinder -> Bool-isVisibleBinder = not . isInvisibleBinder--isNamedBinder :: TyCoBinder -> Bool-isNamedBinder (Named {}) = True-isNamedBinder (Anon {})  = False---- | If its a named binder, is the binder a tyvar?--- Returns True for nondependent binder.--- This check that we're really returning a *Ty*Binder (as opposed to a--- coercion binder). That way, if/when we allow coercion quantification--- in more places, we'll know we missed updating some function.-isTyBinder :: TyCoBinder -> Bool-isTyBinder (Named bnd) = isTyVarBinder bnd-isTyBinder _ = True--{- Note [TyCoBinders]-~~~~~~~~~~~~~~~~~~~-A ForAllTy contains a TyCoVarBinder.  But a type can be decomposed-to a telescope consisting of a [TyCoBinder]--A TyCoBinder represents the type of binders -- that is, the type of an-argument to a Pi-type. GHC Core currently supports two different-Pi-types:-- * A non-dependent function type,-   written with ->, e.g. ty1 -> ty2-   represented as FunTy ty1 ty2. These are-   lifted to Coercions with the corresponding FunCo.-- * A dependent compile-time-only polytype,-   written with forall, e.g.  forall (a:*). ty-   represented as ForAllTy (Bndr a v) ty--Both Pi-types classify terms/types that take an argument. In other-words, if `x` is either a function or a polytype, `x arg` makes sense-(for an appropriate `arg`).---Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder.-  Each TyCoVarBinder-      Bndr a tvis-  is equipped with tvis::ArgFlag, which says whether or not arguments-  for this binder should be visible (explicit) in source Haskell.--* A TyCon contains a list of TyConBinders.  Each TyConBinder-      Bndr a cvis-  is equipped with cvis::TyConBndrVis, which says whether or not type-  and kind arguments for this TyCon should be visible (explicit) in-  source Haskell.--This table summarises the visibility rules:-----------------------------------------------------------------------------------------|                                                      Occurrences look like this-|                             GHC displays type as     in Haskell source code-|---------------------------------------------------------------------------------------| Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term-|  tvis :: ArgFlag-|  tvis = Inferred:            f :: forall {a}. type    Arg not allowed:  f-                               f :: forall {co}. type   Arg not allowed:  f-|  tvis = Specified:           f :: forall a. type      Arg optional:     f  or  f @Int-|  tvis = Required:            T :: forall k -> type    Arg required:     T *-|    This last form is illegal in terms: See Note [No Required TyCoBinder in terms]-|-| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon-|  cvis :: TyConBndrVis-|  cvis = AnonTCB:             T :: kind -> kind        Required:            T *-|  cvis = NamedTCB Inferred:   T :: forall {k}. kind    Arg not allowed:     T-|                              T :: forall {co}. kind   Arg not allowed:     T-|  cvis = NamedTCB Specified:  T :: forall k. kind      Arg not allowed[1]:  T-|  cvis = NamedTCB Required:   T :: forall k -> kind    Required:            T *------------------------------------------------------------------------------------------[1] In types, in the Specified case, it would make sense to allow-    optional kind applications, thus (T @*), but we have not-    yet implemented that------ In term declarations ------* Inferred.  Function defn, with no signature:  f1 x = x-  We infer f1 :: forall {a}. a -> a, with 'a' Inferred-  It's Inferred because it doesn't appear in any-  user-written signature for f1--* Specified.  Function defn, with signature (implicit forall):-     f2 :: a -> a; f2 x = x-  So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified-  even though 'a' is not bound in the source code by an explicit forall--* Specified.  Function defn, with signature (explicit forall):-     f3 :: forall a. a -> a; f3 x = x-  So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified--* Inferred/Specified.  Function signature with inferred kind polymorphism.-     f4 :: a b -> Int-  So 'f4' gets the type f4 :: forall {k} (a:k->*) (b:k). a b -> Int-  Here 'k' is Inferred (it's not mentioned in the type),-  but 'a' and 'b' are Specified.--* Specified.  Function signature with explicit kind polymorphism-     f5 :: a (b :: k) -> Int-  This time 'k' is Specified, because it is mentioned explicitly,-  so we get f5 :: forall (k:*) (a:k->*) (b:k). a b -> Int--* Similarly pattern synonyms:-  Inferred - from inferred types (e.g. no pattern type signature)-           - or from inferred kind polymorphism------ In type declarations ------* Inferred (k)-     data T1 a b = MkT1 (a b)-  Here T1's kind is  T1 :: forall {k:*}. (k->*) -> k -> *-  The kind variable 'k' is Inferred, since it is not mentioned--  Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind,-  and Anon binders don't have a visibility flag. (Or you could think-  of Anon having an implicit Required flag.)--* Specified (k)-     data T2 (a::k->*) b = MkT (a b)-  Here T's kind is  T :: forall (k:*). (k->*) -> k -> *-  The kind variable 'k' is Specified, since it is mentioned in-  the signature.--* Required (k)-     data T k (a::k->*) b = MkT (a b)-  Here T's kind is  T :: forall k:* -> (k->*) -> k -> *-  The kind is Required, since it bound in a positional way in T's declaration-  Every use of T must be explicitly applied to a kind--* Inferred (k1), Specified (k)-     data T a b (c :: k) = MkT (a b) (Proxy c)-  Here T's kind is  T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> *-  So 'k' is Specified, because it appears explicitly,-  but 'k1' is Inferred, because it does not--Generally, in the list of TyConBinders for a TyCon,--* Inferred arguments always come first-* Specified, Anon and Required can be mixed--e.g.-  data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ...--Here Foo's TyConBinders are-   [Required 'a', Specified 'b', Anon]-and its kind prints as-   Foo :: forall a -> forall b. (a -> b -> Type) -> Type--See also Note [Required, Specified, and Inferred for types] in TcTyClsDecls------ Printing ------- We print forall types with enough syntax to tell you their visibility- flag.  But this is not source Haskell, and these types may not all- be parsable.-- Specified: a list of Specified binders is written between `forall` and `.`:-               const :: forall a b. a -> b -> a-- Inferred: like Specified, but every binder is written in braces:-               f :: forall {k} (a:k). S k a -> Int-- Required: binders are put between `forall` and `->`:-              T :: forall k -> *------ Other points -------* In classic Haskell, all named binders (that is, the type variables in-  a polymorphic function type f :: forall a. a -> a) have been Inferred.--* Inferred variables correspond to "generalized" variables from the-  Visible Type Applications paper (ESOP'16).--Note [No Required TyCoBinder in terms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't allow Required foralls for term variables, including pattern-synonyms and data constructors.  Why?  Because then an application-would need a /compulsory/ type argument (possibly without an "@"?),-thus (f Int); and we don't have concrete syntax for that.--We could change this decision, but Required, Named TyCoBinders are rare-anyway.  (Most are Anons.)--However the type of a term can (just about) have a required quantifier;-see Note [Required quantifiers in the type of a term] in TcExpr.--}---{- **********************************************************************-*                                                                       *-                        PredType-*                                                                       *-********************************************************************** -}----- | A type of the form @p@ of constraint kind represents a value whose type is--- the Haskell predicate @p@, where a predicate is what occurs before--- the @=>@ in a Haskell type.------ We use 'PredType' as documentation to mark those types that we guarantee to--- have this kind.------ It can be expanded into its representation, but:------ * The type checker must treat it as opaque------ * The rest of the compiler treats it as transparent------ Consider these examples:------ > f :: (Eq a) => a -> Int--- > g :: (?x :: Int -> Int) => a -> Int--- > h :: (r\l) => {r} => {l::Int | r}------ Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\"-type PredType = Type---- | A collection of 'PredType's-type ThetaType = [PredType]--{--(We don't support TREX records yet, but the setup is designed-to expand to allow them.)--A Haskell qualified type, such as that for f,g,h above, is-represented using-        * a FunTy for the double arrow-        * with a type of kind Constraint as the function argument--The predicate really does turn into a real extra argument to the-function.  If the argument has type (p :: Constraint) then the predicate p is-represented by evidence of type p.---%************************************************************************-%*                                                                      *-            Simple constructors-%*                                                                      *-%************************************************************************--These functions are here so that they can be used by TysPrim,-which in turn is imported by Type--}--mkTyVarTy  :: TyVar   -> Type-mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) )-              TyVarTy v--mkTyVarTys :: [TyVar] -> [Type]-mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy--mkTyCoVarTy :: TyCoVar -> Type-mkTyCoVarTy v-  | isTyVar v-  = TyVarTy v-  | otherwise-  = CoercionTy (CoVarCo v)--mkTyCoVarTys :: [TyCoVar] -> [Type]-mkTyCoVarTys = map mkTyCoVarTy--infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy`      -- Associates to the right--mkFunTy :: AnonArgFlag -> Type -> Type -> Type-mkFunTy af arg res = FunTy { ft_af = af, ft_arg = arg, ft_res = res }--mkVisFunTy, mkInvisFunTy :: Type -> Type -> Type-mkVisFunTy   = mkFunTy VisArg-mkInvisFunTy = mkFunTy InvisArg---- | Make nested arrow types-mkVisFunTys, mkInvisFunTys :: [Type] -> Type -> Type-mkVisFunTys   tys ty = foldr mkVisFunTy   ty tys-mkInvisFunTys tys ty = foldr mkInvisFunTy ty tys---- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder--- See Note [Unused coercion variable in ForAllTy]-mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type-mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty---- | Wraps foralls over the type using the provided 'TyCoVar's from left to right-mkForAllTys :: [TyCoVarBinder] -> Type -> Type-mkForAllTys tyvars ty = foldr ForAllTy ty tyvars--mkPiTy:: TyCoBinder -> Type -> Type-mkPiTy (Anon af ty1) ty2        = FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 }-mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty--mkPiTys :: [TyCoBinder] -> Type -> Type-mkPiTys tbs ty = foldr mkPiTy ty tbs---- | Create the plain type constructor type which has been applied to no type arguments at all.-mkTyConTy :: TyCon -> Type-mkTyConTy tycon = TyConApp tycon []--{--%************************************************************************-%*                                                                      *-            Coercions-%*                                                                      *-%************************************************************************--}---- | A 'Coercion' is concrete evidence of the equality/convertibility--- of two types.---- If you edit this type, you may need to update the GHC formalism--- See Note [GHC Formalism] in GHC.Core.Lint-data Coercion-  -- Each constructor has a "role signature", indicating the way roles are-  -- propagated through coercions.-  --    -  P, N, and R stand for coercions of the given role-  --    -  e stands for a coercion of a specific unknown role-  --           (think "role polymorphism")-  --    -  "e" stands for an explicit role parameter indicating role e.-  --    -   _ stands for a parameter that is not a Role or Coercion.--  -- These ones mirror the shape of types-  = -- Refl :: _ -> N-    Refl Type  -- See Note [Refl invariant]-          -- Invariant: applications of (Refl T) to a bunch of identity coercions-          --            always show up as Refl.-          -- For example  (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)).--          -- Applications of (Refl T) to some coercions, at least one of-          -- which is NOT the identity, show up as TyConAppCo.-          -- (They may not be fully saturated however.)-          -- ConAppCo coercions (like all coercions other than Refl)-          -- are NEVER the identity.--          -- Use (GRefl Representational ty MRefl), not (SubCo (Refl ty))--  -- GRefl :: "e" -> _ -> Maybe N -> e-  -- See Note [Generalized reflexive coercion]-  | GRefl Role Type MCoercionN  -- See Note [Refl invariant]-          -- Use (Refl ty), not (GRefl Nominal ty MRefl)-          -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _))--  -- These ones simply lift the correspondingly-named-  -- Type constructors into Coercions--  -- TyConAppCo :: "e" -> _ -> ?? -> e-  -- See Note [TyConAppCo roles]-  | TyConAppCo Role TyCon [Coercion]    -- lift TyConApp-               -- The TyCon is never a synonym;-               -- we expand synonyms eagerly-               -- But it can be a type function--  | AppCo Coercion CoercionN             -- lift AppTy-          -- AppCo :: e -> N -> e--  -- See Note [Forall coercions]-  | ForAllCo TyCoVar KindCoercion Coercion-         -- ForAllCo :: _ -> N -> e -> e--  | FunCo Role Coercion Coercion         -- lift FunTy-         -- FunCo :: "e" -> e -> e -> e-         -- Note: why doesn't FunCo have a AnonArgFlag, like FunTy?-         -- Because the AnonArgFlag has no impact on Core; it is only-         -- there to guide implicit instantiation of Haskell source-         -- types, and that is irrelevant for coercions, which are-         -- Core-only.--  -- These are special-  | CoVarCo CoVar      -- :: _ -> (N or R)-                       -- result role depends on the tycon of the variable's type--    -- AxiomInstCo :: e -> _ -> ?? -> e-  | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion]-     -- See also [CoAxiom index]-     -- The coercion arguments always *precisely* saturate-     -- arity of (that branch of) the CoAxiom. If there are-     -- any left over, we use AppCo.-     -- See [Coercion axioms applied to coercions]-     -- The roles of the argument coercions are determined-     -- by the cab_roles field of the relevant branch of the CoAxiom--  | AxiomRuleCo CoAxiomRule [Coercion]-    -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule-    -- The number coercions should match exactly the expectations-    -- of the CoAxiomRule (i.e., the rule is fully saturated).--  | UnivCo UnivCoProvenance Role Type Type-      -- :: _ -> "e" -> _ -> _ -> e--  | SymCo Coercion             -- :: e -> e-  | TransCo Coercion Coercion  -- :: e -> e -> e--  | NthCo  Role Int Coercion     -- Zero-indexed; decomposes (T t0 ... tn)-    -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles])-    -- Using NthCo on a ForAllCo gives an N coercion always-    -- See Note [NthCo and newtypes]-    ---    -- Invariant:  (NthCo r i co), it is always the case that r = role of (Nth i co)-    -- That is: the role of the entire coercion is redundantly cached here.-    -- See Note [NthCo Cached Roles]--  | LRCo   LeftOrRight CoercionN     -- Decomposes (t_left t_right)-    -- :: _ -> N -> N-  | InstCo Coercion CoercionN-    -- :: e -> N -> e-    -- See Note [InstCo roles]--  -- Extract a kind coercion from a (heterogeneous) type coercion-  -- NB: all kind coercions are Nominal-  | KindCo Coercion-     -- :: e -> N--  | SubCo CoercionN                  -- Turns a ~N into a ~R-    -- :: N -> R--  | HoleCo CoercionHole              -- ^ See Note [Coercion holes]-                                     -- Only present during typechecking-  deriving Data.Data--type CoercionN = Coercion       -- always nominal-type CoercionR = Coercion       -- always representational-type CoercionP = Coercion       -- always phantom-type KindCoercion = CoercionN   -- always nominal--instance Outputable Coercion where-  ppr = pprCo---- | A semantically more meaningful type to represent what may or may not be a--- useful 'Coercion'.-data MCoercion-  = MRefl-    -- A trivial Reflexivity coercion-  | MCo Coercion-    -- Other coercions-  deriving Data.Data-type MCoercionR = MCoercion-type MCoercionN = MCoercion--instance Outputable MCoercion where-  ppr MRefl    = text "MRefl"-  ppr (MCo co) = text "MCo" <+> ppr co--{--Note [Refl invariant]-~~~~~~~~~~~~~~~~~~~~~-Invariant 1:--Coercions have the following invariant-     Refl (similar for GRefl r ty MRefl) is always lifted as far as possible.--You might think that a consequences is:-     Every identity coercions has Refl at the root--But that's not quite true because of coercion variables.  Consider-     g         where g :: Int~Int-     Left h    where h :: Maybe Int ~ Maybe Int-etc.  So the consequence is only true of coercions that-have no coercion variables.--Note [Generalized reflexive coercion]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--GRefl is a generalized reflexive coercion (see #15192). It wraps a kind-coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing-rules for GRefl:--  ty : k1-  -------------------------------------  GRefl r ty MRefl: ty ~r ty--  ty : k1       co :: k1 ~ k2-  -------------------------------------  GRefl r ty (MCo co) : ty ~r ty |> co--Consider we have--   g1 :: s ~r t-   s  :: k1-   g2 :: k1 ~ k2--and we want to construct a coercions co which has type--   (s |> g2) ~r t--We can define--   co = Sym (GRefl r s g2) ; g1--It is easy to see that--   Refl == GRefl Nominal ty MRefl :: ty ~n ty--A nominal reflexive coercion is quite common, so we keep the special form Refl to-save allocation.--Note [Coercion axioms applied to coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The reason coercion axioms can be applied to coercions and not just-types is to allow for better optimization.  There are some cases where-we need to be able to "push transitivity inside" an axiom in order to-expose further opportunities for optimization.--For example, suppose we have--  C a : t[a] ~ F a-  g   : b ~ c--and we want to optimize--  sym (C b) ; t[g] ; C c--which has the kind--  F b ~ F c--(stopping through t[b] and t[c] along the way).--We'd like to optimize this to just F g -- but how?  The key is-that we need to allow axioms to be instantiated by *coercions*,-not just by types.  Then we can (in certain cases) push-transitivity inside the axiom instantiations, and then react-opposite-polarity instantiations of the same axiom.  In this-case, e.g., we match t[g] against the LHS of (C c)'s kind, to-obtain the substitution  a |-> g  (note this operation is sort-of the dual of lifting!) and hence end up with--  C g : t[b] ~ F c--which indeed has the same kind as  t[g] ; C c.--Now we have--  sym (C b) ; C g--which can be optimized to F g.--Note [CoAxiom index]-~~~~~~~~~~~~~~~~~~~~-A CoAxiom has 1 or more branches. Each branch has contains a list-of the free type variables in that branch, the LHS type patterns,-and the RHS type for that branch. When we apply an axiom to a list-of coercions, we must choose which branch of the axiom we wish to-use, as the different branches may have different numbers of free-type variables. (The number of type patterns is always the same-among branches, but that doesn't quite concern us here.)--The Int in the AxiomInstCo constructor is the 0-indexed number-of the chosen branch.--Note [Forall coercions]-~~~~~~~~~~~~~~~~~~~~~~~-Constructing coercions between forall-types can be a bit tricky,-because the kinds of the bound tyvars can be different.--The typing rule is:---  kind_co : k1 ~ k2-  tv1:k1 |- co : t1 ~ t2-  --------------------------------------------------------------------  ForAllCo tv1 kind_co co : all tv1:k1. t1  ~-                            all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co])--First, the TyCoVar stored in a ForAllCo is really an optimisation: this field-should be a Name, as its kind is redundant. Thinking of the field as a Name-is helpful in understanding what a ForAllCo means.-The kind of TyCoVar always matches the left-hand kind of the coercion.--The idea is that kind_co gives the two kinds of the tyvar. See how, in the-conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right.--Of course, a type variable can't have different kinds at the same time. So,-we arbitrarily prefer the first kind when using tv1 in the inner coercion-co, which shows that t1 equals t2.--The last wrinkle is that we need to fix the kinds in the conclusion. In-t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of-the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with-(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it-mentions the same name with different kinds, but it *is* well-kinded, noting-that `(tv1:k2) |> sym kind_co` has kind k1.--This all really would work storing just a Name in the ForAllCo. But we can't-add Names to, e.g., VarSets, and there generally is just an impedance mismatch-in a bunch of places. So we use tv1. When we need tv2, we can use-setTyVarKind.--Note [Predicate coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-   g :: a~b-How can we coerce between types-   ([c]~a) => [a] -> c-and-   ([c]~b) => [b] -> c-where the equality predicate *itself* differs?--Answer: we simply treat (~) as an ordinary type constructor, so these-types really look like--   ((~) [c] a) -> [a] -> c-   ((~) [c] b) -> [b] -> c--So the coercion between the two is obviously--   ((~) [c] g) -> [g] -> c--Another way to see this to say that we simply collapse predicates to-their representation type (see Type.coreView and Type.predTypeRep).--This collapse is done by mkPredCo; there is no PredCo constructor-in Coercion.  This is important because we need Nth to work on-predicates too:-    Nth 1 ((~) [c] g) = g-See Simplify.simplCoercionF, which generates such selections.--Note [Roles]-~~~~~~~~~~~~-Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated-in #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see-https://gitlab.haskell.org/ghc/ghc/wikis/roles-implementation--Here is one way to phrase the problem:--Given:-newtype Age = MkAge Int-type family F x-type instance F Age = Bool-type instance F Int = Char--This compiles down to:-axAge :: Age ~ Int-axF1 :: F Age ~ Bool-axF2 :: F Int ~ Char--Then, we can make:-(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char--Yikes!--The solution is _roles_, as articulated in "Generative Type Abstraction and-Type-level Computation" (POPL 2010), available at-http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf--The specification for roles has evolved somewhat since that paper. For the-current full details, see the documentation in docs/core-spec. Here are some-highlights.--We label every equality with a notion of type equivalence, of which there are-three options: Nominal, Representational, and Phantom. A ground type is-nominally equivalent only with itself. A newtype (which is considered a ground-type in Haskell) is representationally equivalent to its representation.-Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P"-to denote the equivalences.--The axioms above would be:-axAge :: Age ~R Int-axF1 :: F Age ~N Bool-axF2 :: F Age ~N Char--Then, because transitivity applies only to coercions proving the same notion-of equivalence, the above construction is impossible.--However, there is still an escape hatch: we know that any two types that are-nominally equivalent are representationally equivalent as well. This is what-the form SubCo proves -- it "demotes" a nominal equivalence into a-representational equivalence. So, it would seem the following is possible:--sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char   -- WRONG--What saves us here is that the arguments to a type function F, lifted into a-coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and-we are safe.--Roles are attached to parameters to TyCons. When lifting a TyCon into a-coercion (through TyConAppCo), we need to ensure that the arguments to the-TyCon respect their roles. For example:--data T a b = MkT a (F b)--If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know-that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because-the type function F branches on b's *name*, not representation. So, we say-that 'a' has role Representational and 'b' has role Nominal. The third role,-Phantom, is for parameters not used in the type's definition. Given the-following definition--data Q a = MkQ Int--the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we-can construct the coercion Bool ~P Char (using UnivCo).--See the paper cited above for more examples and information.--Note [TyConAppCo roles]-~~~~~~~~~~~~~~~~~~~~~~~-The TyConAppCo constructor has a role parameter, indicating the role at-which the coercion proves equality. The choice of this parameter affects-the required roles of the arguments of the TyConAppCo. To help explain-it, assume the following definition:--  type instance F Int = Bool   -- Axiom axF : F Int ~N Bool-  newtype Age = MkAge Int      -- Axiom axAge : Age ~R Int-  data Foo a = MkFoo a         -- Role on Foo's parameter is Representational--TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool-  For (TyConAppCo Nominal) all arguments must have role Nominal. Why?-  So that Foo Age ~N Foo Int does *not* hold.--TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool-TyConAppCo Representational Foo axAge       : Foo Age     ~R Foo Int-  For (TyConAppCo Representational), all arguments must have the roles-  corresponding to the result of tyConRoles on the TyCon. This is the-  whole point of having roles on the TyCon to begin with. So, we can-  have Foo Age ~R Foo Int, if Foo's parameter has role R.--  If a Representational TyConAppCo is over-saturated (which is otherwise fine),-  the spill-over arguments must all be at Nominal. This corresponds to the-  behavior for AppCo.--TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool-  All arguments must have role Phantom. This one isn't strictly-  necessary for soundness, but this choice removes ambiguity.--The rules here dictate the roles of the parameters to mkTyConAppCo-(should be checked by Lint).--Note [NthCo and newtypes]-~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have--  newtype N a = MkN Int-  type role N representational--This yields axiom--  NTCo:N :: forall a. N a ~R Int--We can then build--  co :: forall a b. N a ~R N b-  co = NTCo:N a ; sym (NTCo:N b)--for any `a` and `b`. Because of the role annotation on N, if we use-NthCo, we'll get out a representational coercion. That is:--  NthCo r 0 co :: forall a b. a ~R b--Yikes! Clearly, this is terrible. The solution is simple: forbid-NthCo to be used on newtypes if the internal coercion is representational.--This is not just some corner case discovered by a segfault somewhere;-it was discovered in the proof of soundness of roles and described-in the "Safe Coercions" paper (ICFP '14).--Note [NthCo Cached Roles]-~~~~~~~~~~~~~~~~~~~~~~~~~-Why do we cache the role of NthCo in the NthCo constructor?-Because computing role(Nth i co) involves figuring out that--  co :: T tys1 ~ T tys2--using coercionKind, and finding (coercionRole co), and then looking-at the tyConRoles of T. Avoiding bad asymptotic behaviour here means-we have to compute the kind and role of a coercion simultaneously,-which makes the code complicated and inefficient.--This only happens for NthCo. Caching the role solves the problem, and-allows coercionKind and coercionRole to be simple.--See #11735--Note [InstCo roles]-~~~~~~~~~~~~~~~~~~~-Here is (essentially) the typing rule for InstCo:--g :: (forall a. t1) ~r (forall a. t2)-w :: s1 ~N s2-------------------------------- InstCo-InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2])--Note that the Coercion w *must* be nominal. This is necessary-because the variable a might be used in a "nominal position"-(that is, a place where role inference would require a nominal-role) in t1 or t2. If we allowed w to be representational, we-could get bogus equalities.--A more nuanced treatment might be able to relax this condition-somewhat, by checking if t1 and/or t2 use their bound variables-in nominal ways. If not, having w be representational is OK.---%************************************************************************-%*                                                                      *-                UnivCoProvenance-%*                                                                      *-%************************************************************************--A UnivCo is a coercion whose proof does not directly express its role-and kind (indeed for some UnivCos, like PluginProv, there /is/ no proof).--The different kinds of UnivCo are described by UnivCoProvenance.  Really-each is entirely separate, but they all share the need to represent their-role and kind, which is done in the UnivCo constructor.---}---- | For simplicity, we have just one UnivCo that represents a coercion from--- some type to some other type, with (in general) no restrictions on the--- type. The UnivCoProvenance specifies more exactly what the coercion really--- is and why a program should (or shouldn't!) trust the coercion.--- It is reasonable to consider each constructor of 'UnivCoProvenance'--- as a totally independent coercion form; their only commonality is--- that they don't tell you what types they coercion between. (That info--- is in the 'UnivCo' constructor of 'Coercion'.-data UnivCoProvenance-  = PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom-                             -- roled coercions--  | ProofIrrelProv KindCoercion  -- ^ From the fact that any two coercions are-                                 --   considered equivalent. See Note [ProofIrrelProv].-                                 -- Can be used in Nominal or Representational coercions--  | PluginProv String  -- ^ From a plugin, which asserts that this coercion-                       --   is sound. The string is for the use of the plugin.--  deriving Data.Data--instance Outputable UnivCoProvenance where-  ppr (PhantomProv _)    = text "(phantom)"-  ppr (ProofIrrelProv _) = text "(proof irrel.)"-  ppr (PluginProv str)   = parens (text "plugin" <+> brackets (text str))---- | A coercion to be filled in by the type-checker. See Note [Coercion holes]-data CoercionHole-  = CoercionHole { ch_co_var :: CoVar-                       -- See Note [CoercionHoles and coercion free variables]--                 , ch_ref    :: IORef (Maybe Coercion)-                 }--coHoleCoVar :: CoercionHole -> CoVar-coHoleCoVar = ch_co_var--setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole-setCoHoleCoVar h cv = h { ch_co_var = cv }--instance Data.Data CoercionHole where-  -- don't traverse?-  toConstr _   = abstractConstr "CoercionHole"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "CoercionHole"--instance Outputable CoercionHole where-  ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv)---{- Note [Phantom coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-     data T a = T1 | T2-Then we have-     T s ~R T t-for any old s,t. The witness for this is (TyConAppCo T Rep co),-where (co :: s ~P t) is a phantom coercion built with PhantomProv.-The role of the UnivCo is always Phantom.  The Coercion stored is the-(nominal) kind coercion between the types-   kind(s) ~N kind (t)--Note [Coercion holes]-~~~~~~~~~~~~~~~~~~~~~~~~-During typechecking, constraint solving for type classes works by-  - Generate an evidence Id,  d7 :: Num a-  - Wrap it in a Wanted constraint, [W] d7 :: Num a-  - Use the evidence Id where the evidence is needed-  - Solve the constraint later-  - When solved, add an enclosing let-binding  let d7 = .... in ....-    which actually binds d7 to the (Num a) evidence--For equality constraints we use a different strategy.  See Note [The-equality types story] in TysPrim for background on equality constraints.-  - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just-    like type classes above. (Indeed, boxed equality constraints *are* classes.)-  - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2)-    we use a different plan--For unboxed equalities:-  - Generate a CoercionHole, a mutable variable just like a unification-    variable-  - Wrap the CoercionHole in a Wanted constraint; see TcRnTypes.TcEvDest-  - Use the CoercionHole in a Coercion, via HoleCo-  - Solve the constraint later-  - When solved, fill in the CoercionHole by side effect, instead of-    doing the let-binding thing--The main reason for all this is that there may be no good place to let-bind-the evidence for unboxed equalities:--  - We emit constraints for kind coercions, to be used to cast a-    type's kind. These coercions then must be used in types. Because-    they might appear in a top-level type, there is no place to bind-    these (unlifted) coercions in the usual way.--  - A coercion for (forall a. t1) ~ (forall a. t2) will look like-       forall a. (coercion for t1~t2)-    But the coercion for (t1~t2) may mention 'a', and we don't have-    let-bindings within coercions.  We could add them, but coercion-    holes are easier.--  - Moreover, nothing is lost from the lack of let-bindings. For-    dictionaries want to achieve sharing to avoid recomoputing the-    dictionary.  But coercions are entirely erased, so there's little-    benefit to sharing. Indeed, even if we had a let-binding, we-    always inline types and coercions at every use site and drop the-    binding.--Other notes about HoleCo:-- * INVARIANT: CoercionHole and HoleCo are used only during type checking,-   and should never appear in Core. Just like unification variables; a Type-   can contain a TcTyVar, but only during type checking. If, one day, we-   use type-level information to separate out forms that can appear during-   type-checking vs forms that can appear in core proper, holes in Core will-   be ruled out.-- * See Note [CoercionHoles and coercion free variables]-- * Coercion holes can be compared for equality like other coercions:-   by looking at the types coerced.---Note [CoercionHoles and coercion free variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Why does a CoercionHole contain a CoVar, as well as reference to-fill in?  Because we want to treat that CoVar as a free variable of-the coercion.  See #14584, and Note [What prevents a-constraint from floating] in TcSimplify, item (4):--        forall k. [W] co1 :: t1 ~# t2 |> co2-                  [W] co2 :: k ~# *--Here co2 is a CoercionHole. But we /must/ know that it is free in-co1, because that's all that stops it floating outside the-implication.---Note [ProofIrrelProv]-~~~~~~~~~~~~~~~~~~~~~-A ProofIrrelProv is a coercion between coercions. For example:--  data G a where-    MkG :: G Bool--In core, we get--  G :: * -> *-  MkG :: forall (a :: *). (a ~ Bool) -> G a--Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want-a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be--  TyConAppCo Nominal MkG [co3, co4]-  where-    co3 :: co1 ~ co2-    co4 :: a1 ~ a2--Note that-  co1 :: a1 ~ Bool-  co2 :: a2 ~ Bool--Here,-  co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2)-  where-    co5 :: (a1 ~ Bool) ~ (a2 ~ Bool)-    co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, <Bool>]--}---{- *********************************************************************-*                                                                      *-                foldType  and   foldCoercion-*                                                                      *-********************************************************************* -}--{- Note [foldType]-~~~~~~~~~~~~~~~~~~-foldType is a bit more powerful than perhaps it looks:--* You can fold with an accumulating parameter, via-     TyCoFolder env (Endo a)-  Recall newtype Endo a = Endo (a->a)--* You can fold monadically with a monad M, via-     TyCoFolder env (M a)-  provided you have-     instance ..  => Monoid (M a)--Note [mapType vs foldType]-~~~~~~~~~~~~~~~~~~~~~~~~~~-We define foldType here, but mapType in module Type. Why?--* foldType is used in TyCoFVs for finding free variables.-  It's a very simple function that analyses a type,-  but does not construct one.--* mapType constructs new types, and so it needs to call-  the "smart constructors", mkAppTy, mkCastTy, and so on.-  These are sophisticated functions, and can't be defined-  here in TyCoRep.--Note [Specialising foldType]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We inline foldType at every call site (there are not many), so that it-becomes specialised for the particular monoid *and* TyCoFolder at-that site.  This is just for efficiency, but walking over types is-done a *lot* in GHC, so worth optimising.--We were worried that-    TyCoFolder env (Endo a)-might not eta-expand.  Recall newtype Endo a = Endo (a->a).--In particular, given-   fvs :: Type -> TyCoVarSet-   fvs ty = appEndo (foldType tcf emptyVarSet ty) emptyVarSet--   tcf :: TyCoFolder enf (Endo a)-   tcf = TyCoFolder { tcf_tyvar = do_tv, ... }-      where-        do_tvs is tv = Endo do_it-           where-             do_it acc | tv `elemVarSet` is  = acc-                       | tv `elemVarSet` acc = acc-                       | otherwise = acc `extendVarSet` tv---we want to end up with-   fvs ty = go emptyVarSet ty emptyVarSet-     where-       go env (TyVarTy tv) acc = acc `extendVarSet` tv-       ..etc..--And indeed this happens.-  - Selections from 'tcf' are done at compile time-  - 'go' is nicely eta-expanded.--We were also worried about-   deep_fvs :: Type -> TyCoVarSet-   deep_fvs ty = appEndo (foldType deep_tcf emptyVarSet ty) emptyVarSet--   deep_tcf :: TyCoFolder enf (Endo a)-   deep_tcf = TyCoFolder { tcf_tyvar = do_tv, ... }-      where-        do_tvs is tv = Endo do_it-           where-             do_it acc | tv `elemVarSet` is  = acc-                       | tv `elemVarSet` acc = acc-                       | otherwise = deep_fvs (varType tv)-                                     `unionVarSet` acc-                                     `extendVarSet` tv--Here deep_fvs and deep_tcf are mutually recursive, unlike fvs and tcf.-But, amazingly, we get good code here too. GHC is careful not to makr-TyCoFolder data constructor for deep_tcf as a loop breaker, so the-record selections still cancel.  And eta expansion still happens too.--}--data TyCoFolder env a-  = TyCoFolder-      { tcf_view  :: Type -> Maybe Type   -- Optional "view" function-                                          -- E.g. expand synonyms-      , tcf_tyvar :: env -> TyVar -> a-      , tcf_covar :: env -> CoVar -> a-      , tcf_hole  :: env -> CoercionHole -> a-          -- ^ What to do with coercion holes.-          -- See Note [Coercion holes] in TyCoRep.--      , tcf_tycobinder :: env -> TyCoVar -> ArgFlag -> env-          -- ^ The returned env is used in the extended scope-      }--{-# INLINE foldTyCo  #-}  -- See Note [Specialising foldType]-foldTyCo :: Monoid a => TyCoFolder env a -> env-         -> (Type -> a, [Type] -> a, Coercion -> a, [Coercion] -> a)-foldTyCo (TyCoFolder { tcf_view       = view-                     , tcf_tyvar      = tyvar-                     , tcf_tycobinder = tycobinder-                     , tcf_covar      = covar-                     , tcf_hole       = cohole }) env-  = (go_ty env, go_tys env, go_co env, go_cos env)-  where-    go_ty env ty | Just ty' <- view ty = go_ty env ty'-    go_ty env (TyVarTy tv)      = tyvar env tv-    go_ty env (AppTy t1 t2)     = go_ty env t1 `mappend` go_ty env t2-    go_ty _   (LitTy {})        = mempty-    go_ty env (CastTy ty co)    = go_ty env ty `mappend` go_co env co-    go_ty env (CoercionTy co)   = go_co env co-    go_ty env (FunTy _ arg res) = go_ty env arg `mappend` go_ty env res-    go_ty env (TyConApp _ tys)  = go_tys env tys-    go_ty env (ForAllTy (Bndr tv vis) inner)-      = let !env' = tycobinder env tv vis  -- Avoid building a thunk here-        in go_ty env (varType tv) `mappend` go_ty env' inner--    -- Explicit recursion becuase using foldr builds a local-    -- loop (with env free) and I'm not confident it'll be-    -- lambda lifted in the end-    go_tys _   []     = mempty-    go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts--    go_cos _   []     = mempty-    go_cos env (c:cs) = go_co env c `mappend` go_cos env cs--    go_co env (Refl ty)               = go_ty env ty-    go_co env (GRefl _ ty MRefl)      = go_ty env ty-    go_co env (GRefl _ ty (MCo co))   = go_ty env ty `mappend` go_co env co-    go_co env (TyConAppCo _ _ args)   = go_cos env args-    go_co env (AppCo c1 c2)           = go_co env c1 `mappend` go_co env c2-    go_co env (FunCo _ c1 c2)         = go_co env c1 `mappend` go_co env c2-    go_co env (CoVarCo cv)            = covar env cv-    go_co env (AxiomInstCo _ _ args)  = go_cos env args-    go_co env (HoleCo hole)           = cohole env hole-    go_co env (UnivCo p _ t1 t2)      = go_prov env p `mappend` go_ty env t1-                                                      `mappend` go_ty env t2-    go_co env (SymCo co)              = go_co env co-    go_co env (TransCo c1 c2)         = go_co env c1 `mappend` go_co env c2-    go_co env (AxiomRuleCo _ cos)     = go_cos env cos-    go_co env (NthCo _ _ co)          = go_co env co-    go_co env (LRCo _ co)             = go_co env co-    go_co env (InstCo co arg)         = go_co env co `mappend` go_co env arg-    go_co env (KindCo co)             = go_co env co-    go_co env (SubCo co)              = go_co env co-    go_co env (ForAllCo tv kind_co co)-      = go_co env kind_co `mappend` go_ty env (varType tv)-                          `mappend` go_co env' co-      where-        env' = tycobinder env tv Inferred--    go_prov env (PhantomProv co)    = go_co env co-    go_prov env (ProofIrrelProv co) = go_co env co-    go_prov _   (PluginProv _)      = mempty--{- *********************************************************************-*                                                                      *-                   typeSize, coercionSize-*                                                                      *-********************************************************************* -}---- NB: We put typeSize/coercionSize here because they are mutually---     recursive, and have the CPR property.  If we have mutual---     recursion across a hi-boot file, we don't get the CPR property---     and these functions allocate a tremendous amount of rubbish.---     It's not critical (because typeSize is really only used in---     debug mode, but I tripped over an example (T5642) in which---     typeSize was one of the biggest single allocators in all of GHC.---     And it's easy to fix, so I did.---- NB: typeSize does not respect `eqType`, in that two types that---     are `eqType` may return different sizes. This is OK, because this---     function is used only in reporting, not decision-making.--typeSize :: Type -> Int-typeSize (LitTy {})                 = 1-typeSize (TyVarTy {})               = 1-typeSize (AppTy t1 t2)              = typeSize t1 + typeSize t2-typeSize (FunTy _ t1 t2)            = typeSize t1 + typeSize t2-typeSize (ForAllTy (Bndr tv _) t)   = typeSize (varType tv) + typeSize t-typeSize (TyConApp _ ts)            = 1 + sum (map typeSize ts)-typeSize (CastTy ty co)             = typeSize ty + coercionSize co-typeSize (CoercionTy co)            = coercionSize co--coercionSize :: Coercion -> Int-coercionSize (Refl ty)             = typeSize ty-coercionSize (GRefl _ ty MRefl)    = typeSize ty-coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co-coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args)-coercionSize (AppCo co arg)      = coercionSize co + coercionSize arg-coercionSize (ForAllCo _ h co)   = 1 + coercionSize co + coercionSize h-coercionSize (FunCo _ co1 co2)   = 1 + coercionSize co1 + coercionSize co2-coercionSize (CoVarCo _)         = 1-coercionSize (HoleCo _)          = 1-coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args)-coercionSize (UnivCo p _ t1 t2)  = 1 + provSize p + typeSize t1 + typeSize t2-coercionSize (SymCo co)          = 1 + coercionSize co-coercionSize (TransCo co1 co2)   = 1 + coercionSize co1 + coercionSize co2-coercionSize (NthCo _ _ co)      = 1 + coercionSize co-coercionSize (LRCo  _ co)        = 1 + coercionSize co-coercionSize (InstCo co arg)     = 1 + coercionSize co + coercionSize arg-coercionSize (KindCo co)         = 1 + coercionSize co-coercionSize (SubCo co)          = 1 + coercionSize co-coercionSize (AxiomRuleCo _ cs)  = 1 + sum (map coercionSize cs)--provSize :: UnivCoProvenance -> Int-provSize (PhantomProv co)    = 1 + coercionSize co-provSize (ProofIrrelProv co) = 1 + coercionSize co-provSize (PluginProv _)      = 1
− compiler/types/TyCoRep.hs-boot 
@@ -1,23 +0,0 @@-module TyCoRep where--import Data.Data  ( Data )-import {-# SOURCE #-} Var( Var, ArgFlag, AnonArgFlag )--data Type-data TyThing-data Coercion-data UnivCoProvenance-data TyLit-data TyCoBinder-data MCoercion--type PredType = Type-type Kind = Type-type ThetaType = [PredType]-type CoercionN = Coercion-type MCoercionN = MCoercion--mkFunTy   :: AnonArgFlag -> Type -> Type -> Type-mkForAllTy :: Var -> ArgFlag -> Type -> Type--instance Data Type  -- To support Data instances in CoAxiom
− compiler/types/TyCoSubst.hs 
@@ -1,1030 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1998-Type and Coercion - friends' interface--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}---- | Substitution into types and coercions.-module TyCoSubst-  (-        -- * Substitutions-        TCvSubst(..), TvSubstEnv, CvSubstEnv,-        emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst,-        emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst,-        mkTCvSubst, mkTvSubst, mkCvSubst,-        getTvSubstEnv,-        getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs,-        isInScope, notElemTCvSubst,-        setTvSubstEnv, setCvSubstEnv, zapTCvSubst,-        extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet,-        extendTCvSubst, extendTCvSubstWithClone,-        extendCvSubst, extendCvSubstWithClone,-        extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone,-        extendTvSubstList, extendTvSubstAndInScope,-        extendTCvSubstList,-        unionTCvSubst, zipTyEnv, zipCoEnv,-        zipTvSubst, zipCvSubst,-        zipTCvSubst,-        mkTvSubstPrs,--        substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars,-        substCoWith,-        substTy, substTyAddInScope,-        substTyUnchecked, substTysUnchecked, substThetaUnchecked,-        substTyWithUnchecked,-        substCoUnchecked, substCoWithUnchecked,-        substTyWithInScope,-        substTys, substTheta,-        lookupTyVar,-        substCo, substCos, substCoVar, substCoVars, lookupCoVar,-        cloneTyVarBndr, cloneTyVarBndrs,-        substVarBndr, substVarBndrs,-        substTyVarBndr, substTyVarBndrs,-        substCoVarBndr,-        substTyVar, substTyVars, substTyCoVars,-        substForAllCoBndr,-        substVarBndrUsing, substForAllCoBndrUsing,-        checkValidSubst, isValidTCvSubst,-  ) where--#include "HsVersions.h"--import GhcPrelude--import {-# SOURCE #-} Type ( mkCastTy, mkAppTy, isCoercionTy )-import {-# SOURCE #-} Coercion ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo-                               , mkNomReflCo, mkSubCo, mkSymCo-                               , mkFunCo, mkForAllCo, mkUnivCo-                               , mkAxiomInstCo, mkAppCo, mkGReflCo-                               , mkInstCo, mkLRCo, mkTyConAppCo-                               , mkCoercionType-                               , coercionKind, coercionLKind, coVarKindsTypesRole )--import TyCoRep-import TyCoFVs-import TyCoPpr--import Var-import VarSet-import VarEnv--import Pair-import Util-import UniqSupply-import Unique-import UniqFM-import UniqSet-import Outputable--import Data.List (mapAccumL)--{--%************************************************************************-%*                                                                      *-                        Substitutions-      Data type defined here to avoid unnecessary mutual recursion-%*                                                                      *-%************************************************************************--}---- | Type & coercion substitution------ #tcvsubst_invariant#--- The following invariants must hold of a 'TCvSubst':------ 1. The in-scope set is needed /only/ to--- guide the generation of fresh uniques------ 2. In particular, the /kind/ of the type variables in--- the in-scope set is not relevant------ 3. The substitution is only applied ONCE! This is because--- in general such application will not reach a fixed point.-data TCvSubst-  = TCvSubst InScopeSet -- The in-scope type and kind variables-             TvSubstEnv -- Substitutes both type and kind variables-             CvSubstEnv -- Substitutes coercion variables-        -- See Note [Substitutions apply only once]-        -- and Note [Extending the TvSubstEnv]-        -- and Note [Substituting types and coercions]-        -- and Note [The substitution invariant]---- | A substitution of 'Type's for 'TyVar's---                 and 'Kind's for 'KindVar's-type TvSubstEnv = TyVarEnv Type-  -- NB: A TvSubstEnv is used-  --   both inside a TCvSubst (with the apply-once invariant-  --        discussed in Note [Substitutions apply only once],-  --   and  also independently in the middle of matching,-  --        and unification (see Types.Unify).-  -- So you have to look at the context to know if it's idempotent or-  -- apply-once or whatever---- | A substitution of 'Coercion's for 'CoVar's-type CvSubstEnv = CoVarEnv Coercion--{- Note [The substitution invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When calling (substTy subst ty) it should be the case that-the in-scope set in the substitution is a superset of both:--  (SIa) The free vars of the range of the substitution-  (SIb) The free vars of ty minus the domain of the substitution--The same rules apply to other substitutions (notably GHC.Core.Subst.Subst)--* Reason for (SIa). Consider-      substTy [a :-> Maybe b] (forall b. b->a)-  we must rename the forall b, to get-      forall b2. b2 -> Maybe b-  Making 'b' part of the in-scope set forces this renaming to-  take place.--* Reason for (SIb). Consider-     substTy [a :-> Maybe b] (forall b. (a,b,x))-  Then if we use the in-scope set {b}, satisfying (SIa), there is-  a danger we will rename the forall'd variable to 'x' by mistake,-  getting this:-      forall x. (Maybe b, x, x)-  Breaking (SIb) caused the bug from #11371.--Note: if the free vars of the range of the substitution are freshly created,-then the problems of (SIa) can't happen, and so it would be sound to-ignore (SIa).--Note [Substitutions apply only once]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We use TCvSubsts to instantiate things, and we might instantiate-        forall a b. ty-with the types-        [a, b], or [b, a].-So the substitution might go [a->b, b->a].  A similar situation arises in Core-when we find a beta redex like-        (/\ a /\ b -> e) b a-Then we also end up with a substitution that permutes type variables. Other-variations happen to; for example [a -> (a, b)].--        ********************************************************-        *** So a substitution must be applied precisely once ***-        ********************************************************--A TCvSubst is not idempotent, but, unlike the non-idempotent substitution-we use during unifications, it must not be repeatedly applied.--Note [Extending the TvSubstEnv]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See #tcvsubst_invariant# for the invariants that must hold.--This invariant allows a short-cut when the subst envs are empty:-if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst)-holds --- then (substTy subst ty) does nothing.--For example, consider:-        (/\a. /\b:(a~Int). ...b..) Int-We substitute Int for 'a'.  The Unique of 'b' does not change, but-nevertheless we add 'b' to the TvSubstEnv, because b's kind does change--This invariant has several crucial consequences:--* In substVarBndr, we need extend the TvSubstEnv-        - if the unique has changed-        - or if the kind has changed--* In substTyVar, we do not need to consult the in-scope set;-  the TvSubstEnv is enough--* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty--Note [Substituting types and coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Types and coercions are mutually recursive, and either may have variables-"belonging" to the other. Thus, every time we wish to substitute in a-type, we may also need to substitute in a coercion, and vice versa.-However, the constructor used to create type variables is distinct from-that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note-that it would be possible to use the CoercionTy constructor to combine-these environments, but that seems like a false economy.--Note that the TvSubstEnv should *never* map a CoVar (built with the Id-constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore,-the range of the TvSubstEnv should *never* include a type headed with-CoercionTy.--}--emptyTvSubstEnv :: TvSubstEnv-emptyTvSubstEnv = emptyVarEnv--emptyCvSubstEnv :: CvSubstEnv-emptyCvSubstEnv = emptyVarEnv--composeTCvSubstEnv :: InScopeSet-                   -> (TvSubstEnv, CvSubstEnv)-                   -> (TvSubstEnv, CvSubstEnv)-                   -> (TvSubstEnv, CvSubstEnv)--- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@.--- It assumes that both are idempotent.--- Typically, @env1@ is the refinement to a base substitution @env2@-composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2)-  = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2-    , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 )-        -- First apply env1 to the range of env2-        -- Then combine the two, making sure that env1 loses if-        -- both bind the same variable; that's why env1 is the-        --  *left* argument to plusVarEnv, because the right arg wins-  where-    subst1 = TCvSubst in_scope tenv1 cenv1---- | Composes two substitutions, applying the second one provided first,--- like in function composition.-composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst-composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2)-  = TCvSubst is3 tenv3 cenv3-  where-    is3 = is1 `unionInScope` is2-    (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2)--emptyTCvSubst :: TCvSubst-emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv--mkEmptyTCvSubst :: InScopeSet -> TCvSubst-mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv--isEmptyTCvSubst :: TCvSubst -> Bool-         -- See Note [Extending the TvSubstEnv]-isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv--mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst-mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv--mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst--- ^ Make a TCvSubst with specified tyvar subst and empty covar subst-mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv--mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst--- ^ Make a TCvSubst with specified covar subst and empty tyvar subst-mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv--getTvSubstEnv :: TCvSubst -> TvSubstEnv-getTvSubstEnv (TCvSubst _ env _) = env--getCvSubstEnv :: TCvSubst -> CvSubstEnv-getCvSubstEnv (TCvSubst _ _ env) = env--getTCvInScope :: TCvSubst -> InScopeSet-getTCvInScope (TCvSubst in_scope _ _) = in_scope---- | Returns the free variables of the types in the range of a substitution as--- a non-deterministic set.-getTCvSubstRangeFVs :: TCvSubst -> VarSet-getTCvSubstRangeFVs (TCvSubst _ tenv cenv)-    = unionVarSet tenvFVs cenvFVs-  where-    tenvFVs = shallowTyCoVarsOfTyVarEnv tenv-    cenvFVs = shallowTyCoVarsOfCoVarEnv cenv--isInScope :: Var -> TCvSubst -> Bool-isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope--notElemTCvSubst :: Var -> TCvSubst -> Bool-notElemTCvSubst v (TCvSubst _ tenv cenv)-  | isTyVar v-  = not (v `elemVarEnv` tenv)-  | otherwise-  = not (v `elemVarEnv` cenv)--setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst-setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv--setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst-setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv--zapTCvSubst :: TCvSubst -> TCvSubst-zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv--extendTCvInScope :: TCvSubst -> Var -> TCvSubst-extendTCvInScope (TCvSubst in_scope tenv cenv) var-  = TCvSubst (extendInScopeSet in_scope var) tenv cenv--extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst-extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars-  = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv--extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst-extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars-  = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv--extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst-extendTCvSubst subst v ty-  | isTyVar v-  = extendTvSubst subst v ty-  | CoercionTy co <- ty-  = extendCvSubst subst v co-  | otherwise-  = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty)--extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst-extendTCvSubstWithClone subst tcv-  | isTyVar tcv = extendTvSubstWithClone subst tcv-  | otherwise   = extendCvSubstWithClone subst tcv--extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst-extendTvSubst (TCvSubst in_scope tenv cenv) tv ty-  = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv--extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst-extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty-  = ASSERT( isTyVar v )-    extendTvSubstAndInScope subst v ty-extendTvSubstBinderAndInScope subst (Anon {}) _-  = subst--extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst--- Adds a new tv -> tv mapping, /and/ extends the in-scope set-extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv'-  = TCvSubst (extendInScopeSetSet in_scope new_in_scope)-             (extendVarEnv tenv tv (mkTyVarTy tv'))-             cenv-  where-    new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv'--extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst-extendCvSubst (TCvSubst in_scope tenv cenv) v co-  = TCvSubst in_scope tenv (extendVarEnv cenv v co)--extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst-extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv'-  = TCvSubst (extendInScopeSetSet in_scope new_in_scope)-             tenv-             (extendVarEnv cenv cv (mkCoVarCo cv'))-  where-    new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv'--extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst--- Also extends the in-scope set-extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty-  = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty)-             (extendVarEnv tenv tv ty)-             cenv--extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst-extendTvSubstList subst tvs tys-  = foldl2 extendTvSubst subst tvs tys--extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst-extendTCvSubstList subst tvs tys-  = foldl2 extendTCvSubst subst tvs tys--unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst--- Works when the ranges are disjoint-unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2)-  = ASSERT( not (tenv1 `intersectsVarEnv` tenv2)-         && not (cenv1 `intersectsVarEnv` cenv2) )-    TCvSubst (in_scope1 `unionInScope` in_scope2)-             (tenv1     `plusVarEnv`   tenv2)-             (cenv1     `plusVarEnv`   cenv2)---- mkTvSubstPrs and zipTvSubst generate the in-scope set from--- the types given; but it's just a thunk so with a bit of luck--- it'll never be evaluated---- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming--- environment. No CoVars, please!-zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst-zipTvSubst tvs tys-  = mkTvSubst (mkInScopeSet (shallowTyCoVarsOfTypes tys)) tenv-  where-    tenv = zipTyEnv tvs tys---- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming--- environment.  No TyVars, please!-zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst-zipCvSubst cvs cos-  = TCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) emptyTvSubstEnv cenv-  where-    cenv = zipCoEnv cvs cos--zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst-zipTCvSubst tcvs tys-  = zip_tcvsubst tcvs tys $-    mkEmptyTCvSubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys-  where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst-        zip_tcvsubst (tv:tvs) (ty:tys) subst-          = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty)-        zip_tcvsubst [] [] subst = subst -- empty case-        zip_tcvsubst _  _  _     = pprPanic "zipTCvSubst: length mismatch"-                                            (ppr tcvs <+> ppr tys)---- | Generates the in-scope set for the 'TCvSubst' from the types in the--- incoming environment. No CoVars, please!-mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst-mkTvSubstPrs prs =-    ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs )-    mkTvSubst in_scope tenv-  where tenv = mkVarEnv prs-        in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ map snd prs-        onlyTyVarsAndNoCoercionTy =-          and [ isTyVar tv && not (isCoercionTy ty)-              | (tv, ty) <- prs ]--zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv-zipTyEnv tyvars tys-  | debugIsOn-  , not (all isTyVar tyvars)-  = pprPanic "zipTyEnv" (ppr tyvars <+> ppr tys)-  | otherwise-  = ASSERT( all (not . isCoercionTy) tys )-    mkVarEnv (zipEqual "zipTyEnv" tyvars tys)-        -- There used to be a special case for when-        --      ty == TyVarTy tv-        -- (a not-uncommon case) in which case the substitution was dropped.-        -- But the type-tidier changes the print-name of a type variable without-        -- changing the unique, and that led to a bug.   Why?  Pre-tidying, we had-        -- a type {Foo t}, where Foo is a one-method class.  So Foo is really a newtype.-        -- And it happened that t was the type variable of the class.  Post-tiding,-        -- it got turned into {Foo t2}.  The ext-core printer expanded this using-        -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique,-        -- and so generated a rep type mentioning t not t2.-        ---        -- Simplest fix is to nuke the "optimisation"--zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv-zipCoEnv cvs cos-  | debugIsOn-  , not (all isCoVar cvs)-  = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos)-  | otherwise-  = mkVarEnv (zipEqual "zipCoEnv" cvs cos)--instance Outputable TCvSubst where-  ppr (TCvSubst ins tenv cenv)-    = brackets $ sep[ text "TCvSubst",-                      nest 2 (text "In scope:" <+> ppr ins),-                      nest 2 (text "Type env:" <+> ppr tenv),-                      nest 2 (text "Co env:" <+> ppr cenv) ]--{--%************************************************************************-%*                                                                      *-                Performing type or kind substitutions-%*                                                                      *-%************************************************************************--Note [Sym and ForAllCo]-~~~~~~~~~~~~~~~~~~~~~~~-In OptCoercion, we try to push "sym" out to the leaves of a coercion. But,-how do we push sym into a ForAllCo? It's a little ugly.--Here is the typing rule:--h : k1 ~# k2-(tv : k1) |- g : ty1 ~# ty2------------------------------ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~#-                  (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h]))--Here is what we want:--ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~#-                    (ForAllTy (tv : k1) ty1)---Because the kinds of the type variables to the right of the colon are the kinds-coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h).--Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want--ForAllCo tv h' g' :-  (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~#-  (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h']))--We thus see that we want--g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h']--and thus g' = sym (g[tv |-> tv |> h']).--Putting it all together, we get this:--sym (ForAllCo tv h g)-==>-ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h])--Note [Substituting in a coercion hole]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It seems highly suspicious to be substituting in a coercion that still-has coercion holes. Yet, this can happen in a situation like this:--  f :: forall k. k :~: Type -> ()-  f Refl = let x :: forall (a :: k). [a] -> ...-               x = ...--When we check x's type signature, we require that k ~ Type. We indeed-know this due to the Refl pattern match, but the eager unifier can't-make use of givens. So, when we're done looking at x's type, a coercion-hole will remain. Then, when we're checking x's definition, we skolemise-x's type (in order to, e.g., bring the scoped type variable `a` into scope).-This requires performing a substitution for the fresh skolem variables.--This substitution needs to affect the kind of the coercion hole, too ---otherwise, the kind will have an out-of-scope variable in it. More problematically-in practice (we won't actually notice the out-of-scope variable ever), skolems-in the kind might have too high a level, triggering a failure to uphold the-invariant that no free variables in a type have a higher level than the-ambient level in the type checker. In the event of having free variables in the-hole's kind, I'm pretty sure we'll always have an erroneous program, so we-don't need to worry what will happen when the hole gets filled in. After all,-a hole relating a locally-bound type variable will be unable to be solved. This-is why it's OK not to look through the IORef of a coercion hole during-substitution.---}---- | Type substitution, see 'zipTvSubst'-substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type--- Works only if the domain of the substitution is a--- superset of the type being substituted into-substTyWith tvs tys = {-#SCC "substTyWith" #-}-                      ASSERT( tvs `equalLength` tys )-                      substTy (zipTvSubst tvs tys)---- | Type substitution, see 'zipTvSubst'. Disables sanity checks.--- The problems that the sanity checks in substTy catch are described in--- Note [The substitution invariant].--- The goal of #11371 is to migrate all the calls of substTyUnchecked to--- substTy and remove this function. Please don't use in new code.-substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type-substTyWithUnchecked tvs tys-  = ASSERT( tvs `equalLength` tys )-    substTyUnchecked (zipTvSubst tvs tys)---- | Substitute tyvars within a type using a known 'InScopeSet'.--- Pre-condition: the 'in_scope' set should satisfy Note [The substitution--- invariant]; specifically it should include the free vars of 'tys',--- and of 'ty' minus the domain of the subst.-substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type-substTyWithInScope in_scope tvs tys ty =-  ASSERT( tvs `equalLength` tys )-  substTy (mkTvSubst in_scope tenv) ty-  where tenv = zipTyEnv tvs tys---- | Coercion substitution, see 'zipTvSubst'-substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion-substCoWith tvs tys = ASSERT( tvs `equalLength` tys )-                      substCo (zipTvSubst tvs tys)---- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks.--- The problems that the sanity checks in substCo catch are described in--- Note [The substitution invariant].--- The goal of #11371 is to migrate all the calls of substCoUnchecked to--- substCo and remove this function. Please don't use in new code.-substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion-substCoWithUnchecked tvs tys-  = ASSERT( tvs `equalLength` tys )-    substCoUnchecked (zipTvSubst tvs tys)------ | Substitute covars within a type-substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type-substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos)---- | Type substitution, see 'zipTvSubst'-substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]-substTysWith tvs tys = ASSERT( tvs `equalLength` tys )-                       substTys (zipTvSubst tvs tys)---- | Type substitution, see 'zipTvSubst'-substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type]-substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos )-                             substTys (zipCvSubst cvs cos)---- | Substitute within a 'Type' after adding the free variables of the type--- to the in-scope set. This is useful for the case when the free variables--- aren't already in the in-scope set or easily available.--- See also Note [The substitution invariant].-substTyAddInScope :: TCvSubst -> Type -> Type-substTyAddInScope subst ty =-  substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty---- | When calling `substTy` it should be the case that the in-scope set in--- the substitution is a superset of the free vars of the range of the--- substitution.--- See also Note [The substitution invariant].-isValidTCvSubst :: TCvSubst -> Bool-isValidTCvSubst (TCvSubst in_scope tenv cenv) =-  (tenvFVs `varSetInScope` in_scope) &&-  (cenvFVs `varSetInScope` in_scope)-  where-  tenvFVs = shallowTyCoVarsOfTyVarEnv tenv-  cenvFVs = shallowTyCoVarsOfCoVarEnv cenv---- | This checks if the substitution satisfies the invariant from--- Note [The substitution invariant].-checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a-checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a-  = ASSERT2( isValidTCvSubst subst,-             text "in_scope" <+> ppr in_scope $$-             text "tenv" <+> ppr tenv $$-             text "tenvFVs" <+> ppr (shallowTyCoVarsOfTyVarEnv tenv) $$-             text "cenv" <+> ppr cenv $$-             text "cenvFVs" <+> ppr (shallowTyCoVarsOfCoVarEnv cenv) $$-             text "tys" <+> ppr tys $$-             text "cos" <+> ppr cos )-    ASSERT2( tysCosFVsInScope,-             text "in_scope" <+> ppr in_scope $$-             text "tenv" <+> ppr tenv $$-             text "cenv" <+> ppr cenv $$-             text "tys" <+> ppr tys $$-             text "cos" <+> ppr cos $$-             text "needInScope" <+> ppr needInScope )-    a-  where-  substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv-    -- It's OK to use nonDetKeysUFM here, because we only use this list to-    -- remove some elements from a set-  needInScope = (shallowTyCoVarsOfTypes tys `unionVarSet`-                 shallowTyCoVarsOfCos cos)-                `delListFromUniqSet_Directly` substDomain-  tysCosFVsInScope = needInScope `varSetInScope` in_scope----- | Substitute within a 'Type'--- The substitution has to satisfy the invariants described in--- Note [The substitution invariant].-substTy :: HasCallStack => TCvSubst -> Type  -> Type-substTy subst ty-  | isEmptyTCvSubst subst = ty-  | otherwise             = checkValidSubst subst [ty] [] $-                            subst_ty subst ty---- | Substitute within a 'Type' disabling the sanity checks.--- The problems that the sanity checks in substTy catch are described in--- Note [The substitution invariant].--- The goal of #11371 is to migrate all the calls of substTyUnchecked to--- substTy and remove this function. Please don't use in new code.-substTyUnchecked :: TCvSubst -> Type -> Type-substTyUnchecked subst ty-                 | isEmptyTCvSubst subst = ty-                 | otherwise             = subst_ty subst ty---- | Substitute within several 'Type's--- The substitution has to satisfy the invariants described in--- Note [The substitution invariant].-substTys :: HasCallStack => TCvSubst -> [Type] -> [Type]-substTys subst tys-  | isEmptyTCvSubst subst = tys-  | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys---- | Substitute within several 'Type's disabling the sanity checks.--- The problems that the sanity checks in substTys catch are described in--- Note [The substitution invariant].--- The goal of #11371 is to migrate all the calls of substTysUnchecked to--- substTys and remove this function. Please don't use in new code.-substTysUnchecked :: TCvSubst -> [Type] -> [Type]-substTysUnchecked subst tys-                 | isEmptyTCvSubst subst = tys-                 | otherwise             = map (subst_ty subst) tys---- | Substitute within a 'ThetaType'--- The substitution has to satisfy the invariants described in--- Note [The substitution invariant].-substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType-substTheta = substTys---- | Substitute within a 'ThetaType' disabling the sanity checks.--- The problems that the sanity checks in substTys catch are described in--- Note [The substitution invariant].--- The goal of #11371 is to migrate all the calls of substThetaUnchecked to--- substTheta and remove this function. Please don't use in new code.-substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType-substThetaUnchecked = substTysUnchecked---subst_ty :: TCvSubst -> Type -> Type--- subst_ty is the main workhorse for type substitution------ Note that the in_scope set is poked only if we hit a forall--- so it may often never be fully computed-subst_ty subst ty-   = go ty-  where-    go (TyVarTy tv)      = substTyVar subst tv-    go (AppTy fun arg)   = mkAppTy (go fun) $! (go arg)-                -- The mkAppTy smart constructor is important-                -- we might be replacing (a Int), represented with App-                -- by [Int], represented with TyConApp-    go (TyConApp tc tys) = let args = map go tys-                           in  args `seqList` TyConApp tc args-    go ty@(FunTy { ft_arg = arg, ft_res = res })-      = let !arg' = go arg-            !res' = go res-        in ty { ft_arg = arg', ft_res = res' }-    go (ForAllTy (Bndr tv vis) ty)-                         = case substVarBndrUnchecked subst tv of-                             (subst', tv') ->-                               (ForAllTy $! ((Bndr $! tv') vis)) $!-                                            (subst_ty subst' ty)-    go (LitTy n)         = LitTy $! n-    go (CastTy ty co)    = (mkCastTy $! (go ty)) $! (subst_co subst co)-    go (CoercionTy co)   = CoercionTy $! (subst_co subst co)--substTyVar :: TCvSubst -> TyVar -> Type-substTyVar (TCvSubst _ tenv _) tv-  = ASSERT( isTyVar tv )-    case lookupVarEnv tenv tv of-      Just ty -> ty-      Nothing -> TyVarTy tv--substTyVars :: TCvSubst -> [TyVar] -> [Type]-substTyVars subst = map $ substTyVar subst--substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type]-substTyCoVars subst = map $ substTyCoVar subst--substTyCoVar :: TCvSubst -> TyCoVar -> Type-substTyCoVar subst tv-  | isTyVar tv = substTyVar subst tv-  | otherwise = CoercionTy $ substCoVar subst tv--lookupTyVar :: TCvSubst -> TyVar  -> Maybe Type-        -- See Note [Extending the TCvSubst]-lookupTyVar (TCvSubst _ tenv _) tv-  = ASSERT( isTyVar tv )-    lookupVarEnv tenv tv---- | Substitute within a 'Coercion'--- The substitution has to satisfy the invariants described in--- Note [The substitution invariant].-substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion-substCo subst co-  | isEmptyTCvSubst subst = co-  | otherwise = checkValidSubst subst [] [co] $ subst_co subst co---- | Substitute within a 'Coercion' disabling sanity checks.--- The problems that the sanity checks in substCo catch are described in--- Note [The substitution invariant].--- The goal of #11371 is to migrate all the calls of substCoUnchecked to--- substCo and remove this function. Please don't use in new code.-substCoUnchecked :: TCvSubst -> Coercion -> Coercion-substCoUnchecked subst co-  | isEmptyTCvSubst subst = co-  | otherwise = subst_co subst co---- | Substitute within several 'Coercion's--- The substitution has to satisfy the invariants described in--- Note [The substitution invariant].-substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion]-substCos subst cos-  | isEmptyTCvSubst subst = cos-  | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos--subst_co :: TCvSubst -> Coercion -> Coercion-subst_co subst co-  = go co-  where-    go_ty :: Type -> Type-    go_ty = subst_ty subst--    go_mco :: MCoercion -> MCoercion-    go_mco MRefl    = MRefl-    go_mco (MCo co) = MCo (go co)--    go :: Coercion -> Coercion-    go (Refl ty)             = mkNomReflCo $! (go_ty ty)-    go (GRefl r ty mco)      = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco)-    go (TyConAppCo r tc args)= let args' = map go args-                               in  args' `seqList` mkTyConAppCo r tc args'-    go (AppCo co arg)        = (mkAppCo $! go co) $! go arg-    go (ForAllCo tv kind_co co)-      = case substForAllCoBndrUnchecked subst tv kind_co of-         (subst', tv', kind_co') ->-          ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co-    go (FunCo r co1 co2)     = (mkFunCo r $! go co1) $! go co2-    go (CoVarCo cv)          = substCoVar subst cv-    go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos-    go (UnivCo p r t1 t2)    = (((mkUnivCo $! go_prov p) $! r) $!-                                (go_ty t1)) $! (go_ty t2)-    go (SymCo co)            = mkSymCo $! (go co)-    go (TransCo co1 co2)     = (mkTransCo $! (go co1)) $! (go co2)-    go (NthCo r d co)        = mkNthCo r d $! (go co)-    go (LRCo lr co)          = mkLRCo lr $! (go co)-    go (InstCo co arg)       = (mkInstCo $! (go co)) $! go arg-    go (KindCo co)           = mkKindCo $! (go co)-    go (SubCo co)            = mkSubCo $! (go co)-    go (AxiomRuleCo c cs)    = let cs1 = map go cs-                                in cs1 `seqList` AxiomRuleCo c cs1-    go (HoleCo h)            = HoleCo $! go_hole h--    go_prov (PhantomProv kco)    = PhantomProv (go kco)-    go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco)-    go_prov p@(PluginProv _)     = p--    -- See Note [Substituting in a coercion hole]-    go_hole h@(CoercionHole { ch_co_var = cv })-      = h { ch_co_var = updateVarType go_ty cv }--substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion-                  -> (TCvSubst, TyCoVar, Coercion)-substForAllCoBndr subst-  = substForAllCoBndrUsing False (substCo subst) subst---- | Like 'substForAllCoBndr', but disables sanity checks.--- The problems that the sanity checks in substCo catch are described in--- Note [The substitution invariant].--- The goal of #11371 is to migrate all the calls of substCoUnchecked to--- substCo and remove this function. Please don't use in new code.-substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion-                           -> (TCvSubst, TyCoVar, Coercion)-substForAllCoBndrUnchecked subst-  = substForAllCoBndrUsing False (substCoUnchecked subst) subst---- See Note [Sym and ForAllCo]-substForAllCoBndrUsing :: Bool  -- apply sym to binder?-                       -> (Coercion -> Coercion)  -- transformation to kind co-                       -> TCvSubst -> TyCoVar -> KindCoercion-                       -> (TCvSubst, TyCoVar, KindCoercion)-substForAllCoBndrUsing sym sco subst old_var-  | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var-  | otherwise       = substForAllCoCoVarBndrUsing sym sco subst old_var--substForAllCoTyVarBndrUsing :: Bool  -- apply sym to binder?-                            -> (Coercion -> Coercion)  -- transformation to kind co-                            -> TCvSubst -> TyVar -> KindCoercion-                            -> (TCvSubst, TyVar, KindCoercion)-substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co-  = ASSERT( isTyVar old_var )-    ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv-    , new_var, new_kind_co )-  where-    new_env | no_change && not sym = delVarEnv tenv old_var-            | sym       = extendVarEnv tenv old_var $-                          TyVarTy new_var `CastTy` new_kind_co-            | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)--    no_kind_change = noFreeVarsOfCo old_kind_co-    no_change = no_kind_change && (new_var == old_var)--    new_kind_co | no_kind_change = old_kind_co-                | otherwise      = sco old_kind_co--    new_ki1 = coercionLKind new_kind_co-    -- We could do substitution to (tyVarKind old_var). We don't do so because-    -- we already substituted new_kind_co, which contains the kind information-    -- we want. We don't want to do substitution once more. Also, in most cases,-    -- new_kind_co is a Refl, in which case coercionKind is really fast.--    new_var  = uniqAway in_scope (setTyVarKind old_var new_ki1)--substForAllCoCoVarBndrUsing :: Bool  -- apply sym to binder?-                            -> (Coercion -> Coercion)  -- transformation to kind co-                            -> TCvSubst -> CoVar -> KindCoercion-                            -> (TCvSubst, CoVar, KindCoercion)-substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv)-                            old_var old_kind_co-  = ASSERT( isCoVar old_var )-    ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv-    , new_var, new_kind_co )-  where-    new_cenv | no_change && not sym = delVarEnv cenv old_var-             | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var)--    no_kind_change = noFreeVarsOfCo old_kind_co-    no_change = no_kind_change && (new_var == old_var)--    new_kind_co | no_kind_change = old_kind_co-                | otherwise      = sco old_kind_co--    Pair h1 h2 = coercionKind new_kind_co--    new_var       = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type-    new_var_type  | sym       = h2-                  | otherwise = h1--substCoVar :: TCvSubst -> CoVar -> Coercion-substCoVar (TCvSubst _ _ cenv) cv-  = case lookupVarEnv cenv cv of-      Just co -> co-      Nothing -> CoVarCo cv--substCoVars :: TCvSubst -> [CoVar] -> [Coercion]-substCoVars subst cvs = map (substCoVar subst) cvs--lookupCoVar :: TCvSubst -> Var -> Maybe Coercion-lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v--substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar)-substTyVarBndr = substTyVarBndrUsing substTy--substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])-substTyVarBndrs = mapAccumL substTyVarBndr--substVarBndr :: HasCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar)-substVarBndr = substVarBndrUsing substTy--substVarBndrs :: HasCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar])-substVarBndrs = mapAccumL substVarBndr--substCoVarBndr :: HasCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar)-substCoVarBndr = substCoVarBndrUsing substTy---- | Like 'substVarBndr', but disables sanity checks.--- The problems that the sanity checks in substTy catch are described in--- Note [The substitution invariant].--- The goal of #11371 is to migrate all the calls of substTyUnchecked to--- substTy and remove this function. Please don't use in new code.-substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar)-substVarBndrUnchecked = substVarBndrUsing substTyUnchecked--substVarBndrUsing :: (TCvSubst -> Type -> Type)-                  -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar)-substVarBndrUsing subst_fn subst v-  | isTyVar v = substTyVarBndrUsing subst_fn subst v-  | otherwise = substCoVarBndrUsing subst_fn subst v---- | Substitute a tyvar in a binding position, returning an--- extended subst and a new tyvar.--- Use the supplied function to substitute in the kind-substTyVarBndrUsing-  :: (TCvSubst -> Type -> Type)  -- ^ Use this to substitute in the kind-  -> TCvSubst -> TyVar -> (TCvSubst, TyVar)-substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var-  = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst )-    ASSERT( isTyVar old_var )-    (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var)-  where-    new_env | no_change = delVarEnv tenv old_var-            | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)--    _no_capture = not (new_var `elemVarSet` shallowTyCoVarsOfTyVarEnv tenv)-    -- Assertion check that we are not capturing something in the substitution--    old_ki = tyVarKind old_var-    no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed-    no_change = no_kind_change && (new_var == old_var)-        -- no_change means that the new_var is identical in-        -- all respects to the old_var (same unique, same kind)-        -- See Note [Extending the TCvSubst]-        ---        -- In that case we don't need to extend the substitution-        -- to map old to new.  But instead we must zap any-        -- current substitution for the variable. For example:-        --      (\x.e) with id_subst = [x |-> e']-        -- Here we must simply zap the substitution for x--    new_var | no_kind_change = uniqAway in_scope old_var-            | otherwise = uniqAway in_scope $-                          setTyVarKind old_var (subst_fn subst old_ki)-        -- The uniqAway part makes sure the new variable is not already in scope---- | Substitute a covar in a binding position, returning an--- extended subst and a new covar.--- Use the supplied function to substitute in the kind-substCoVarBndrUsing-  :: (TCvSubst -> Type -> Type)-  -> TCvSubst -> CoVar -> (TCvSubst, CoVar)-substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var-  = ASSERT( isCoVar old_var )-    (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var)-  where-    new_co         = mkCoVarCo new_var-    no_kind_change = noFreeVarsOfTypes [t1, t2]-    no_change      = new_var == old_var && no_kind_change--    new_cenv | no_change = delVarEnv cenv old_var-             | otherwise = extendVarEnv cenv old_var new_co--    new_var = uniqAway in_scope subst_old_var-    subst_old_var = mkCoVar (varName old_var) new_var_type--    (_, _, t1, t2, role) = coVarKindsTypesRole old_var-    t1' = subst_fn subst t1-    t2' = subst_fn subst t2-    new_var_type = mkCoercionType role t1' t2'-                  -- It's important to do the substitution for coercions,-                  -- because they can have free type variables--cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar)-cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq-  = ASSERT2( isTyVar tv, ppr tv )   -- I think it's only called on TyVars-    (TCvSubst (extendInScopeSet in_scope tv')-              (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv')-  where-    old_ki = tyVarKind tv-    no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed--    tv1 | no_kind_change = tv-        | otherwise      = setTyVarKind tv (substTy subst old_ki)--    tv' = setVarUnique tv1 uniq--cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar])-cloneTyVarBndrs subst []     _usupply = (subst, [])-cloneTyVarBndrs subst (t:ts)  usupply = (subst'', tv:tvs)-  where-    (uniq, usupply') = takeUniqFromSupply usupply-    (subst' , tv )   = cloneTyVarBndr subst t uniq-    (subst'', tvs)   = cloneTyVarBndrs subst' ts usupply'
− compiler/types/TyCoTidy.hs 
@@ -1,235 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}---- | Tidying types and coercions for printing in error messages.-module TyCoTidy-  (-        -- * Tidying type related things up for printing-        tidyType,      tidyTypes,-        tidyOpenType,  tidyOpenTypes,-        tidyOpenKind,-        tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes,-        tidyOpenTyCoVar, tidyOpenTyCoVars,-        tidyTyCoVarOcc,-        tidyTopType,-        tidyKind,-        tidyCo, tidyCos,-        tidyTyCoVarBinder, tidyTyCoVarBinders-  ) where--import GhcPrelude--import TyCoRep-import TyCoFVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList)--import Name hiding (varName)-import Var-import VarEnv-import Util (seqList)--import Data.List (mapAccumL)--{--%************************************************************************-%*                                                                      *-\subsection{TidyType}-%*                                                                      *-%************************************************************************--}---- | This tidies up a type for printing in an error message, or in--- an interface file.------ It doesn't change the uniques at all, just the print names.-tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])-tidyVarBndrs tidy_env tvs-  = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs--tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)-tidyVarBndr tidy_env@(occ_env, subst) var-  = case tidyOccName occ_env (getHelpfulOccName var) of-      (occ_env', occ') -> ((occ_env', subst'), var')-        where-          subst' = extendVarEnv subst var var'-          var'   = setVarType (setVarName var name') type'-          type'  = tidyType tidy_env (varType var)-          name'  = tidyNameOcc name occ'-          name   = varName var--avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv--- Seed the occ_env with clashes among the names, see--- Note [Tidying multiple names at once] in OccName-avoidNameClashes tvs (occ_env, subst)-  = (avoidClashesOccEnv occ_env occs, subst)-  where-    occs = map getHelpfulOccName tvs--getHelpfulOccName :: TyCoVar -> OccName--- A TcTyVar with a System Name is probably a--- unification variable; when we tidy them we give them a trailing--- "0" (or 1 etc) so that they don't take precedence for the--- un-modified name. Plus, indicating a unification variable in--- this way is a helpful clue for users-getHelpfulOccName tv-  | isSystemName name, isTcTyVar tv-  = mkTyVarOcc (occNameString occ ++ "0")-  | otherwise-  = occ-  where-   name = varName tv-   occ  = getOccName name--tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis-                  -> (TidyEnv, VarBndr TyCoVar vis)-tidyTyCoVarBinder tidy_env (Bndr tv vis)-  = (tidy_env', Bndr tv' vis)-  where-    (tidy_env', tv') = tidyVarBndr tidy_env tv--tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis]-                   -> (TidyEnv, [VarBndr TyCoVar vis])-tidyTyCoVarBinders tidy_env tvbs-  = mapAccumL tidyTyCoVarBinder-              (avoidNameClashes (binderVars tvbs) tidy_env) tvbs------------------tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv--- ^ Add the free 'TyVar's to the env in tidy form,--- so that we can tidy the type they are free in-tidyFreeTyCoVars tidy_env tyvars-  = fst (tidyOpenTyCoVars tidy_env tyvars)------------------tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])-tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars------------------tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)--- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name--- using the environment if one has not already been allocated. See--- also 'tidyVarBndr'-tidyOpenTyCoVar env@(_, subst) tyvar-  = case lookupVarEnv subst tyvar of-        Just tyvar' -> (env, tyvar')              -- Already substituted-        Nothing     ->-          let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar))-          in tidyVarBndr env' tyvar  -- Treat it as a binder------------------tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar-tidyTyCoVarOcc env@(_, subst) tv-  = case lookupVarEnv subst tv of-        Nothing  -> updateVarType (tidyType env) tv-        Just tv' -> tv'------------------tidyTypes :: TidyEnv -> [Type] -> [Type]-tidyTypes env tys = map (tidyType env) tys------------------tidyType :: TidyEnv -> Type -> Type-tidyType _   (LitTy n)             = LitTy n-tidyType env (TyVarTy tv)          = TyVarTy (tidyTyCoVarOcc env tv)-tidyType env (TyConApp tycon tys)  = let args = tidyTypes env tys-                                     in args `seqList` TyConApp tycon args-tidyType env (AppTy fun arg)       = (AppTy $! (tidyType env fun)) $! (tidyType env arg)-tidyType env ty@(FunTy _ arg res)  = let { !arg' = tidyType env arg-                                         ; !res' = tidyType env res }-                                     in ty { ft_arg = arg', ft_res = res' }-tidyType env (ty@(ForAllTy{}))     = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty-  where-    (tvs, vis, body_ty) = splitForAllTys' ty-    (env', tvs') = tidyVarBndrs env tvs-tidyType env (CastTy ty co)       = (CastTy $! tidyType env ty) $! (tidyCo env co)-tidyType env (CoercionTy co)      = CoercionTy $! (tidyCo env co)----- The following two functions differ from mkForAllTys and splitForAllTys in that--- they expect/preserve the ArgFlag argument. These belong to types/Type.hs, but--- how should they be named?-mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type-mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs-  where-    strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty--splitForAllTys' :: Type -> ([TyCoVar], [ArgFlag], Type)-splitForAllTys' ty = go ty [] []-  where-    go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss)-    go ty                          tvs viss = (reverse tvs, reverse viss, ty)--------------------- | Grabs the free type variables, tidies them--- and then uses 'tidyType' to work over the type itself-tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])-tidyOpenTypes env tys-  = (env', tidyTypes (trimmed_occ_env, var_env) tys)-  where-    (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $-                                tyCoVarsOfTypesWellScoped tys-    trimmed_occ_env = initTidyOccEnv (map getOccName tvs')-      -- The idea here was that we restrict the new TidyEnv to the-      -- _free_ vars of the types, so that we don't gratuitously rename-      -- the _bound_ variables of the types.------------------tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)-tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in-                      (env', ty')-------------------- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment)-tidyTopType :: Type -> Type-tidyTopType ty = tidyType emptyTidyEnv ty------------------tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind)-tidyOpenKind = tidyOpenType--tidyKind :: TidyEnv -> Kind -> Kind-tidyKind = tidyType-------------------tidyCo :: TidyEnv -> Coercion -> Coercion-tidyCo env@(_, subst) co-  = go co-  where-    go_mco MRefl    = MRefl-    go_mco (MCo co) = MCo (go co)--    go (Refl ty)             = Refl (tidyType env ty)-    go (GRefl r ty mco)      = GRefl r (tidyType env ty) $! go_mco mco-    go (TyConAppCo r tc cos) = let args = map go cos-                               in args `seqList` TyConAppCo r tc args-    go (AppCo co1 co2)       = (AppCo $! go co1) $! go co2-    go (ForAllCo tv h co)    = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co)-                               where (envp, tvp) = tidyVarBndr env tv-            -- the case above duplicates a bit of work in tidying h and the kind-            -- of tv. But the alternative is to use coercionKind, which seems worse.-    go (FunCo r co1 co2)     = (FunCo r $! go co1) $! go co2-    go (CoVarCo cv)          = case lookupVarEnv subst cv of-                                 Nothing  -> CoVarCo cv-                                 Just cv' -> CoVarCo cv'-    go (HoleCo h)            = HoleCo h-    go (AxiomInstCo con ind cos) = let args = map go cos-                               in  args `seqList` AxiomInstCo con ind args-    go (UnivCo p r t1 t2)    = (((UnivCo $! (go_prov p)) $! r) $!-                                tidyType env t1) $! tidyType env t2-    go (SymCo co)            = SymCo $! go co-    go (TransCo co1 co2)     = (TransCo $! go co1) $! go co2-    go (NthCo r d co)        = NthCo r d $! go co-    go (LRCo lr co)          = LRCo lr $! go co-    go (InstCo co ty)        = (InstCo $! go co) $! go ty-    go (KindCo co)           = KindCo $! go co-    go (SubCo co)            = SubCo $! go co-    go (AxiomRuleCo ax cos)  = let cos1 = tidyCos env cos-                               in cos1 `seqList` AxiomRuleCo ax cos1--    go_prov (PhantomProv co)    = PhantomProv (go co)-    go_prov (ProofIrrelProv co) = ProofIrrelProv (go co)-    go_prov p@(PluginProv _)    = p--tidyCos :: TidyEnv -> [Coercion] -> [Coercion]-tidyCos env = map (tidyCo env)
− compiler/types/TyCon.hs 
@@ -1,2807 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---The @TyCon@ datatype--}--{-# LANGUAGE CPP, FlexibleInstances #-}--module TyCon(-        -- * Main TyCon data types-        TyCon,-        AlgTyConRhs(..), visibleDataCons,-        AlgTyConFlav(..), isNoParent,-        FamTyConFlav(..), Role(..), Injectivity(..),-        RuntimeRepInfo(..), TyConFlavour(..),--        -- * TyConBinder-        TyConBinder, TyConBndrVis(..), TyConTyCoBinder,-        mkNamedTyConBinder, mkNamedTyConBinders,-        mkRequiredTyConBinder,-        mkAnonTyConBinder, mkAnonTyConBinders,-        tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder,-        isVisibleTyConBinder, isInvisibleTyConBinder,--        -- ** Field labels-        tyConFieldLabels, lookupTyConFieldLabel,--        -- ** Constructing TyCons-        mkAlgTyCon,-        mkClassTyCon,-        mkFunTyCon,-        mkPrimTyCon,-        mkKindTyCon,-        mkLiftedPrimTyCon,-        mkTupleTyCon,-        mkSumTyCon,-        mkDataTyConRhs,-        mkSynonymTyCon,-        mkFamilyTyCon,-        mkPromotedDataCon,-        mkTcTyCon,-        noTcTyConScopedTyVars,--        -- ** Predicates on TyCons-        isAlgTyCon, isVanillaAlgTyCon,-        isClassTyCon, isFamInstTyCon,-        isFunTyCon,-        isPrimTyCon,-        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,-        isUnboxedSumTyCon, isPromotedTupleTyCon,-        isTypeSynonymTyCon,-        mustBeSaturated,-        isPromotedDataCon, isPromotedDataCon_maybe,-        isKindTyCon, isLiftedTypeKindTyConName,-        isTauTyCon, isFamFreeTyCon,--        isDataTyCon, isProductTyCon, isDataProductTyCon_maybe,-        isDataSumTyCon_maybe,-        isEnumerationTyCon,-        isNewTyCon, isAbstractTyCon,-        isFamilyTyCon, isOpenFamilyTyCon,-        isTypeFamilyTyCon, isDataFamilyTyCon,-        isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe,-        tyConInjectivityInfo,-        isBuiltInSynFamTyCon_maybe,-        isUnliftedTyCon,-        isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs,-        isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe,-        isImplicitTyCon,-        isTyConWithSrcDataCons,-        isTcTyCon, setTcTyConKind,-        isTcLevPoly,--        -- ** Extracting information out of TyCons-        tyConName,-        tyConSkolem,-        tyConKind,-        tyConUnique,-        tyConTyVars, tyConVisibleTyVars,-        tyConCType, tyConCType_maybe,-        tyConDataCons, tyConDataCons_maybe,-        tyConSingleDataCon_maybe, tyConSingleDataCon,-        tyConSingleAlgDataCon_maybe,-        tyConFamilySize,-        tyConStupidTheta,-        tyConArity,-        tyConRoles,-        tyConFlavour,-        tyConTuple_maybe, tyConClass_maybe, tyConATs,-        tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe,-        tyConFamilyResVar_maybe,-        synTyConDefn_maybe, synTyConRhs_maybe,-        famTyConFlav_maybe, famTcResVar,-        algTyConRhs,-        newTyConRhs, newTyConEtadArity, newTyConEtadRhs,-        unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe,-        newTyConDataCon_maybe,-        algTcFields,-        tyConRuntimeRepInfo,-        tyConBinders, tyConResKind, tyConTyVarBinders,-        tcTyConScopedTyVars, tcTyConIsPoly,-        mkTyConTagMap,--        -- ** Manipulating TyCons-        expandSynTyCon_maybe,-        newTyConCo, newTyConCo_maybe,-        pprPromotionQuote, mkTyConKind,--        -- ** Predicated on TyConFlavours-        tcFlavourIsOpen,--        -- * Runtime type representation-        TyConRepName, tyConRepName_maybe,-        mkPrelTyConRepName,-        tyConRepModOcc,--        -- * Primitive representations of Types-        PrimRep(..), PrimElemRep(..),-        isVoidRep, isGcPtrRep,-        primRepSizeB,-        primElemRepSizeB,-        primRepIsFloat,-        primRepsCompatible,-        primRepCompatible,--        -- * Recursion breaking-        RecTcChecker, initRecTc, defaultRecTcMaxBound,-        setRecTcMaxBound, checkRecTc--) where--#include "HsVersions.h"--import GhcPrelude--import {-# SOURCE #-} TyCoRep    ( Kind, Type, PredType, mkForAllTy, mkFunTy )-import {-# SOURCE #-} TyCoPpr    ( pprType )-import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind-                                 , vecCountTyCon, vecElemTyCon, liftedTypeKind )-import {-# SOURCE #-} DataCon    ( DataCon, dataConExTyCoVars, dataConFieldLabels-                                 , dataConTyCon, dataConFullSig-                                 , isUnboxedSumCon )--import Binary-import Var-import VarSet-import Class-import BasicTypes-import GHC.Driver.Session-import ForeignCall-import Name-import NameEnv-import CoAxiom-import PrelNames-import Maybes-import Outputable-import FastStringEnv-import FieldLabel-import Constants-import Util-import Unique( tyConRepNameUnique, dataConTyRepNameUnique )-import UniqSet-import Module--import qualified Data.Data as Data--{--------------------------------------------------        Notes about type families--------------------------------------------------Note [Type synonym families]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* Type synonym families, also known as "type functions", map directly-  onto the type functions in FC:--        type family F a :: *-        type instance F Int = Bool-        ..etc...--* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon--* From the user's point of view (F Int) and Bool are simply-  equivalent types.--* A Haskell 98 type synonym is a degenerate form of a type synonym-  family.--* Type functions can't appear in the LHS of a type function:-        type instance F (F Int) = ...   -- BAD!--* Translation of type family decl:-        type family F a :: *-  translates to-    a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon--        type family G a :: * where-          G Int = Bool-          G Bool = Char-          G a = ()-  translates to-    a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the-    appropriate CoAxiom representing the equations--We also support injective type families -- see Note [Injective type families]--Note [Data type families]-~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [Wrappers for data instance tycons] in MkId.hs--* Data type families are declared thus-        data family T a :: *-        data instance T Int = T1 | T2 Bool--  Here T is the "family TyCon".--* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon--* The user does not see any "equivalent types" as he did with type-  synonym families.  He just sees constructors with types-        T1 :: T Int-        T2 :: Bool -> T Int--* Here's the FC version of the above declarations:--        data T a-        data R:TInt = T1 | T2 Bool-        axiom ax_ti : T Int ~R R:TInt--  Note that this is a *representational* coercion-  The R:TInt is the "representation TyCons".-  It has an AlgTyConFlav of-        DataFamInstTyCon T [Int] ax_ti--* The axiom ax_ti may be eta-reduced; see-  Note [Eta reduction for data families] in FamInstEnv--* Data family instances may have a different arity than the data family.-  See Note [Arity of data families] in FamInstEnv--* The data constructor T2 has a wrapper (which is what the-  source-level "T2" invokes):--        $WT2 :: Bool -> T Int-        $WT2 b = T2 b `cast` sym ax_ti--* A data instance can declare a fully-fledged GADT:--        data instance T (a,b) where-          X1 :: T (Int,Bool)-          X2 :: a -> b -> T (a,b)--  Here's the FC version of the above declaration:--        data R:TPair a b where-          X1 :: R:TPair Int Bool-          X2 :: a -> b -> R:TPair a b-        axiom ax_pr :: T (a,b)  ~R  R:TPair a b--        $WX1 :: forall a b. a -> b -> T (a,b)-        $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b)--  The R:TPair are the "representation TyCons".-  We have a bit of work to do, to unpick the result types of the-  data instance declaration for T (a,b), to get the result type in the-  representation; e.g.  T (a,b) --> R:TPair a b--  The representation TyCon R:TList, has an AlgTyConFlav of--        DataFamInstTyCon T [(a,b)] ax_pr--* Notice that T is NOT translated to a FC type function; it just-  becomes a "data type" with no constructors, which can be coerced-  into R:TInt, R:TPair by the axioms.  These axioms-  axioms come into play when (and *only* when) you-        - use a data constructor-        - do pattern matching-  Rather like newtype, in fact--  As a result--  - T behaves just like a data type so far as decomposition is concerned--  - (T Int) is not implicitly converted to R:TInt during type inference.-    Indeed the latter type is unknown to the programmer.--  - There *is* an instance for (T Int) in the type-family instance-    environment, but it is only used for overlap checking--  - It's fine to have T in the LHS of a type function:-    type instance F (T a) = [a]--  It was this last point that confused me!  The big thing is that you-  should not think of a data family T as a *type function* at all, not-  even an injective one!  We can't allow even injective type functions-  on the LHS of a type function:-        type family injective G a :: *-        type instance F (G Int) = Bool-  is no good, even if G is injective, because consider-        type instance G Int = Bool-        type instance F Bool = Char--  So a data type family is not an injective type function. It's just a-  data type with some axioms that connect it to other data types.--* The tyConTyVars of the representation tycon are the tyvars that the-  user wrote in the patterns. This is important in TcDeriv, where we-  bring these tyvars into scope before type-checking the deriving-  clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl.--Note [Associated families and their parent class]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-*Associated* families are just like *non-associated* families, except-that they have a famTcParent field of (Just cls_tc), which identifies the-parent class.--However there is an important sharing relationship between-  * the tyConTyVars of the parent Class-  * the tyConTyVars of the associated TyCon--   class C a b where-     data T p a-     type F a q b--Here the 'a' and 'b' are shared with the 'Class'; that is, they have-the same Unique.--This is important. In an instance declaration we expect-  * all the shared variables to be instantiated the same way-  * the non-shared variables of the associated type should not-    be instantiated at all--  instance C [x] (Tree y) where-     data T p [x] = T1 x | T2 p-     type F [x] q (Tree y) = (x,y,q)--Note [TyCon Role signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Every tycon has a role signature, assigning a role to each of the tyConTyVars-(or of equal length to the tyConArity, if there are no tyConTyVars). An-example demonstrates these best: say we have a tycon T, with parameters a at-nominal, b at representational, and c at phantom. Then, to prove-representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have-nominal equality between a1 and a2, representational equality between b1 and-b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This-might happen, say, with the following declaration:--  data T a b c where-    MkT :: b -> T Int b c--Data and class tycons have their roles inferred (see inferRoles in TcTyDecls),-as do vanilla synonym tycons. Family tycons have all parameters at role N,-though it is conceivable that we could relax this restriction. (->)'s and-tuples' parameters are at role R. Each primitive tycon declares its roles;-it's worth noting that (~#)'s parameters are at role N. Promoted data-constructors' type arguments are at role R. All kind arguments are at role-N.--Note [Unboxed tuple RuntimeRep vars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The contents of an unboxed tuple may have any representation. Accordingly,-the kind of the unboxed tuple constructor is runtime-representation-polymorphic.--Type constructor (2 kind arguments)-   (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep).-                   TYPE q -> TYPE r -> TYPE (TupleRep [q, r])-Data constructor (4 type arguments)-   (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep)-                   (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #)--These extra tyvars (q and r) cause some delicate processing around tuples,-where we need to manually insert RuntimeRep arguments.-The same situation happens with unboxed sums: each alternative-has its own RuntimeRep.-For boxed tuples, there is no levity polymorphism, and therefore-we add RuntimeReps only for the unboxed version.--Type constructor (no kind arguments)-   (,) :: Type -> Type -> Type-Data constructor (2 type arguments)-   (,) :: forall a b. a -> b -> (a, b)---Note [Injective type families]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We allow injectivity annotations for type families (both open and closed):--  type family F (a :: k) (b :: k) = r | r -> a-  type family G a b = res | res -> a b where ...--Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`.-`famTcInj` maybe stores a list of Bools, where each entry corresponds to a-single element of `tyConTyVars` (both lists should have identical length). If no-injectivity annotation was provided `famTcInj` is Nothing. From this follows an-invariant that if `famTcInj` is a Just then at least one element in the list-must be True.--See also:- * [Injectivity annotation] in GHC.Hs.Decls- * [Renaming injectivity annotation] in GHC.Rename.Source- * [Verifying injectivity annotation] in FamInstEnv- * [Type inference for type families with injectivity] in TcInteract--************************************************************************-*                                                                      *-                    TyConBinder, TyConTyCoBinder-*                                                                      *-************************************************************************--}--type TyConBinder = VarBndr TyVar TyConBndrVis---- In the whole definition of @data TyCon@, only @PromotedDataCon@ will really--- contain CoVar.-type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis--data TyConBndrVis-  = NamedTCB ArgFlag-  | AnonTCB  AnonArgFlag--instance Outputable TyConBndrVis where-  ppr (NamedTCB flag) = text "NamedTCB" <> ppr flag-  ppr (AnonTCB af)    = text "AnonTCB"  <> ppr af--mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder-mkAnonTyConBinder af tv = ASSERT( isTyVar tv)-                          Bndr tv (AnonTCB af)--mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder]-mkAnonTyConBinders af tvs = map (mkAnonTyConBinder af) tvs--mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder--- The odd argument order supports currying-mkNamedTyConBinder vis tv = ASSERT( isTyVar tv )-                            Bndr tv (NamedTCB vis)--mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder]--- The odd argument order supports currying-mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs---- | Make a Required TyConBinder. It chooses between NamedTCB and--- AnonTCB based on whether the tv is mentioned in the dependent set-mkRequiredTyConBinder :: TyCoVarSet  -- these are used dependently-                      -> TyVar-                      -> TyConBinder-mkRequiredTyConBinder dep_set tv-  | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv-  | otherwise               = mkAnonTyConBinder  VisArg   tv--tyConBinderArgFlag :: TyConBinder -> ArgFlag-tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis--tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag-tyConBndrVisArgFlag (NamedTCB vis)     = vis-tyConBndrVisArgFlag (AnonTCB VisArg)   = Required-tyConBndrVisArgFlag (AnonTCB InvisArg) = Inferred    -- See Note [AnonTCB InvisArg]--isNamedTyConBinder :: TyConBinder -> Bool--- Identifies kind variables--- E.g. data T k (a:k) = blah--- Here 'k' is a NamedTCB, a variable used in the kind of other binders-isNamedTyConBinder (Bndr _ (NamedTCB {})) = True-isNamedTyConBinder _                      = False--isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool--- Works for IfaceTyConBinder too-isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis--isVisibleTcbVis :: TyConBndrVis -> Bool-isVisibleTcbVis (NamedTCB vis)     = isVisibleArgFlag vis-isVisibleTcbVis (AnonTCB VisArg)   = True-isVisibleTcbVis (AnonTCB InvisArg) = False--isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool--- Works for IfaceTyConBinder too-isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb)---- Build the 'tyConKind' from the binders and the result kind.--- Keep in sync with 'mkTyConKind' in GHC.Iface.Type.-mkTyConKind :: [TyConBinder] -> Kind -> Kind-mkTyConKind bndrs res_kind = foldr mk res_kind bndrs-  where-    mk :: TyConBinder -> Kind -> Kind-    mk (Bndr tv (AnonTCB af))   k = mkFunTy af (varType tv) k-    mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k--tyConTyVarBinders :: [TyConBinder]   -- From the TyCon-                  -> [TyVarBinder]   -- Suitable for the foralls of a term function--- See Note [Building TyVarBinders from TyConBinders]-tyConTyVarBinders tc_bndrs- = map mk_binder tc_bndrs- where-   mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv-      where-        vis = case tc_vis of-                AnonTCB VisArg    -> Specified-                AnonTCB InvisArg  -> Inferred   -- See Note [AnonTCB InvisArg]-                NamedTCB Required -> Specified-                NamedTCB vis      -> vis---- Returns only tyvars, as covars are always inferred-tyConVisibleTyVars :: TyCon -> [TyVar]-tyConVisibleTyVars tc-  = [ tv | Bndr tv vis <- tyConBinders tc-         , isVisibleTcbVis vis ]--{- Note [AnonTCB InvisArg]-~~~~~~~~~~~~~~~~~~~~~~~~~~-It's pretty rare to have an (AnonTCB InvisArg) binder.  The-only way it can occur is through equality constraints in kinds. These-can arise in one of two ways:--* In a PromotedDataCon whose kind has an equality constraint:--    'MkT :: forall a b. (a~b) => blah--  See Note [Constraints in kinds] in TyCoRep, and-  Note [Promoted data constructors] in this module.-* In a data type whose kind has an equality constraint, as in the-  following example from #12102:--    data T :: forall a. (IsTypeLit a ~ 'True) => a -> Type--When mapping an (AnonTCB InvisArg) to an ArgFlag, in-tyConBndrVisArgFlag, we use "Inferred" to mean "the user cannot-specify this arguments, even with visible type/kind application;-instead the type checker must fill it in.--We map (AnonTCB VisArg) to Required, of course: the user must-provide it. It would be utterly wrong to do this for constraint-arguments, which is why AnonTCB must have the AnonArgFlag in-the first place.--Note [Building TyVarBinders from TyConBinders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We sometimes need to build the quantified type of a value from-the TyConBinders of a type or class.  For that we need not-TyConBinders but TyVarBinders (used in forall-type)  E.g:-- *  From   data T a = MkT (Maybe a)-    we are going to make a data constructor with type-           MkT :: forall a. Maybe a -> T a-    See the TyCoVarBinders passed to buildDataCon-- * From    class C a where { op :: a -> Maybe a }-   we are going to make a default method-           $dmop :: forall a. C a => a -> Maybe a-   See the TyCoVarBinders passed to mkSigmaTy in mkDefaultMethodType--Both of these are user-callable.  (NB: default methods are not callable-directly by the user but rather via the code generated by 'deriving',-which uses visible type application; see mkDefMethBind.)--Since they are user-callable we must get their type-argument visibility-information right; and that info is in the TyConBinders.-Here is an example:--  data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> *--The TyCon has--  tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ]--The TyConBinders for App line up with App's kind, given above.--But the DataCon MkApp has the type-  MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b--That is, its TyCoVarBinders should be--  dataConUnivTyVarBinders = [ Bndr (k:*)    Inferred-                            , Bndr (a:k->*) Specified-                            , Bndr (b:k)    Specified ]--So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders:-  - variable names from the TyConBinders-  - but changing Anon/Required to Specified--The last part about Required->Specified comes from this:-  data T k (a:k) b = MkT (a b)-Here k is Required in T's kind, but we don't have Required binders in-the TyCoBinders for a term (see Note [No Required TyCoBinder in terms]-in TyCoRep), so we change it to Specified when making MkT's TyCoBinders--}---{- Note [The binders/kind/arity fields of a TyCon]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-All TyCons have this group of fields-  tyConBinders   :: [TyConBinder/TyConTyCoBinder]-  tyConResKind   :: Kind-  tyConTyVars    :: [TyVar]   -- Cached = binderVars tyConBinders-                              --   NB: Currently (Aug 2018), TyCons that own this-                              --   field really only contain TyVars. So it is-                              --   [TyVar] instead of [TyCoVar].-  tyConKind      :: Kind      -- Cached = mkTyConKind tyConBinders tyConResKind-  tyConArity     :: Arity     -- Cached = length tyConBinders--They fit together like so:--* tyConBinders gives the telescope of type/coercion variables on the LHS of the-  type declaration.  For example:--    type App a (b :: k) = a b--  tyConBinders = [ Bndr (k::*)   (NamedTCB Inferred)-                 , Bndr (a:k->*) AnonTCB-                 , Bndr (b:k)    AnonTCB ]--  Note that that are three binders here, including the-  kind variable k.--* See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep-  for what the visibility flag means.--* Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and-  that TyVar may scope over some other part of the TyCon's definition. Eg-      type T a = a -> a-  we have-      tyConBinders = [ Bndr (a:*) AnonTCB ]-      synTcRhs     = a -> a-  So the 'a' scopes over the synTcRhs--* From the tyConBinders and tyConResKind we can get the tyConKind-  E.g for our App example:-      App :: forall k. (k->*) -> k -> *--  We get a 'forall' in the kind for each NamedTCB, and an arrow-  for each AnonTCB--  tyConKind is the full kind of the TyCon, not just the result kind--* For type families, tyConArity is the arguments this TyCon must be-  applied to, to be considered saturated.  Here we mean "applied to in-  the actual Type", not surface syntax; i.e. including implicit kind-  variables.  So it's just (length tyConBinders)--* For an algebraic data type, or data instance, the tyConResKind is-  always (TYPE r); that is, the tyConBinders are enough to saturate-  the type constructor.  I'm not quite sure why we have this invariant,-  but it's enforced by etaExpandAlgTyCon--}--instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where-  ppr (Bndr v bi) = ppr_bi bi <+> parens (pprBndr LetBind v)-    where-      ppr_bi (AnonTCB VisArg)     = text "anon-vis"-      ppr_bi (AnonTCB InvisArg)   = text "anon-invis"-      ppr_bi (NamedTCB Required)  = text "req"-      ppr_bi (NamedTCB Specified) = text "spec"-      ppr_bi (NamedTCB Inferred)  = text "inf"--instance Binary TyConBndrVis where-  put_ bh (AnonTCB af)   = do { putByte bh 0; put_ bh af }-  put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis }--  get bh = do { h <- getByte bh-              ; case h of-                  0 -> do { af  <- get bh; return (AnonTCB af) }-                  _ -> do { vis <- get bh; return (NamedTCB vis) } }---{- *********************************************************************-*                                                                      *-               The TyCon type-*                                                                      *-************************************************************************--}----- | TyCons represent type constructors. Type constructors are introduced by--- things such as:------ 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of---    kind @*@------ 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor------ 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor---    of kind @* -> *@------ 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor---    of kind @*@------ This data type also encodes a number of primitive, built in type constructors--- such as those for function and tuple types.---- If you edit this type, you may need to update the GHC formalism--- See Note [GHC Formalism] in GHC.Core.Lint-data TyCon-  = -- | The function type constructor, @(->)@-    FunTyCon {-        tyConUnique :: Unique,   -- ^ A Unique of this TyCon. Invariant:-                                 -- identical to Unique of Name stored in-                                 -- tyConName field.--        tyConName   :: Name,     -- ^ Name of the constructor--        -- See Note [The binders/kind/arity fields of a TyCon]-        tyConBinders :: [TyConBinder], -- ^ Full binders-        tyConResKind :: Kind,             -- ^ Result kind-        tyConKind    :: Kind,             -- ^ Kind of this TyCon-        tyConArity   :: Arity,            -- ^ Arity--        tcRepName :: TyConRepName-    }--  -- | Algebraic data types, from-  --     - @data@ declarations-  --     - @newtype@ declarations-  --     - data instance declarations-  --     - type instance declarations-  --     - the TyCon generated by a class declaration-  --     - boxed tuples-  --     - unboxed tuples-  --     - constraint tuples-  -- All these constructors are lifted and boxed except unboxed tuples-  -- which should have an 'UnboxedAlgTyCon' parent.-  -- Data/newtype/type /families/ are handled by 'FamilyTyCon'.-  -- See 'AlgTyConRhs' for more information.-  | AlgTyCon {-        tyConUnique  :: Unique,  -- ^ A Unique of this TyCon. Invariant:-                                 -- identical to Unique of Name stored in-                                 -- tyConName field.--        tyConName    :: Name,    -- ^ Name of the constructor--        -- See Note [The binders/kind/arity fields of a TyCon]-        tyConBinders :: [TyConBinder], -- ^ Full binders-        tyConTyVars  :: [TyVar],          -- ^ TyVar binders-        tyConResKind :: Kind,             -- ^ Result kind-        tyConKind    :: Kind,             -- ^ Kind of this TyCon-        tyConArity   :: Arity,            -- ^ Arity--              -- The tyConTyVars scope over:-              ---              -- 1. The 'algTcStupidTheta'-              -- 2. The cached types in algTyConRhs.NewTyCon-              -- 3. The family instance types if present-              ---              -- Note that it does /not/ scope over the data-              -- constructors.--        tcRoles      :: [Role],  -- ^ The role for each type variable-                                 -- This list has length = tyConArity-                                 -- See also Note [TyCon Role signatures]--        tyConCType   :: Maybe CType,-- ^ The C type that should be used-                                    -- for this type when using the FFI-                                    -- and CAPI--        algTcGadtSyntax  :: Bool,   -- ^ Was the data type declared with GADT-                                    -- syntax?  If so, that doesn't mean it's a-                                    -- true GADT; only that the "where" form-                                    -- was used.  This field is used only to-                                    -- guide pretty-printing--        algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data-                                        -- type (always empty for GADTs).  A-                                        -- \"stupid theta\" is the context to-                                        -- the left of an algebraic type-                                        -- declaration, e.g. @Eq a@ in the-                                        -- declaration @data Eq a => T a ...@.--        algTcRhs    :: AlgTyConRhs, -- ^ Contains information about the-                                    -- data constructors of the algebraic type--        algTcFields :: FieldLabelEnv, -- ^ Maps a label to information-                                      -- about the field--        algTcParent :: AlgTyConFlav -- ^ Gives the class or family declaration-                                       -- 'TyCon' for derived 'TyCon's representing-                                       -- class or family instances, respectively.--    }--  -- | Represents type synonyms-  | SynonymTyCon {-        tyConUnique  :: Unique,  -- ^ A Unique of this TyCon. Invariant:-                                 -- identical to Unique of Name stored in-                                 -- tyConName field.--        tyConName    :: Name,    -- ^ Name of the constructor--        -- See Note [The binders/kind/arity fields of a TyCon]-        tyConBinders :: [TyConBinder], -- ^ Full binders-        tyConTyVars  :: [TyVar],          -- ^ TyVar binders-        tyConResKind :: Kind,             -- ^ Result kind-        tyConKind    :: Kind,             -- ^ Kind of this TyCon-        tyConArity   :: Arity,            -- ^ Arity-             -- tyConTyVars scope over: synTcRhs--        tcRoles      :: [Role],  -- ^ The role for each type variable-                                 -- This list has length = tyConArity-                                 -- See also Note [TyCon Role signatures]--        synTcRhs     :: Type,    -- ^ Contains information about the expansion-                                 -- of the synonym--        synIsTau     :: Bool,   -- True <=> the RHS of this synonym does not-                                 --          have any foralls, after expanding any-                                 --          nested synonyms-        synIsFamFree  :: Bool    -- True <=> the RHS of this synonym does not mention-                                 --          any type synonym families (data families-                                 --          are fine), again after expanding any-                                 --          nested synonyms-    }--  -- | Represents families (both type and data)-  -- Argument roles are all Nominal-  | FamilyTyCon {-        tyConUnique  :: Unique,  -- ^ A Unique of this TyCon. Invariant:-                                 -- identical to Unique of Name stored in-                                 -- tyConName field.--        tyConName    :: Name,    -- ^ Name of the constructor--        -- See Note [The binders/kind/arity fields of a TyCon]-        tyConBinders :: [TyConBinder], -- ^ Full binders-        tyConTyVars  :: [TyVar],          -- ^ TyVar binders-        tyConResKind :: Kind,             -- ^ Result kind-        tyConKind    :: Kind,             -- ^ Kind of this TyCon-        tyConArity   :: Arity,            -- ^ Arity-            -- tyConTyVars connect an associated family TyCon-            -- with its parent class; see TcValidity.checkConsistentFamInst--        famTcResVar  :: Maybe Name,   -- ^ Name of result type variable, used-                                      -- for pretty-printing with --show-iface-                                      -- and for reifying TyCon in Template-                                      -- Haskell--        famTcFlav    :: FamTyConFlav, -- ^ Type family flavour: open, closed,-                                      -- abstract, built-in. See comments for-                                      -- FamTyConFlav--        famTcParent  :: Maybe TyCon,  -- ^ For *associated* type/data families-                                      -- The class tycon in which the family is declared-                                      -- See Note [Associated families and their parent class]--        famTcInj     :: Injectivity   -- ^ is this a type family injective in-                                      -- its type variables? Nothing if no-                                      -- injectivity annotation was given-    }--  -- | Primitive types; cannot be defined in Haskell. This includes-  -- the usual suspects (such as @Int#@) as well as foreign-imported-  -- types and kinds (@*@, @#@, and @?@)-  | PrimTyCon {-        tyConUnique   :: Unique, -- ^ A Unique of this TyCon. Invariant:-                                 -- identical to Unique of Name stored in-                                 -- tyConName field.--        tyConName     :: Name,   -- ^ Name of the constructor--        -- See Note [The binders/kind/arity fields of a TyCon]-        tyConBinders :: [TyConBinder], -- ^ Full binders-        tyConResKind :: Kind,             -- ^ Result kind-        tyConKind    :: Kind,             -- ^ Kind of this TyCon-        tyConArity   :: Arity,            -- ^ Arity--        tcRoles       :: [Role], -- ^ The role for each type variable-                                 -- This list has length = tyConArity-                                 -- See also Note [TyCon Role signatures]--        isUnlifted   :: Bool,    -- ^ Most primitive tycons are unlifted (may-                                 -- not contain bottom) but other are lifted,-                                 -- e.g. @RealWorld@-                                 -- Only relevant if tyConKind = *--        primRepName :: Maybe TyConRepName   -- Only relevant for kind TyCons-                                            -- i.e, *, #, ?-    }--  -- | Represents promoted data constructor.-  | PromotedDataCon {          -- See Note [Promoted data constructors]-        tyConUnique  :: Unique,     -- ^ Same Unique as the data constructor-        tyConName    :: Name,       -- ^ Same Name as the data constructor--        -- See Note [The binders/kind/arity fields of a TyCon]-        tyConBinders :: [TyConTyCoBinder], -- ^ Full binders-        tyConResKind :: Kind,             -- ^ Result kind-        tyConKind    :: Kind,             -- ^ Kind of this TyCon-        tyConArity   :: Arity,            -- ^ Arity--        tcRoles       :: [Role],    -- ^ Roles: N for kind vars, R for type vars-        dataCon       :: DataCon,   -- ^ Corresponding data constructor-        tcRepName     :: TyConRepName,-        promDcRepInfo :: RuntimeRepInfo  -- ^ See comments with 'RuntimeRepInfo'-    }--  -- | These exist only during type-checking. See Note [How TcTyCons work]-  -- in TcTyClsDecls-  | TcTyCon {-        tyConUnique :: Unique,-        tyConName   :: Name,--        -- See Note [The binders/kind/arity fields of a TyCon]-        tyConBinders :: [TyConBinder], -- ^ Full binders-        tyConTyVars  :: [TyVar],       -- ^ TyVar binders-        tyConResKind :: Kind,          -- ^ Result kind-        tyConKind    :: Kind,          -- ^ Kind of this TyCon-        tyConArity   :: Arity,         -- ^ Arity--          -- NB: the TyConArity of a TcTyCon must match-          -- the number of Required (positional, user-specified)-          -- arguments to the type constructor; see the use-          -- of tyConArity in generaliseTcTyCon--        tcTyConScopedTyVars :: [(Name,TyVar)],-          -- ^ Scoped tyvars over the tycon's body-          -- See Note [Scoped tyvars in a TcTyCon]--        tcTyConIsPoly     :: Bool, -- ^ Is this TcTyCon already generalized?--        tcTyConFlavour :: TyConFlavour-                           -- ^ What sort of 'TyCon' this represents.-      }-{- Note [Scoped tyvars in a TcTyCon]--~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The tcTyConScopedTyVars field records the lexicial-binding connection-between the original, user-specified Name (i.e. thing in scope) and-the TcTyVar that the Name is bound to.--Order *does* matter; the tcTyConScopedTyvars list consists of-     specified_tvs ++ required_tvs--where-   * specified ones first-   * required_tvs the same as tyConTyVars-   * tyConArity = length required_tvs--See also Note [How TcTyCons work] in TcTyClsDecls--}---- | Represents right-hand-sides of 'TyCon's for algebraic types-data AlgTyConRhs--    -- | Says that we know nothing about this data type, except that-    -- it's represented by a pointer.  Used when we export a data type-    -- abstractly into an .hi file.-  = AbstractTyCon--    -- | Information about those 'TyCon's derived from a @data@-    -- declaration. This includes data types with no constructors at-    -- all.-  | DataTyCon {-        data_cons :: [DataCon],-                          -- ^ The data type constructors; can be empty if the-                          --   user declares the type to have no constructors-                          ---                          -- INVARIANT: Kept in order of increasing 'DataCon'-                          -- tag (see the tag assignment in mkTyConTagMap)-        data_cons_size :: Int,-                          -- ^ Cached value: length data_cons-        is_enum :: Bool   -- ^ Cached value: is this an enumeration type?-                          --   See Note [Enumeration types]-    }--  | TupleTyCon {                   -- A boxed, unboxed, or constraint tuple-        data_con :: DataCon,       -- NB: it can be an *unboxed* tuple-        tup_sort :: TupleSort      -- ^ Is this a boxed, unboxed or constraint-                                   -- tuple?-    }--  -- | An unboxed sum type.-  | SumTyCon {-        data_cons :: [DataCon],-        data_cons_size :: Int  -- ^ Cached value: length data_cons-    }--  -- | Information about those 'TyCon's derived from a @newtype@ declaration-  | NewTyCon {-        data_con :: DataCon,    -- ^ The unique constructor for the @newtype@.-                                --   It has no existentials--        nt_rhs :: Type,         -- ^ Cached value: the argument type of the-                                -- constructor, which is just the representation-                                -- type of the 'TyCon' (remember that @newtype@s-                                -- do not exist at runtime so need a different-                                -- representation type).-                                ---                                -- The free 'TyVar's of this type are the-                                -- 'tyConTyVars' from the corresponding 'TyCon'--        nt_etad_rhs :: ([TyVar], Type),-                        -- ^ Same as the 'nt_rhs', but this time eta-reduced.-                        -- Hence the list of 'TyVar's in this field may be-                        -- shorter than the declared arity of the 'TyCon'.--                        -- See Note [Newtype eta]-        nt_co :: CoAxiom Unbranched,-                             -- The axiom coercion that creates the @newtype@-                             -- from the representation 'Type'.--                             -- See Note [Newtype coercions]-                             -- Invariant: arity = #tvs in nt_etad_rhs;-                             -- See Note [Newtype eta]-                             -- Watch out!  If any newtypes become transparent-                             -- again check #1072.-        nt_lev_poly :: Bool-                        -- 'True' if the newtype can be levity polymorphic when-                        -- fully applied to its arguments, 'False' otherwise.-                        -- This can only ever be 'True' with UnliftedNewtypes.-                        ---                        -- Invariant: nt_lev_poly nt = isTypeLevPoly (nt_rhs nt)-                        ---                        -- This is cached to make it cheaper to check if a-                        -- variable binding is levity polymorphic, as used by-                        -- isTcLevPoly.-    }--mkSumTyConRhs :: [DataCon] -> AlgTyConRhs-mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons)--mkDataTyConRhs :: [DataCon] -> AlgTyConRhs-mkDataTyConRhs cons-  = DataTyCon {-        data_cons = cons,-        data_cons_size = length cons,-        is_enum = not (null cons) && all is_enum_con cons-                  -- See Note [Enumeration types] in TyCon-    }-  where-    is_enum_con con-       | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res)-           <- dataConFullSig con-       = null ex_tvs && null eq_spec && null theta && null arg_tys---- | Some promoted datacons signify extra info relevant to GHC. For example,--- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep'--- constructor of 'PrimRep'. This data structure allows us to store this--- information right in the 'TyCon'. The other approach would be to look--- up things like @RuntimeRep@'s @PrimRep@ by known-key every time.--- See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType-data RuntimeRepInfo-  = NoRRI       -- ^ an ordinary promoted data con-  | RuntimeRep ([Type] -> [PrimRep])-      -- ^ A constructor of @RuntimeRep@. The argument to the function should-      -- be the list of arguments to the promoted datacon.-  | VecCount Int         -- ^ A constructor of @VecCount@-  | VecElem PrimElemRep  -- ^ A constructor of @VecElem@---- | Extract those 'DataCon's that we are able to learn about.  Note--- that visibility in this sense does not correspond to visibility in--- the context of any particular user program!-visibleDataCons :: AlgTyConRhs -> [DataCon]-visibleDataCons (AbstractTyCon {})            = []-visibleDataCons (DataTyCon{ data_cons = cs }) = cs-visibleDataCons (NewTyCon{ data_con = c })    = [c]-visibleDataCons (TupleTyCon{ data_con = c })  = [c]-visibleDataCons (SumTyCon{ data_cons = cs })  = cs---- ^ Both type classes as well as family instances imply implicit--- type constructors.  These implicit type constructors refer to their parent--- structure (ie, the class or family from which they derive) using a type of--- the following form.-data AlgTyConFlav-  = -- | An ordinary type constructor has no parent.-    VanillaAlgTyCon-       TyConRepName   -- For Typeable--    -- | An unboxed type constructor. The TyConRepName is a Maybe since we-    -- currently don't allow unboxed sums to be Typeable since there are too-    -- many of them. See #13276.-  | UnboxedAlgTyCon-       (Maybe TyConRepName)--  -- | Type constructors representing a class dictionary.-  -- See Note [ATyCon for classes] in TyCoRep-  | ClassTyCon-        Class           -- INVARIANT: the classTyCon of this Class is the-                        -- current tycon-        TyConRepName--  -- | Type constructors representing an *instance* of a *data* family.-  -- Parameters:-  ---  --  1) The type family in question-  ---  --  2) Instance types; free variables are the 'tyConTyVars'-  --  of the current 'TyCon' (not the family one). INVARIANT:-  --  the number of types matches the arity of the family 'TyCon'-  ---  --  3) A 'CoTyCon' identifying the representation-  --  type with the type instance family-  | DataFamInstTyCon          -- See Note [Data type families]-        (CoAxiom Unbranched)  -- The coercion axiom.-               -- A *Representational* coercion,-               -- of kind   T ty1 ty2   ~R   R:T a b c-               -- where T is the family TyCon,-               -- and R:T is the representation TyCon (ie this one)-               -- and a,b,c are the tyConTyVars of this TyCon-               ---               -- BUT may be eta-reduced; see FamInstEnv-               --     Note [Eta reduction for data families]--          -- Cached fields of the CoAxiom, but adjusted to-          -- use the tyConTyVars of this TyCon-        TyCon   -- The family TyCon-        [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)-                -- No shorter in length than the tyConTyVars of the family TyCon-                -- How could it be longer? See [Arity of data families] in FamInstEnv--        -- E.g.  data instance T [a] = ...-        -- gives a representation tycon:-        --      data R:TList a = ...-        --      axiom co a :: T [a] ~ R:TList a-        -- with R:TList's algTcParent = DataFamInstTyCon T [a] co--instance Outputable AlgTyConFlav where-    ppr (VanillaAlgTyCon {})        = text "Vanilla ADT"-    ppr (UnboxedAlgTyCon {})        = text "Unboxed ADT"-    ppr (ClassTyCon cls _)          = text "Class parent" <+> ppr cls-    ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)"-                                      <+> ppr tc <+> sep (map pprType tys)---- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class--- name, if any-okParent :: Name -> AlgTyConFlav -> Bool-okParent _       (VanillaAlgTyCon {})            = True-okParent _       (UnboxedAlgTyCon {})            = True-okParent tc_name (ClassTyCon cls _)              = tc_name == tyConName (classTyCon cls)-okParent _       (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc--isNoParent :: AlgTyConFlav -> Bool-isNoParent (VanillaAlgTyCon {}) = True-isNoParent _                   = False------------------------data Injectivity-  = NotInjective-  | Injective [Bool]   -- 1-1 with tyConTyVars (incl kind vars)-  deriving( Eq )---- | Information pertaining to the expansion of a type synonym (@type@)-data FamTyConFlav-  = -- | Represents an open type family without a fixed right hand-    -- side.  Additional instances can appear at any time.-    ---    -- These are introduced by either a top level declaration:-    ---    -- > data family T a :: *-    ---    -- Or an associated data type declaration, within a class declaration:-    ---    -- > class C a b where-    -- >   data T b :: *-     DataFamilyTyCon-       TyConRepName--     -- | An open type synonym family  e.g. @type family F x y :: * -> *@-   | OpenSynFamilyTyCon--   -- | A closed type synonym family  e.g.-   -- @type family F x where { F Int = Bool }@-   | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched))-     -- See Note [Closed type families]--   -- | A closed type synonym family declared in an hs-boot file with-   -- type family F a where ..-   | AbstractClosedSynFamilyTyCon--   -- | Built-in type family used by the TypeNats solver-   | BuiltInSynFamTyCon BuiltInSynFamily--instance Outputable FamTyConFlav where-    ppr (DataFamilyTyCon n) = text "data family" <+> ppr n-    ppr OpenSynFamilyTyCon = text "open type family"-    ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family"-    ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax-    ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family"-    ppr (BuiltInSynFamTyCon _) = text "built-in type family"--{- Note [Closed type families]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* In an open type family you can add new instances later.  This is the-  usual case.--* In a closed type family you can only put equations where the family-  is defined.--A non-empty closed type family has a single axiom with multiple-branches, stored in the 'ClosedSynFamilyTyCon' constructor.  A closed-type family with no equations does not have an axiom, because there is-nothing for the axiom to prove!---Note [Promoted data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-All data constructors can be promoted to become a type constructor,-via the PromotedDataCon alternative in TyCon.--* The TyCon promoted from a DataCon has the *same* Name and Unique as-  the DataCon.  Eg. If the data constructor Data.Maybe.Just(unique 78,-  say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78)--* We promote the *user* type of the DataCon.  Eg-     data T = MkT {-# UNPACK #-} !(Bool, Bool)-  The promoted kind is-     'MkT :: (Bool,Bool) -> T-  *not*-     'MkT :: Bool -> Bool -> T--* Similarly for GADTs:-     data G a where-       MkG :: forall b. b -> G [b]-  The promoted data constructor has kind-       'MkG :: forall b. b -> G [b]-  *not*-       'MkG :: forall a b. (a ~# [b]) => b -> G a--Note [Enumeration types]-~~~~~~~~~~~~~~~~~~~~~~~~-We define datatypes with no constructors to *not* be-enumerations; this fixes trac #2578,  Otherwise we-end up generating an empty table for-  <mod>_<type>_closure_tbl-which is used by tagToEnum# to map Int# to constructors-in an enumeration. The empty table apparently upset-the linker.--Moreover, all the data constructor must be enumerations, meaning-they have type  (forall abc. T a b c).  GADTs are not enumerations.-For example consider-    data T a where-      T1 :: T Int-      T2 :: T Bool-      T3 :: T a-What would [T1 ..] be?  [T1,T3] :: T Int? Easiest thing is to exclude them.-See #4528.--Note [Newtype coercions]-~~~~~~~~~~~~~~~~~~~~~~~~-The NewTyCon field nt_co is a CoAxiom which is used for coercing from-the representation type of the newtype, to the newtype itself. For-example,--   newtype T a = MkT (a -> a)--the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t.--In the case that the right hand side is a type application-ending with the same type variables as the left hand side, we-"eta-contract" the coercion.  So if we had--   newtype S a = MkT [a]--then we would generate the arity 0 axiom CoS : S ~ [].  The-primary reason we do this is to make newtype deriving cleaner.--In the paper we'd write-        axiom CoT : (forall t. T t) ~ (forall t. [t])-and then when we used CoT at a particular type, s, we'd say-        CoT @ s-which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s])--Note [Newtype eta]-~~~~~~~~~~~~~~~~~~-Consider-        newtype Parser a = MkParser (IO a) deriving Monad-Are these two types equal (to Core)?-        Monad Parser-        Monad IO-which we need to make the derived instance for Monad Parser.--Well, yes.  But to see that easily we eta-reduce the RHS type of-Parser, in this case to ([], Froogle), so that even unsaturated applications-of Parser will work right.  This eta reduction is done when the type-constructor is built, and cached in NewTyCon.--Here's an example that I think showed up in practice-Source code:-        newtype T a = MkT [a]-        newtype Foo m = MkFoo (forall a. m a -> Int)--        w1 :: Foo []-        w1 = ...--        w2 :: Foo T-        w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x)--After desugaring, and discarding the data constructors for the newtypes,-we get:-        w2 = w1 `cast` Foo CoT-so the coercion tycon CoT must have-        kind:    T ~ []- and    arity:   0--This eta-reduction is implemented in BuildTyCl.mkNewTyConRhs.---************************************************************************-*                                                                      *-                 TyConRepName-*                                                                      *-********************************************************************* -}--type TyConRepName = Name-   -- The Name of the top-level declaration for the Typeable world-   --    $tcMaybe :: Data.Typeable.Internal.TyCon-   --    $tcMaybe = TyCon { tyConName = "Maybe", ... }--tyConRepName_maybe :: TyCon -> Maybe TyConRepName-tyConRepName_maybe (FunTyCon   { tcRepName = rep_nm })-  = Just rep_nm-tyConRepName_maybe (PrimTyCon  { primRepName = mb_rep_nm })-  = mb_rep_nm-tyConRepName_maybe (AlgTyCon { algTcParent = parent })-  | VanillaAlgTyCon rep_nm <- parent = Just rep_nm-  | ClassTyCon _ rep_nm    <- parent = Just rep_nm-  | UnboxedAlgTyCon rep_nm <- parent = rep_nm-tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })-  = Just rep_nm-tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm })-  | isUnboxedSumCon dc   -- see #13276-  = Nothing-  | otherwise-  = Just rep_nm-tyConRepName_maybe _ = Nothing---- | Make a 'Name' for the 'Typeable' representation of the given wired-in type-mkPrelTyConRepName :: Name -> TyConRepName--- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.-mkPrelTyConRepName tc_name  -- Prelude tc_name is always External,-                            -- so nameModule will work-  = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name)-  where-    name_occ  = nameOccName tc_name-    name_mod  = nameModule  tc_name-    name_uniq = nameUnique  tc_name-    rep_uniq | isTcOcc name_occ = tyConRepNameUnique   name_uniq-             | otherwise        = dataConTyRepNameUnique name_uniq-    (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ---- | The name (and defining module) for the Typeable representation (TyCon) of a--- type constructor.------ See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.-tyConRepModOcc :: Module -> OccName -> (Module, OccName)-tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ)-  where-    rep_module-      | tc_module == gHC_PRIM = gHC_TYPES-      | otherwise             = tc_module---{- *********************************************************************-*                                                                      *-                 PrimRep-*                                                                      *-************************************************************************--Note [rep swamp]--GHC has a rich selection of types that represent "primitive types" of-one kind or another.  Each of them makes a different set of-distinctions, and mostly the differences are for good reasons,-although it's probably true that we could merge some of these.--Roughly in order of "includes more information":-- - A Width (cmm/CmmType) is simply a binary value with the specified-   number of bits.  It may represent a signed or unsigned integer, a-   floating-point value, or an address.--    data Width = W8 | W16 | W32 | W64  | W128-- - Size, which is used in the native code generator, is Width +-   floating point information.--   data Size = II8 | II16 | II32 | II64 | FF32 | FF64--   it is necessary because e.g. the instruction to move a 64-bit float-   on x86 (movsd) is different from the instruction to move a 64-bit-   integer (movq), so the mov instruction is parameterised by Size.-- - CmmType wraps Width with more information: GC ptr, float, or-   other value.--    data CmmType = CmmType CmmCat Width--    data CmmCat     -- "Category" (not exported)-       = GcPtrCat   -- GC pointer-       | BitsCat    -- Non-pointer-       | FloatCat   -- Float--   It is important to have GcPtr information in Cmm, since we generate-   info tables containing pointerhood for the GC from this.  As for-   why we have float (and not signed/unsigned) here, see Note [Signed-   vs unsigned].-- - ArgRep makes only the distinctions necessary for the call and-   return conventions of the STG machine.  It is essentially CmmType-   + void.-- - PrimRep makes a few more distinctions than ArgRep: it divides-   non-GC-pointers into signed/unsigned and addresses, information-   that is necessary for passing these values to foreign functions.--There's another tension here: whether the type encodes its size in-bytes, or whether its size depends on the machine word size.  Width-and CmmType have the size built-in, whereas ArgRep and PrimRep do not.--This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags.--On the other hand, CmmType includes some "nonsense" values, such as-CmmType GcPtrCat W32 on a 64-bit machine.--The PrimRep type is closely related to the user-visible RuntimeRep type.-See Note [RuntimeRep and PrimRep] in GHC.Types.RepType.---}---- | A 'PrimRep' is an abstraction of a type.  It contains information that--- the code generator needs in order to pass arguments, return results,--- and store values of this type. See also Note [RuntimeRep and PrimRep] in--- GHC.Types.RepType and Note [VoidRep] in GHC.Types.RepType.-data PrimRep-  = VoidRep-  | LiftedRep-  | UnliftedRep   -- ^ Unlifted pointer-  | Int8Rep       -- ^ Signed, 8-bit value-  | Int16Rep      -- ^ Signed, 16-bit value-  | Int32Rep      -- ^ Signed, 32-bit value-  | Int64Rep      -- ^ Signed, 64 bit value (with 32-bit words only)-  | IntRep        -- ^ Signed, word-sized value-  | Word8Rep      -- ^ Unsigned, 8 bit value-  | Word16Rep     -- ^ Unsigned, 16 bit value-  | Word32Rep     -- ^ Unsigned, 32 bit value-  | Word64Rep     -- ^ Unsigned, 64 bit value (with 32-bit words only)-  | WordRep       -- ^ Unsigned, word-sized value-  | AddrRep       -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep')-  | FloatRep-  | DoubleRep-  | VecRep Int PrimElemRep  -- ^ A vector-  deriving( Show )--data PrimElemRep-  = Int8ElemRep-  | Int16ElemRep-  | Int32ElemRep-  | Int64ElemRep-  | Word8ElemRep-  | Word16ElemRep-  | Word32ElemRep-  | Word64ElemRep-  | FloatElemRep-  | DoubleElemRep-   deriving( Eq, Show )--instance Outputable PrimRep where-  ppr r = text (show r)--instance Outputable PrimElemRep where-  ppr r = text (show r)--isVoidRep :: PrimRep -> Bool-isVoidRep VoidRep = True-isVoidRep _other  = False--isGcPtrRep :: PrimRep -> Bool-isGcPtrRep LiftedRep   = True-isGcPtrRep UnliftedRep = True-isGcPtrRep _           = False---- A PrimRep is compatible with another iff one can be coerced to the other.--- See Note [bad unsafe coercion] in GHC.Core.Lint for when are two types coercible.-primRepCompatible :: DynFlags -> PrimRep -> PrimRep -> Bool-primRepCompatible dflags rep1 rep2 =-    (isUnboxed rep1 == isUnboxed rep2) &&-    (primRepSizeB dflags rep1 == primRepSizeB dflags rep2) &&-    (primRepIsFloat rep1 == primRepIsFloat rep2)-  where-    isUnboxed = not . isGcPtrRep---- More general version of `primRepCompatible` for types represented by zero or--- more than one PrimReps.-primRepsCompatible :: DynFlags -> [PrimRep] -> [PrimRep] -> Bool-primRepsCompatible dflags reps1 reps2 =-    length reps1 == length reps2 &&-    and (zipWith (primRepCompatible dflags) reps1 reps2)---- | The size of a 'PrimRep' in bytes.------ This applies also when used in a constructor, where we allow packing the--- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will--- take only 8 bytes, which for 64-bit arch will be equal to 1 word.--- See also mkVirtHeapOffsetsWithPadding for details of how data fields are--- laid out.-primRepSizeB :: DynFlags -> PrimRep -> Int-primRepSizeB dflags IntRep           = wORD_SIZE dflags-primRepSizeB dflags WordRep          = wORD_SIZE dflags-primRepSizeB _      Int8Rep          = 1-primRepSizeB _      Int16Rep         = 2-primRepSizeB _      Int32Rep         = 4-primRepSizeB _      Int64Rep         = wORD64_SIZE-primRepSizeB _      Word8Rep         = 1-primRepSizeB _      Word16Rep        = 2-primRepSizeB _      Word32Rep        = 4-primRepSizeB _      Word64Rep        = wORD64_SIZE-primRepSizeB _      FloatRep         = fLOAT_SIZE-primRepSizeB dflags DoubleRep        = dOUBLE_SIZE dflags-primRepSizeB dflags AddrRep          = wORD_SIZE dflags-primRepSizeB dflags LiftedRep        = wORD_SIZE dflags-primRepSizeB dflags UnliftedRep      = wORD_SIZE dflags-primRepSizeB _      VoidRep          = 0-primRepSizeB _      (VecRep len rep) = len * primElemRepSizeB rep--primElemRepSizeB :: PrimElemRep -> Int-primElemRepSizeB Int8ElemRep   = 1-primElemRepSizeB Int16ElemRep  = 2-primElemRepSizeB Int32ElemRep  = 4-primElemRepSizeB Int64ElemRep  = 8-primElemRepSizeB Word8ElemRep  = 1-primElemRepSizeB Word16ElemRep = 2-primElemRepSizeB Word32ElemRep = 4-primElemRepSizeB Word64ElemRep = 8-primElemRepSizeB FloatElemRep  = 4-primElemRepSizeB DoubleElemRep = 8---- | Return if Rep stands for floating type,--- returns Nothing for vector types.-primRepIsFloat :: PrimRep -> Maybe Bool-primRepIsFloat  FloatRep     = Just True-primRepIsFloat  DoubleRep    = Just True-primRepIsFloat  (VecRep _ _) = Nothing-primRepIsFloat  _            = Just False---{--************************************************************************-*                                                                      *-                             Field labels-*                                                                      *-************************************************************************--}---- | The labels for the fields of this particular 'TyCon'-tyConFieldLabels :: TyCon -> [FieldLabel]-tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc---- | The labels for the fields of this particular 'TyCon'-tyConFieldLabelEnv :: TyCon -> FieldLabelEnv-tyConFieldLabelEnv tc-  | isAlgTyCon tc = algTcFields tc-  | otherwise     = emptyDFsEnv---- | Look up a field label belonging to this 'TyCon'-lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel-lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl---- | Make a map from strings to FieldLabels from all the data--- constructors of this algebraic tycon-fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv-fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl)-                                | fl <- dataConsFields (visibleDataCons rhs) ]-  where-    -- Duplicates in this list will be removed by 'mkFsEnv'-    dataConsFields dcs = concatMap dataConFieldLabels dcs---{--************************************************************************-*                                                                      *-\subsection{TyCon Construction}-*                                                                      *-************************************************************************--Note: the TyCon constructors all take a Kind as one argument, even though-they could, in principle, work out their Kind from their other arguments.-But to do so they need functions from Types, and that makes a nasty-module mutual-recursion.  And they aren't called from many places.-So we compromise, and move their Kind calculation to the call site.--}---- | Given the name of the function type constructor and it's kind, create the--- corresponding 'TyCon'. It is recommended to use 'TyCoRep.funTyCon' if you want--- this functionality-mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon-mkFunTyCon name binders rep_nm-  = FunTyCon {-        tyConUnique  = nameUnique name,-        tyConName    = name,-        tyConBinders = binders,-        tyConResKind = liftedTypeKind,-        tyConKind    = mkTyConKind binders liftedTypeKind,-        tyConArity   = length binders,-        tcRepName    = rep_nm-    }---- | This is the making of an algebraic 'TyCon'. Notably, you have to--- pass in the generic (in the -XGenerics sense) information about the--- type constructor - you can get hold of it easily (see Generics--- module)-mkAlgTyCon :: Name-           -> [TyConBinder]  -- ^ Binders of the 'TyCon'-           -> Kind              -- ^ Result kind-           -> [Role]            -- ^ The roles for each TyVar-           -> Maybe CType       -- ^ The C type this type corresponds to-                                --   when using the CAPI FFI-           -> [PredType]        -- ^ Stupid theta: see 'algTcStupidTheta'-           -> AlgTyConRhs       -- ^ Information about data constructors-           -> AlgTyConFlav      -- ^ What flavour is it?-                                -- (e.g. vanilla, type family)-           -> Bool              -- ^ Was the 'TyCon' declared with GADT syntax?-           -> TyCon-mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn-  = AlgTyCon {-        tyConName        = name,-        tyConUnique      = nameUnique name,-        tyConBinders     = binders,-        tyConResKind     = res_kind,-        tyConKind        = mkTyConKind binders res_kind,-        tyConArity       = length binders,-        tyConTyVars      = binderVars binders,-        tcRoles          = roles,-        tyConCType       = cType,-        algTcStupidTheta = stupid,-        algTcRhs         = rhs,-        algTcFields      = fieldsOfAlgTcRhs rhs,-        algTcParent      = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent,-        algTcGadtSyntax  = gadt_syn-    }---- | Simpler specialization of 'mkAlgTyCon' for classes-mkClassTyCon :: Name -> [TyConBinder]-             -> [Role] -> AlgTyConRhs -> Class-             -> Name -> TyCon-mkClassTyCon name binders roles rhs clas tc_rep_name-  = mkAlgTyCon name binders constraintKind roles Nothing [] rhs-               (ClassTyCon clas tc_rep_name)-               False--mkTupleTyCon :: Name-             -> [TyConBinder]-             -> Kind    -- ^ Result kind of the 'TyCon'-             -> Arity   -- ^ Arity of the tuple 'TyCon'-             -> DataCon-             -> TupleSort    -- ^ Whether the tuple is boxed or unboxed-             -> AlgTyConFlav-             -> TyCon-mkTupleTyCon name binders res_kind arity con sort parent-  = AlgTyCon {-        tyConUnique      = nameUnique name,-        tyConName        = name,-        tyConBinders     = binders,-        tyConTyVars      = binderVars binders,-        tyConResKind     = res_kind,-        tyConKind        = mkTyConKind binders res_kind,-        tyConArity       = arity,-        tcRoles          = replicate arity Representational,-        tyConCType       = Nothing,-        algTcGadtSyntax  = False,-        algTcStupidTheta = [],-        algTcRhs         = TupleTyCon { data_con = con,-                                        tup_sort = sort },-        algTcFields      = emptyDFsEnv,-        algTcParent      = parent-    }--mkSumTyCon :: Name-             -> [TyConBinder]-             -> Kind    -- ^ Kind of the resulting 'TyCon'-             -> Arity   -- ^ Arity of the sum-             -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'-             -> [DataCon]-             -> AlgTyConFlav-             -> TyCon-mkSumTyCon name binders res_kind arity tyvars cons parent-  = AlgTyCon {-        tyConUnique      = nameUnique name,-        tyConName        = name,-        tyConBinders     = binders,-        tyConTyVars      = tyvars,-        tyConResKind     = res_kind,-        tyConKind        = mkTyConKind binders res_kind,-        tyConArity       = arity,-        tcRoles          = replicate arity Representational,-        tyConCType       = Nothing,-        algTcGadtSyntax  = False,-        algTcStupidTheta = [],-        algTcRhs         = mkSumTyConRhs cons,-        algTcFields      = emptyDFsEnv,-        algTcParent      = parent-    }---- | Makes a tycon suitable for use during type-checking. It stores--- a variety of details about the definition of the TyCon, but no--- right-hand side. It lives only during the type-checking of a--- mutually-recursive group of tycons; it is then zonked to a proper--- TyCon in zonkTcTyCon.--- See also Note [Kind checking recursive type and class declarations]--- in TcTyClsDecls.-mkTcTyCon :: Name-          -> [TyConBinder]-          -> Kind                -- ^ /result/ kind only-          -> [(Name,TcTyVar)]    -- ^ Scoped type variables;-                                 -- see Note [How TcTyCons work] in TcTyClsDecls-          -> Bool                -- ^ Is this TcTyCon generalised already?-          -> TyConFlavour        -- ^ What sort of 'TyCon' this represents-          -> TyCon-mkTcTyCon name binders res_kind scoped_tvs poly flav-  = TcTyCon { tyConUnique  = getUnique name-            , tyConName    = name-            , tyConTyVars  = binderVars binders-            , tyConBinders = binders-            , tyConResKind = res_kind-            , tyConKind    = mkTyConKind binders res_kind-            , tyConArity   = length binders-            , tcTyConScopedTyVars = scoped_tvs-            , tcTyConIsPoly       = poly-            , tcTyConFlavour      = flav }---- | No scoped type variables (to be used with mkTcTyCon).-noTcTyConScopedTyVars :: [(Name, TcTyVar)]-noTcTyConScopedTyVars = []---- | Create an unlifted primitive 'TyCon', such as @Int#@.-mkPrimTyCon :: Name -> [TyConBinder]-            -> Kind   -- ^ /result/ kind, never levity-polymorphic-            -> [Role] -> TyCon-mkPrimTyCon name binders res_kind roles-  = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name)---- | Kind constructors-mkKindTyCon :: Name -> [TyConBinder]-            -> Kind  -- ^ /result/ kind-            -> [Role] -> Name -> TyCon-mkKindTyCon name binders res_kind roles rep_nm-  = tc-  where-    tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm)---- | Create a lifted primitive 'TyCon' such as @RealWorld@-mkLiftedPrimTyCon :: Name -> [TyConBinder]-                  -> Kind   -- ^ /result/ kind-                  -> [Role] -> TyCon-mkLiftedPrimTyCon name binders res_kind roles-  = mkPrimTyCon' name binders res_kind roles False (Just rep_nm)-  where rep_nm = mkPrelTyConRepName name--mkPrimTyCon' :: Name -> [TyConBinder]-             -> Kind    -- ^ /result/ kind, never levity-polymorphic-                        -- (If you need a levity-polymorphic PrimTyCon, change-                        --  isTcLevPoly.)-             -> [Role]-             -> Bool -> Maybe TyConRepName -> TyCon-mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm-  = PrimTyCon {-        tyConName    = name,-        tyConUnique  = nameUnique name,-        tyConBinders = binders,-        tyConResKind = res_kind,-        tyConKind    = mkTyConKind binders res_kind,-        tyConArity   = length roles,-        tcRoles      = roles,-        isUnlifted   = is_unlifted,-        primRepName  = rep_nm-    }---- | Create a type synonym 'TyCon'-mkSynonymTyCon :: Name -> [TyConBinder] -> Kind   -- ^ /result/ kind-               -> [Role] -> Type -> Bool -> Bool -> TyCon-mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free-  = SynonymTyCon {-        tyConName    = name,-        tyConUnique  = nameUnique name,-        tyConBinders = binders,-        tyConResKind = res_kind,-        tyConKind    = mkTyConKind binders res_kind,-        tyConArity   = length binders,-        tyConTyVars  = binderVars binders,-        tcRoles      = roles,-        synTcRhs     = rhs,-        synIsTau     = is_tau,-        synIsFamFree = is_fam_free-    }---- | Create a type family 'TyCon'-mkFamilyTyCon :: Name -> [TyConBinder] -> Kind  -- ^ /result/ kind-              -> Maybe Name -> FamTyConFlav-              -> Maybe Class -> Injectivity -> TyCon-mkFamilyTyCon name binders res_kind resVar flav parent inj-  = FamilyTyCon-      { tyConUnique  = nameUnique name-      , tyConName    = name-      , tyConBinders = binders-      , tyConResKind = res_kind-      , tyConKind    = mkTyConKind binders res_kind-      , tyConArity   = length binders-      , tyConTyVars  = binderVars binders-      , famTcResVar  = resVar-      , famTcFlav    = flav-      , famTcParent  = classTyCon <$> parent-      , famTcInj     = inj-      }----- | Create a promoted data constructor 'TyCon'--- Somewhat dodgily, we give it the same Name--- as the data constructor itself; when we pretty-print--- the TyCon we add a quote; see the Outputable TyCon instance-mkPromotedDataCon :: DataCon -> Name -> TyConRepName-                  -> [TyConTyCoBinder] -> Kind -> [Role]-                  -> RuntimeRepInfo -> TyCon-mkPromotedDataCon con name rep_name binders res_kind roles rep_info-  = PromotedDataCon {-        tyConUnique   = nameUnique name,-        tyConName     = name,-        tyConArity    = length roles,-        tcRoles       = roles,-        tyConBinders  = binders,-        tyConResKind  = res_kind,-        tyConKind     = mkTyConKind binders res_kind,-        dataCon       = con,-        tcRepName     = rep_name,-        promDcRepInfo = rep_info-  }--isFunTyCon :: TyCon -> Bool-isFunTyCon (FunTyCon {}) = True-isFunTyCon _             = False---- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors)-isAbstractTyCon :: TyCon -> Bool-isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True-isAbstractTyCon _ = False---- | Does this 'TyCon' represent something that cannot be defined in Haskell?-isPrimTyCon :: TyCon -> Bool-isPrimTyCon (PrimTyCon {}) = True-isPrimTyCon _              = False---- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can--- only be true for primitive and unboxed-tuple 'TyCon's-isUnliftedTyCon :: TyCon -> Bool-isUnliftedTyCon (PrimTyCon  {isUnlifted = is_unlifted})-  = is_unlifted-isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } )-  | TupleTyCon { tup_sort = sort } <- rhs-  = not (isBoxed (tupleSortBoxity sort))-isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } )-  | SumTyCon {} <- rhs-  = True-isUnliftedTyCon _ = False---- | Returns @True@ if the supplied 'TyCon' resulted from either a--- @data@ or @newtype@ declaration-isAlgTyCon :: TyCon -> Bool-isAlgTyCon (AlgTyCon {})   = True-isAlgTyCon _               = False---- | Returns @True@ for vanilla AlgTyCons -- that is, those created--- with a @data@ or @newtype@ declaration.-isVanillaAlgTyCon :: TyCon -> Bool-isVanillaAlgTyCon (AlgTyCon { algTcParent = VanillaAlgTyCon _ }) = True-isVanillaAlgTyCon _                                              = False--isDataTyCon :: TyCon -> Bool--- ^ Returns @True@ for data types that are /definitely/ represented by--- heap-allocated constructors.  These are scrutinised by Core-level--- @case@ expressions, and they get info tables allocated for them.------ Generally, the function will be true for all @data@ types and false--- for @newtype@s, unboxed tuples, unboxed sums and type family--- 'TyCon's. But it is not guaranteed to return @True@ in all cases--- that it could.------ NB: for a data type family, only the /instance/ 'TyCon's---     get an info table.  The family declaration 'TyCon' does not-isDataTyCon (AlgTyCon {algTcRhs = rhs})-  = case rhs of-        TupleTyCon { tup_sort = sort }-                           -> isBoxed (tupleSortBoxity sort)-        SumTyCon {}        -> False-        DataTyCon {}       -> True-        NewTyCon {}        -> False-        AbstractTyCon {}   -> False      -- We don't know, so return False-isDataTyCon _ = False---- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds--- (where X is the role passed in):---   If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2)--- (where X1, X2, and X3, are the roles given by tyConRolesX tc X)--- See also Note [Decomposing equality] in TcCanonical-isInjectiveTyCon :: TyCon -> Role -> Bool-isInjectiveTyCon _                             Phantom          = False-isInjectiveTyCon (FunTyCon {})                 _                = True-isInjectiveTyCon (AlgTyCon {})                 Nominal          = True-isInjectiveTyCon (AlgTyCon {algTcRhs = rhs})   Representational-  = isGenInjAlgRhs rhs-isInjectiveTyCon (SynonymTyCon {})             _                = False-isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ })-                                               Nominal          = True-isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj-isInjectiveTyCon (FamilyTyCon {})              _                = False-isInjectiveTyCon (PrimTyCon {})                _                = True-isInjectiveTyCon (PromotedDataCon {})          _                = True-isInjectiveTyCon (TcTyCon {})                  _                = True-  -- Reply True for TcTyCon to minimise knock on type errors-  -- See Note [How TcTyCons work] item (1) in TcTyClsDecls---- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds--- (where X is the role passed in):---   If (T tys ~X t), then (t's head ~X T).--- See also Note [Decomposing equality] in TcCanonical-isGenerativeTyCon :: TyCon -> Role -> Bool-isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True-isGenerativeTyCon (FamilyTyCon {}) _ = False-  -- in all other cases, injectivity implies generativity-isGenerativeTyCon tc               r = isInjectiveTyCon tc r---- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective--- with respect to representational equality?-isGenInjAlgRhs :: AlgTyConRhs -> Bool-isGenInjAlgRhs (TupleTyCon {})          = True-isGenInjAlgRhs (SumTyCon {})            = True-isGenInjAlgRhs (DataTyCon {})           = True-isGenInjAlgRhs (AbstractTyCon {})       = False-isGenInjAlgRhs (NewTyCon {})            = False---- | Is this 'TyCon' that for a @newtype@-isNewTyCon :: TyCon -> Bool-isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True-isNewTyCon _                                   = False---- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it--- expands into, and (possibly) a coercion from the representation type to the--- @newtype@.--- Returns @Nothing@ if this is not possible.-unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched)-unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs,-                                 algTcRhs = NewTyCon { nt_co = co,-                                                       nt_rhs = rhs }})-                           = Just (tvs, rhs, co)-unwrapNewTyCon_maybe _     = Nothing--unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched)-unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co,-                                                           nt_etad_rhs = (tvs,rhs) }})-                           = Just (tvs, rhs, co)-unwrapNewTyConEtad_maybe _ = Nothing--isProductTyCon :: TyCon -> Bool--- True of datatypes or newtypes that have---   one, non-existential, data constructor--- See Note [Product types]-isProductTyCon tc@(AlgTyCon {})-  = case algTcRhs tc of-      TupleTyCon {} -> True-      DataTyCon{ data_cons = [data_con] }-                    -> null (dataConExTyCoVars data_con)-      NewTyCon {}   -> True-      _             -> False-isProductTyCon _ = False--isDataProductTyCon_maybe :: TyCon -> Maybe DataCon--- True of datatypes (not newtypes) with---   one, vanilla, data constructor--- See Note [Product types]-isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs })-  = case rhs of-       DataTyCon { data_cons = [con] }-         | null (dataConExTyCoVars con)  -- non-existential-         -> Just con-       TupleTyCon { data_con = con }-         -> Just con-       _ -> Nothing-isDataProductTyCon_maybe _ = Nothing--isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon]-isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs })-  = case rhs of-      DataTyCon { data_cons = cons }-        | cons `lengthExceeds` 1-        , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this?-        -> Just cons-      SumTyCon { data_cons = cons }-        | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this?-        -> Just cons-      _ -> Nothing-isDataSumTyCon_maybe _ = Nothing--{- Note [Product types]-~~~~~~~~~~~~~~~~~~~~~~~-A product type is- * A data type (not a newtype)- * With one, boxed data constructor- * That binds no existential type variables--The main point is that product types are amenable to unboxing for-  * Strict function calls; we can transform-        f (D a b) = e-    to-        fw a b = e-    via the worker/wrapper transformation.  (Question: couldn't this-    work for existentials too?)--  * CPR for function results; we can transform-        f x y = let ... in D a b-    to-        fw x y = let ... in (# a, b #)--Note that the data constructor /can/ have evidence arguments: equality-constraints, type classes etc.  So it can be GADT.  These evidence-arguments are simply value arguments, and should not get in the way.--}----- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)?-isTypeSynonymTyCon :: TyCon -> Bool-isTypeSynonymTyCon (SynonymTyCon {}) = True-isTypeSynonymTyCon _                 = False--isTauTyCon :: TyCon -> Bool-isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau-isTauTyCon _                                    = True--isFamFreeTyCon :: TyCon -> Bool-isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free-isFamFreeTyCon (FamilyTyCon { famTcFlav = flav })         = isDataFamFlav flav-isFamFreeTyCon _                                          = True---- As for newtypes, it is in some contexts important to distinguish between--- closed synonyms and synonym families, as synonym families have no unique--- right hand side to which a synonym family application can expand.------- | True iff we can decompose (T a b c) into ((T a b) c)---   I.e. is it injective and generative w.r.t nominal equality?---   That is, if (T a b) ~N d e f, is it always the case that---            (T ~N d), (a ~N e) and (b ~N f)?--- Specifically NOT true of synonyms (open and otherwise)------ It'd be unusual to call mustBeSaturated on a regular H98--- type synonym, because you should probably have expanded it first--- But regardless, it's not decomposable-mustBeSaturated :: TyCon -> Bool-mustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour---- | Is this an algebraic 'TyCon' declared with the GADT syntax?-isGadtSyntaxTyCon :: TyCon -> Bool-isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res-isGadtSyntaxTyCon _                                    = False---- | Is this an algebraic 'TyCon' which is just an enumeration of values?-isEnumerationTyCon :: TyCon -> Bool--- See Note [Enumeration types] in TyCon-isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs })-  = case rhs of-       DataTyCon { is_enum = res } -> res-       TupleTyCon {}               -> arity == 0-       _                           -> False-isEnumerationTyCon _ = False---- | Is this a 'TyCon', synonym or otherwise, that defines a family?-isFamilyTyCon :: TyCon -> Bool-isFamilyTyCon (FamilyTyCon {}) = True-isFamilyTyCon _                = False---- | Is this a 'TyCon', synonym or otherwise, that defines a family with--- instances?-isOpenFamilyTyCon :: TyCon -> Bool-isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav })-  | OpenSynFamilyTyCon <- flav = True-  | DataFamilyTyCon {} <- flav = True-isOpenFamilyTyCon _            = False---- | Is this a synonym 'TyCon' that can have may have further instances appear?-isTypeFamilyTyCon :: TyCon -> Bool-isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav)-isTypeFamilyTyCon _                                  = False---- | Is this a synonym 'TyCon' that can have may have further instances appear?-isDataFamilyTyCon :: TyCon -> Bool-isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav-isDataFamilyTyCon _                                  = False---- | Is this an open type family TyCon?-isOpenTypeFamilyTyCon :: TyCon -> Bool-isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True-isOpenTypeFamilyTyCon _                                               = False---- | Is this a non-empty closed type family? Returns 'Nothing' for--- abstract or empty closed families.-isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched)-isClosedSynFamilyTyConWithAxiom_maybe-  (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb-isClosedSynFamilyTyConWithAxiom_maybe _               = Nothing---- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ is @tc@ is an--- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is--- injective), or 'NotInjective' otherwise.-tyConInjectivityInfo :: TyCon -> Injectivity-tyConInjectivityInfo tc-  | FamilyTyCon { famTcInj = inj } <- tc-  = inj-  | isInjectiveTyCon tc Nominal-  = Injective (replicate (tyConArity tc) True)-  | otherwise-  = NotInjective--isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily-isBuiltInSynFamTyCon_maybe-  (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops-isBuiltInSynFamTyCon_maybe _                          = Nothing--isDataFamFlav :: FamTyConFlav -> Bool-isDataFamFlav (DataFamilyTyCon {}) = True   -- Data family-isDataFamFlav _                    = False  -- Type synonym family---- | Is this TyCon for an associated type?-isTyConAssoc :: TyCon -> Bool-isTyConAssoc = isJust . tyConAssoc_maybe---- | Get the enclosing class TyCon (if there is one) for the given TyCon.-tyConAssoc_maybe :: TyCon -> Maybe TyCon-tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour---- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour-tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon-tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent)     = mb_parent-tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent-tyConFlavourAssoc_maybe _                                 = Nothing---- The unit tycon didn't used to be classed as a tuple tycon--- but I thought that was silly so I've undone it--- If it can't be for some reason, it should be a AlgTyCon-isTupleTyCon :: TyCon -> Bool--- ^ Does this 'TyCon' represent a tuple?------ NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to--- 'isTupleTyCon', because they are built as 'AlgTyCons'.  However they--- get spat into the interface file as tuple tycons, so I don't think--- it matters.-isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True-isTupleTyCon _ = False--tyConTuple_maybe :: TyCon -> Maybe TupleSort-tyConTuple_maybe (AlgTyCon { algTcRhs = rhs })-  | TupleTyCon { tup_sort = sort} <- rhs = Just sort-tyConTuple_maybe _                       = Nothing---- | Is this the 'TyCon' for an unboxed tuple?-isUnboxedTupleTyCon :: TyCon -> Bool-isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs })-  | TupleTyCon { tup_sort = sort } <- rhs-  = not (isBoxed (tupleSortBoxity sort))-isUnboxedTupleTyCon _ = False---- | Is this the 'TyCon' for a boxed tuple?-isBoxedTupleTyCon :: TyCon -> Bool-isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs })-  | TupleTyCon { tup_sort = sort } <- rhs-  = isBoxed (tupleSortBoxity sort)-isBoxedTupleTyCon _ = False---- | Is this the 'TyCon' for an unboxed sum?-isUnboxedSumTyCon :: TyCon -> Bool-isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs })-  | SumTyCon {} <- rhs-  = True-isUnboxedSumTyCon _ = False---- | Is this the 'TyCon' for a /promoted/ tuple?-isPromotedTupleTyCon :: TyCon -> Bool-isPromotedTupleTyCon tyCon-  | Just dataCon <- isPromotedDataCon_maybe tyCon-  , isTupleTyCon (dataConTyCon dataCon) = True-  | otherwise                           = False---- | Is this a PromotedDataCon?-isPromotedDataCon :: TyCon -> Bool-isPromotedDataCon (PromotedDataCon {}) = True-isPromotedDataCon _                    = False---- | Retrieves the promoted DataCon if this is a PromotedDataCon;-isPromotedDataCon_maybe :: TyCon -> Maybe DataCon-isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc-isPromotedDataCon_maybe _ = Nothing---- | Is this tycon really meant for use at the kind level? That is,--- should it be permitted without -XDataKinds?-isKindTyCon :: TyCon -> Bool-isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys---- | These TyCons should be allowed at the kind level, even without--- -XDataKinds.-kindTyConKeys :: UniqSet Unique-kindTyConKeys = unionManyUniqSets-  ( mkUniqSet [ liftedTypeKindTyConKey, constraintKindTyConKey, tYPETyConKey ]-  : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon-                                          , vecCountTyCon, vecElemTyCon ] )-  where-    tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc)--isLiftedTypeKindTyConName :: Name -> Bool-isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey)---- | Identifies implicit tycons that, in particular, do not go into interface--- files (because they are implicitly reconstructed when the interface is--- read).------ Note that:------ * Associated families are implicit, as they are re-constructed from---   the class declaration in which they reside, and------ * Family instances are /not/ implicit as they represent the instance body---   (similar to a @dfun@ does that for a class instance).------ * Tuples are implicit iff they have a wired-in name---   (namely: boxed and unboxed tuples are wired-in and implicit,---            but constraint tuples are not)-isImplicitTyCon :: TyCon -> Bool-isImplicitTyCon (FunTyCon {})        = True-isImplicitTyCon (PrimTyCon {})       = True-isImplicitTyCon (PromotedDataCon {}) = True-isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name })-  | TupleTyCon {} <- rhs             = isWiredInName name-  | SumTyCon {} <- rhs               = True-  | otherwise                        = False-isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent-isImplicitTyCon (SynonymTyCon {})    = False-isImplicitTyCon (TcTyCon {})         = False--tyConCType_maybe :: TyCon -> Maybe CType-tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc-tyConCType_maybe _ = Nothing---- | Is this a TcTyCon? (That is, one only used during type-checking?)-isTcTyCon :: TyCon -> Bool-isTcTyCon (TcTyCon {}) = True-isTcTyCon _            = False--setTcTyConKind :: TyCon -> Kind -> TyCon--- Update the Kind of a TcTyCon--- The new kind is always a zonked version of its previous--- kind, so we don't need to update any other fields.--- See Note [The Purely Kinded Invariant] in TcHsType-setTcTyConKind tc@(TcTyCon {}) kind = tc { tyConKind = kind }-setTcTyConKind tc              _    = pprPanic "setTcTyConKind" (ppr tc)---- | Could this TyCon ever be levity-polymorphic when fully applied?--- True is safe. False means we're sure. Does only a quick check--- based on the TyCon's category.--- Precondition: The fully-applied TyCon has kind (TYPE blah)-isTcLevPoly :: TyCon -> Bool-isTcLevPoly FunTyCon{}           = False-isTcLevPoly (AlgTyCon { algTcParent = parent, algTcRhs = rhs })-  | UnboxedAlgTyCon _ <- parent-  = True-  | NewTyCon { nt_lev_poly = lev_poly } <- rhs-  = lev_poly -- Newtypes can be levity polymorphic with UnliftedNewtypes (#17360)-  | otherwise-  = False-isTcLevPoly SynonymTyCon{}       = True-isTcLevPoly FamilyTyCon{}        = True-isTcLevPoly PrimTyCon{}          = False-isTcLevPoly TcTyCon{}            = False-isTcLevPoly tc@PromotedDataCon{} = pprPanic "isTcLevPoly datacon" (ppr tc)--{----------------------------------------------------      Expand type-constructor applications--------------------------------------------------}--expandSynTyCon_maybe-        :: TyCon-        -> [tyco]                 -- ^ Arguments to 'TyCon'-        -> Maybe ([(TyVar,tyco)],-                  Type,-                  [tyco])         -- ^ Returns a 'TyVar' substitution, the body-                                  -- type of the synonym (not yet substituted)-                                  -- and any arguments remaining from the-                                  -- application---- ^ Expand a type synonym application, if any-expandSynTyCon_maybe tc tys-  | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc-  = case tys `listLengthCmp` arity of-        GT -> Just (tvs `zip` tys, rhs, drop arity tys)-        EQ -> Just (tvs `zip` tys, rhs, [])-        LT -> Nothing-   | otherwise-   = Nothing---------------------- | Check if the tycon actually refers to a proper `data` or `newtype`---  with user defined constructors rather than one from a class or other---  construction.---- NB: This is only used in TcRnExports.checkPatSynParent to determine if an--- exported tycon can have a pattern synonym bundled with it, e.g.,--- module Foo (TyCon(.., PatSyn)) where-isTyConWithSrcDataCons :: TyCon -> Bool-isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) =-  case rhs of-    DataTyCon {}  -> isSrcParent-    NewTyCon {}   -> isSrcParent-    TupleTyCon {} -> isSrcParent-    _ -> False-  where-    isSrcParent = isNoParent parent-isTyConWithSrcDataCons (FamilyTyCon { famTcFlav = DataFamilyTyCon {} })-                         = True -- #14058-isTyConWithSrcDataCons _ = False----- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no--- constructors could be found-tyConDataCons :: TyCon -> [DataCon]--- It's convenient for tyConDataCons to return the--- empty list for type synonyms etc-tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` []---- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon'--- is the sort that can have any constructors (note: this does not include--- abstract algebraic types)-tyConDataCons_maybe :: TyCon -> Maybe [DataCon]-tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs})-  = case rhs of-       DataTyCon { data_cons = cons } -> Just cons-       NewTyCon { data_con = con }    -> Just [con]-       TupleTyCon { data_con = con }  -> Just [con]-       SumTyCon { data_cons = cons }  -> Just cons-       _                              -> Nothing-tyConDataCons_maybe _ = Nothing---- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@--- type with one alternative, a tuple type or a @newtype@ then that constructor--- is returned. If the 'TyCon' has more than one constructor, or represents a--- primitive or function type constructor then @Nothing@ is returned. In any--- other case, the function panics-tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon-tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs })-  = case rhs of-      DataTyCon { data_cons = [c] } -> Just c-      TupleTyCon { data_con = c }   -> Just c-      NewTyCon { data_con = c }     -> Just c-      _                             -> Nothing-tyConSingleDataCon_maybe _           = Nothing--tyConSingleDataCon :: TyCon -> DataCon-tyConSingleDataCon tc-  = case tyConSingleDataCon_maybe tc of-      Just c  -> c-      Nothing -> pprPanic "tyConDataCon" (ppr tc)--tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon--- Returns (Just con) for single-constructor--- *algebraic* data types *not* newtypes-tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs })-  = case rhs of-      DataTyCon { data_cons = [c] } -> Just c-      TupleTyCon { data_con = c }   -> Just c-      _                             -> Nothing-tyConSingleAlgDataCon_maybe _        = Nothing---- | Determine the number of value constructors a 'TyCon' has. Panics if the--- 'TyCon' is not algebraic or a tuple-tyConFamilySize  :: TyCon -> Int-tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs })-  = case rhs of-      DataTyCon { data_cons_size = size } -> size-      NewTyCon {}                    -> 1-      TupleTyCon {}                  -> 1-      SumTyCon { data_cons_size = size }  -> size-      _                              -> pprPanic "tyConFamilySize 1" (ppr tc)-tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc)---- | Extract an 'AlgTyConRhs' with information about data constructors from an--- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon'-algTyConRhs :: TyCon -> AlgTyConRhs-algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs-algTyConRhs other = pprPanic "algTyConRhs" (ppr other)---- | Extract type variable naming the result of injective type family-tyConFamilyResVar_maybe :: TyCon -> Maybe Name-tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res-tyConFamilyResVar_maybe _                                 = Nothing---- | Get the list of roles for the type parameters of a TyCon-tyConRoles :: TyCon -> [Role]--- See also Note [TyCon Role signatures]-tyConRoles tc-  = case tc of-    { FunTyCon {}                         -> [Nominal, Nominal, Representational, Representational]-    ; AlgTyCon { tcRoles = roles }        -> roles-    ; SynonymTyCon { tcRoles = roles }    -> roles-    ; FamilyTyCon {}                      -> const_role Nominal-    ; PrimTyCon { tcRoles = roles }       -> roles-    ; PromotedDataCon { tcRoles = roles } -> roles-    ; TcTyCon {}                          -> const_role Nominal-    }-  where-    const_role r = replicate (tyConArity tc) r---- | Extract the bound type variables and type expansion of a type synonym--- 'TyCon'. Panics if the 'TyCon' is not a synonym-newTyConRhs :: TyCon -> ([TyVar], Type)-newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }})-    = (tvs, rhs)-newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon)---- | The number of type parameters that need to be passed to a newtype to--- resolve it. May be less than in the definition if it can be eta-contracted.-newTyConEtadArity :: TyCon -> Int-newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }})-        = length (fst tvs_rhs)-newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon)---- | Extract the bound type variables and type expansion of an eta-contracted--- type synonym 'TyCon'.  Panics if the 'TyCon' is not a synonym-newTyConEtadRhs :: TyCon -> ([TyVar], Type)-newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs-newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon)---- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to--- construct something with the @newtype@s type from its representation type--- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns--- @Nothing@-newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched)-newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co-newTyConCo_maybe _                                               = Nothing--newTyConCo :: TyCon -> CoAxiom Unbranched-newTyConCo tc = case newTyConCo_maybe tc of-                 Just co -> co-                 Nothing -> pprPanic "newTyConCo" (ppr tc)--newTyConDataCon_maybe :: TyCon -> Maybe DataCon-newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con-newTyConDataCon_maybe _ = Nothing---- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context--- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration--- @data Eq a => T a ...@-tyConStupidTheta :: TyCon -> [PredType]-tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid-tyConStupidTheta (FunTyCon {}) = []-tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon)---- | Extract the 'TyVar's bound by a vanilla type synonym--- and the corresponding (unsubstituted) right hand side.-synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type)-synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty})-  = Just (tyvars, ty)-synTyConDefn_maybe _ = Nothing---- | Extract the information pertaining to the right hand side of a type synonym--- (@type@) declaration.-synTyConRhs_maybe :: TyCon -> Maybe Type-synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs-synTyConRhs_maybe _                               = Nothing---- | Extract the flavour of a type family (with all the extra information that--- it carries)-famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav-famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav-famTyConFlav_maybe _                                = Nothing---- | Is this 'TyCon' that for a class instance?-isClassTyCon :: TyCon -> Bool-isClassTyCon (AlgTyCon {algTcParent = ClassTyCon {}}) = True-isClassTyCon _                                        = False---- | If this 'TyCon' is that for a class instance, return the class it is for.--- Otherwise returns @Nothing@-tyConClass_maybe :: TyCon -> Maybe Class-tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas _}) = Just clas-tyConClass_maybe _                                            = Nothing---- | Return the associated types of the 'TyCon', if any-tyConATs :: TyCon -> [TyCon]-tyConATs (AlgTyCon {algTcParent = ClassTyCon clas _}) = classATs clas-tyConATs _                                            = []--------------------------------------------------------------------------------- | Is this 'TyCon' that for a data family instance?-isFamInstTyCon :: TyCon -> Bool-isFamInstTyCon (AlgTyCon {algTcParent = DataFamInstTyCon {} })-  = True-isFamInstTyCon _ = False--tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched)-tyConFamInstSig_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax f ts })-  = Just (f, ts, ax)-tyConFamInstSig_maybe _ = Nothing---- | If this 'TyCon' is that of a data family instance, return the family in question--- and the instance types. Otherwise, return @Nothing@-tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])-tyConFamInst_maybe (AlgTyCon {algTcParent = DataFamInstTyCon _ f ts })-  = Just (f, ts)-tyConFamInst_maybe _ = Nothing---- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which--- represents a coercion identifying the representation type with the type--- instance family.  Otherwise, return @Nothing@-tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched)-tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ })-  = Just ax-tyConFamilyCoercion_maybe _ = Nothing---- | Extract any 'RuntimeRepInfo' from this TyCon-tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo-tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri-tyConRuntimeRepInfo _                                         = NoRRI-  -- could panic in that second case. But Douglas Adams told me not to.--{--Note [Constructor tag allocation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When typechecking we need to allocate constructor tags to constructors.-They are allocated based on the position in the data_cons field of TyCon,-with the first constructor getting fIRST_TAG.--We used to pay linear cost per constructor, with each constructor looking up-its relative index in the constructor list. That was quadratic and prohibitive-for large data types with more than 10k constructors.--The current strategy is to build a NameEnv with a mapping from constructor's-Name to ConTag and pass it down to buildDataCon for efficient lookup.--Relevant ticket: #14657--}--mkTyConTagMap :: TyCon -> NameEnv ConTag-mkTyConTagMap tycon =-  mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..]-  -- See Note [Constructor tag allocation]--{--************************************************************************-*                                                                      *-\subsection[TyCon-instances]{Instance declarations for @TyCon@}-*                                                                      *-************************************************************************--@TyCon@s are compared by comparing their @Unique@s.--}--instance Eq TyCon where-    a == b = getUnique a == getUnique b-    a /= b = getUnique a /= getUnique b--instance Uniquable TyCon where-    getUnique tc = tyConUnique tc--instance Outputable TyCon where-  -- At the moment a promoted TyCon has the same Name as its-  -- corresponding TyCon, so we add the quote to distinguish it here-  ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc-    where-      pp_tc = getPprStyle $ \sty -> if ((debugStyle sty || dumpStyle sty) && isTcTyCon tc)-                                    then text "[tc]"-                                    else empty---- | Paints a picture of what a 'TyCon' represents, in broad strokes.--- This is used towards more informative error messages.-data TyConFlavour-  = ClassFlavour-  | TupleFlavour Boxity-  | SumFlavour-  | DataTypeFlavour-  | NewtypeFlavour-  | AbstractTypeFlavour-  | DataFamilyFlavour (Maybe TyCon)     -- Just tc <=> (tc == associated class)-  | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class)-  | ClosedTypeFamilyFlavour-  | TypeSynonymFlavour-  | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'.-  | PromotedDataConFlavour-  deriving Eq--instance Outputable TyConFlavour where-  ppr = text . go-    where-      go ClassFlavour = "class"-      go (TupleFlavour boxed) | isBoxed boxed = "tuple"-                              | otherwise     = "unboxed tuple"-      go SumFlavour              = "unboxed sum"-      go DataTypeFlavour         = "data type"-      go NewtypeFlavour          = "newtype"-      go AbstractTypeFlavour     = "abstract type"-      go (DataFamilyFlavour (Just _))  = "associated data family"-      go (DataFamilyFlavour Nothing)   = "data family"-      go (OpenTypeFamilyFlavour (Just _)) = "associated type family"-      go (OpenTypeFamilyFlavour Nothing)  = "type family"-      go ClosedTypeFamilyFlavour = "type family"-      go TypeSynonymFlavour      = "type synonym"-      go BuiltInTypeFlavour      = "built-in type"-      go PromotedDataConFlavour  = "promoted data constructor"--tyConFlavour :: TyCon -> TyConFlavour-tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs })-  | ClassTyCon _ _ <- parent = ClassFlavour-  | otherwise = case rhs of-                  TupleTyCon { tup_sort = sort }-                                     -> TupleFlavour (tupleSortBoxity sort)-                  SumTyCon {}        -> SumFlavour-                  DataTyCon {}       -> DataTypeFlavour-                  NewTyCon {}        -> NewtypeFlavour-                  AbstractTyCon {}   -> AbstractTypeFlavour-tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent })-  = case flav of-      DataFamilyTyCon{}            -> DataFamilyFlavour parent-      OpenSynFamilyTyCon           -> OpenTypeFamilyFlavour parent-      ClosedSynFamilyTyCon{}       -> ClosedTypeFamilyFlavour-      AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour-      BuiltInSynFamTyCon{}         -> ClosedTypeFamilyFlavour-tyConFlavour (SynonymTyCon {})    = TypeSynonymFlavour-tyConFlavour (FunTyCon {})        = BuiltInTypeFlavour-tyConFlavour (PrimTyCon {})       = BuiltInTypeFlavour-tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour-tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav---- | Can this flavour of 'TyCon' appear unsaturated?-tcFlavourMustBeSaturated :: TyConFlavour -> Bool-tcFlavourMustBeSaturated ClassFlavour            = False-tcFlavourMustBeSaturated DataTypeFlavour         = False-tcFlavourMustBeSaturated NewtypeFlavour          = False-tcFlavourMustBeSaturated DataFamilyFlavour{}     = False-tcFlavourMustBeSaturated TupleFlavour{}          = False-tcFlavourMustBeSaturated SumFlavour              = False-tcFlavourMustBeSaturated AbstractTypeFlavour     = False-tcFlavourMustBeSaturated BuiltInTypeFlavour      = False-tcFlavourMustBeSaturated PromotedDataConFlavour  = False-tcFlavourMustBeSaturated TypeSynonymFlavour      = True-tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True-tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True---- | Is this flavour of 'TyCon' an open type family or a data family?-tcFlavourIsOpen :: TyConFlavour -> Bool-tcFlavourIsOpen DataFamilyFlavour{}     = True-tcFlavourIsOpen OpenTypeFamilyFlavour{} = True-tcFlavourIsOpen ClosedTypeFamilyFlavour = False-tcFlavourIsOpen ClassFlavour            = False-tcFlavourIsOpen DataTypeFlavour         = False-tcFlavourIsOpen NewtypeFlavour          = False-tcFlavourIsOpen TupleFlavour{}          = False-tcFlavourIsOpen SumFlavour              = False-tcFlavourIsOpen AbstractTypeFlavour     = False-tcFlavourIsOpen BuiltInTypeFlavour      = False-tcFlavourIsOpen PromotedDataConFlavour  = False-tcFlavourIsOpen TypeSynonymFlavour      = False--pprPromotionQuote :: TyCon -> SDoc--- Promoted data constructors already have a tick in their OccName-pprPromotionQuote tc-  = case tc of-      PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types-      _                  -> empty--instance NamedThing TyCon where-    getName = tyConName--instance Data.Data TyCon where-    -- don't traverse?-    toConstr _   = abstractConstr "TyCon"-    gunfold _ _  = error "gunfold"-    dataTypeOf _ = mkNoRepType "TyCon"--instance Binary Injectivity where-    put_ bh NotInjective   = putByte bh 0-    put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs--    get bh = do { h <- getByte bh-                ; case h of-                    0 -> return NotInjective-                    _ -> do { xs <- get bh-                            ; return (Injective xs) } }--{--************************************************************************-*                                                                      *-           Walking over recursive TyCons-*                                                                      *-************************************************************************--Note [Expanding newtypes and products]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When expanding a type to expose a data-type constructor, we need to be-careful about newtypes, lest we fall into an infinite loop. Here are-the key examples:--  newtype Id  x = MkId x-  newtype Fix f = MkFix (f (Fix f))-  newtype T     = MkT (T -> T)--  Type           Expansion- ---------------------------  T              T -> T-  Fix Maybe      Maybe (Fix Maybe)-  Id (Id Int)    Int-  Fix Id         NO NO NO--Notice that- * We can expand T, even though it's recursive.- * We can expand Id (Id Int), even though the Id shows up-   twice at the outer level, because Id is non-recursive--So, when expanding, we keep track of when we've seen a recursive-newtype at outermost level; and bail out if we see it again.--We sometimes want to do the same for product types, so that the-strictness analyser doesn't unbox infinitely deeply.--More precisely, we keep a *count* of how many times we've seen it.-This is to account for-   data instance T (a,b) = MkT (T a) (T b)-Then (#10482) if we have a type like-        T (Int,(Int,(Int,(Int,Int))))-we can still unbox deeply enough during strictness analysis.-We have to treat T as potentially recursive, but it's still-good to be able to unwrap multiple layers.--The function that manages all this is checkRecTc.--}--data RecTcChecker = RC !Int (NameEnv Int)-  -- The upper bound, and the number of times-  -- we have encountered each TyCon---- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'.-initRecTc :: RecTcChecker-initRecTc = RC defaultRecTcMaxBound emptyNameEnv---- | The default upper bound (100) for the number of times a 'RecTcChecker' is--- allowed to encounter each 'TyCon'.-defaultRecTcMaxBound :: Int-defaultRecTcMaxBound = 100--- Should we have a flag for this?---- | Change the upper bound for the number of times a 'RecTcChecker' is allowed--- to encounter each 'TyCon'.-setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker-setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts--checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker--- Nothing      => Recursion detected--- Just rec_tcs => Keep going-checkRecTc (RC bound rec_nts) tc-  = case lookupNameEnv rec_nts tc_name of-      Just n | n >= bound -> Nothing-             | otherwise  -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1)))-      Nothing             -> Just (RC bound (extendNameEnv rec_nts tc_name 1))-  where-    tc_name = tyConName tc---- | Returns whether or not this 'TyCon' is definite, or a hole--- that may be filled in at some later point.  See Note [Skolem abstract data]-tyConSkolem :: TyCon -> Bool-tyConSkolem = isHoleName . tyConName---- Note [Skolem abstract data]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Skolem abstract data arises from data declarations in an hsig file.------ The best analogy is to interpret the types declared in signature files as--- elaborating to universally quantified type variables; e.g.,------    unit p where---        signature H where---            data T---            data S---        module M where---            import H---            f :: (T ~ S) => a -> b---            f x = x------ elaborates as (with some fake structural types):------    p :: forall t s. { f :: forall a b. t ~ s => a -> b }---    p = { f = \x -> x } -- ill-typed------ It is clear that inside p, t ~ s is not provable (and--- if we tried to write a function to cast t to s, that--- would not work), but if we call p @Int @Int, clearly Int ~ Int--- is provable.  The skolem variables are all distinct from--- one another, but we can't make assumptions like "f is--- inaccessible", because the skolem variables will get--- instantiated eventually!------ Skolem abstractness can apply to "non-abstract" data as well):------    unit p where---        signature H1 where---            data T = MkT---        signature H2 where---            data T = MkT---        module M where---            import qualified H1---            import qualified H2---            f :: (H1.T ~ H2.T) => a -> b---            f x = x------ This is why the test is on the original name of the TyCon,--- not whether it is abstract or not.
− compiler/types/TyCon.hs-boot 
@@ -1,9 +0,0 @@-module TyCon where--import GhcPrelude--data TyCon--isTupleTyCon        :: TyCon -> Bool-isUnboxedTupleTyCon :: TyCon -> Bool-isFunTyCon          :: TyCon -> Bool
− compiler/types/Type.hs 
@@ -1,3229 +0,0 @@--- (c) The University of Glasgow 2006--- (c) The GRASP/AQUA Project, Glasgow University, 1998------ Type - public interface--{-# LANGUAGE CPP, FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}---- | Main functions for manipulating types and type-related things-module Type (-        -- Note some of this is just re-exports from TyCon..--        -- * Main data types representing Types-        -- $type_classification--        -- $representation_types-        TyThing(..), Type, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..),-        KindOrType, PredType, ThetaType,-        Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder,-        KnotTied,--        -- ** Constructing and deconstructing types-        mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe,-        getCastedTyVar_maybe, tyVarKind, varType,--        mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys,-        splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe,--        mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys,-        splitFunTy, splitFunTy_maybe,-        splitFunTys, funResultTy, funArgTy,--        mkTyConApp, mkTyConTy,-        tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,-        tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,-        splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole,-        tcSplitTyConApp_maybe,-        splitListTyConApp_maybe,-        repSplitTyConApp_maybe,--        mkForAllTy, mkForAllTys, mkTyCoInvForAllTys,-        mkSpecForAllTy, mkSpecForAllTys,-        mkVisForAllTys, mkTyCoInvForAllTy,-        mkInvForAllTy, mkInvForAllTys,-        splitForAllTys, splitForAllTysSameVis,-        splitForAllVarBndrs,-        splitForAllTy_maybe, splitForAllTy,-        splitForAllTy_ty_maybe, splitForAllTy_co_maybe,-        splitPiTy_maybe, splitPiTy, splitPiTys,-        mkTyConBindersPreferAnon,-        mkPiTy, mkPiTys,-        mkLamType, mkLamTypes,-        piResultTy, piResultTys,-        applyTysX, dropForAlls,-        mkFamilyTyConApp,-        buildSynTyCon,--        mkNumLitTy, isNumLitTy,-        mkStrLitTy, isStrLitTy,-        isLitTy,--        isPredTy,--        getRuntimeRep_maybe, kindRep_maybe, kindRep,--        mkCastTy, mkCoercionTy, splitCastTy_maybe,-        discardCast,--        userTypeError_maybe, pprUserTypeErrorTy,--        coAxNthLHS,-        stripCoercionTy,--        splitPiTysInvisible, splitPiTysInvisibleN,-        invisibleTyBndrCount,-        filterOutInvisibleTypes, filterOutInferredTypes,-        partitionInvisibleTypes, partitionInvisibles,-        tyConArgFlags, appTyArgFlags,-        synTyConResKind,--        modifyJoinResTy, setJoinResTy,--        -- ** Analyzing types-        TyCoMapper(..), mapType, mapCoercion,-        TyCoFolder(..), foldTyCo,--        -- (Newtypes)-        newTyConInstRhs,--        -- ** Binders-        sameVis,-        mkTyCoVarBinder, mkTyCoVarBinders,-        mkTyVarBinders,-        mkAnonBinder,-        isAnonTyCoBinder,-        binderVar, binderVars, binderType, binderArgFlag,-        tyCoBinderType, tyCoBinderVar_maybe,-        tyBinderType,-        binderRelevantType_maybe,-        isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder,-        isInvisibleBinder, isNamedBinder,-        tyConBindersTyCoBinders,--        -- ** Common type constructors-        funTyCon,--        -- ** Predicates on types-        isTyVarTy, isFunTy, isCoercionTy,-        isCoercionTy_maybe, isForAllTy,-        isForAllTy_ty, isForAllTy_co,-        isPiTy, isTauTy, isFamFreeTy,-        isCoVarType,--        isValidJoinPointType,-        tyConAppNeedsKindSig,--        -- *** Levity and boxity-        isLiftedType_maybe,-        isLiftedTypeKind, isUnliftedTypeKind,-        isLiftedRuntimeRep, isUnliftedRuntimeRep,-        isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType,-        isAlgType, isDataFamilyAppType,-        isPrimitiveType, isStrictType,-        isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,-        dropRuntimeRepArgs,-        getRuntimeRep,--        -- * Main data types representing Kinds-        Kind,--        -- ** Finding the kind of a type-        typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly,-        tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind,-        tcIsRuntimeTypeKind,--        -- ** Common Kind-        liftedTypeKind,--        -- * Type free variables-        tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs,-        tyCoVarsOfType, tyCoVarsOfTypes,-        tyCoVarsOfTypeDSet,-        coVarsOfType,-        coVarsOfTypes,--        noFreeVarsOfType,-        splitVisVarsOfType, splitVisVarsOfTypes,-        expandTypeSynonyms,-        typeSize, occCheckExpand,--        -- ** Closing over kinds-        closeOverKindsDSet, closeOverKindsList,-        closeOverKinds,--        -- * Well-scoped lists of variables-        scopedSort, tyCoVarsOfTypeWellScoped,-        tyCoVarsOfTypesWellScoped,--        -- * Type comparison-        eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX,-        nonDetCmpTypesX, nonDetCmpTc,-        eqVarBndrs,--        -- * Forcing evaluation of types-        seqType, seqTypes,--        -- * Other views onto Types-        coreView, tcView,--        tyConsOfType,--        -- * Main type substitution data types-        TvSubstEnv,     -- Representation widely visible-        TCvSubst(..),    -- Representation visible to a few friends--        -- ** Manipulating type substitutions-        emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst,--        mkTCvSubst, zipTvSubst, mkTvSubstPrs,-        zipTCvSubst,-        notElemTCvSubst,-        getTvSubstEnv, setTvSubstEnv,-        zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs,-        extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet,-        extendTCvSubst, extendCvSubst,-        extendTvSubst, extendTvSubstBinderAndInScope,-        extendTvSubstList, extendTvSubstAndInScope,-        extendTCvSubstList,-        extendTvSubstWithClone,-        extendTCvSubstWithClone,-        isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv,-        isEmptyTCvSubst, unionTCvSubst,--        -- ** Performing substitution on types and kinds-        substTy, substTys, substTyWith, substTysWith, substTheta,-        substTyAddInScope,-        substTyUnchecked, substTysUnchecked, substThetaUnchecked,-        substTyWithUnchecked,-        substCoUnchecked, substCoWithUnchecked,-        substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,-        substVarBndr, substVarBndrs,-        cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,--        -- * Tidying type related things up for printing-        tidyType,      tidyTypes,-        tidyOpenType,  tidyOpenTypes,-        tidyOpenKind,-        tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars,-        tidyOpenTyCoVar, tidyOpenTyCoVars,-        tidyTyCoVarOcc,-        tidyTopType,-        tidyKind,-        tidyTyCoVarBinder, tidyTyCoVarBinders,--        -- * Kinds-        isConstraintKindCon,-        classifiesTypeWithValues,-        isKindLevPoly-    ) where--#include "HsVersions.h"--import GhcPrelude--import BasicTypes---- We import the representation and primitive functions from TyCoRep.--- Many things are reexported, but not the representation!--import TyCoRep-import TyCoSubst-import TyCoTidy-import TyCoFVs---- friends:-import Var-import VarEnv-import VarSet-import UniqSet--import TyCon-import TysPrim-import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind-                                 , typeSymbolKind, liftedTypeKind-                                 , liftedTypeKindTyCon-                                 , constraintKind )-import Name( Name )-import PrelNames-import CoAxiom-import {-# SOURCE #-} Coercion( mkNomReflCo, mkGReflCo, mkReflCo-                              , mkTyConAppCo, mkAppCo, mkCoVarCo, mkAxiomRuleCo-                              , mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo-                              , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo-                              , mkKindCo, mkSubCo, mkFunCo, mkAxiomInstCo-                              , decomposePiCos, coercionKind, coercionLKind-                              , coercionRKind, coercionType-                              , isReflexiveCo, seqCo )---- others-import Util-import FV-import Outputable-import FastString-import Pair-import ListSetOps-import Unique ( nonDetCmpUnique )--import Maybes           ( orElse )-import Data.Maybe       ( isJust )-import Control.Monad    ( guard )---- $type_classification--- #type_classification#------ Types are one of:------ [Unboxed]            Iff its representation is other than a pointer---                      Unboxed types are also unlifted.------ [Lifted]             Iff it has bottom as an element.---                      Closures always have lifted types: i.e. any---                      let-bound identifier in Core must have a lifted---                      type. Operationally, a lifted object is one that---                      can be entered.---                      Only lifted types may be unified with a type variable.------ [Algebraic]          Iff it is a type with one or more constructors, whether---                      declared with @data@ or @newtype@.---                      An algebraic type is one that can be deconstructed---                      with a case expression. This is /not/ the same as---                      lifted types, because we also include unboxed---                      tuples in this classification.------ [Data]               Iff it is a type declared with @data@, or a boxed tuple.------ [Primitive]          Iff it is a built-in type that can't be expressed in Haskell.------ Currently, all primitive types are unlifted, but that's not necessarily--- the case: for example, @Int@ could be primitive.------ Some primitive types are unboxed, such as @Int#@, whereas some are boxed--- but unlifted (such as @ByteArray#@).  The only primitive types that we--- classify as algebraic are the unboxed tuples.------ Some examples of type classifications that may make this a bit clearer are:------ @--- Type          primitive       boxed           lifted          algebraic--- -------------------------------------------------------------------------------- Int#          Yes             No              No              No--- ByteArray#    Yes             Yes             No              No--- (\# a, b \#)  Yes             No              No              Yes--- (\# a | b \#) Yes             No              No              Yes--- (  a, b  )    No              Yes             Yes             Yes--- [a]           No              Yes             Yes             Yes--- @---- $representation_types--- A /source type/ is a type that is a separate type as far as the type checker is--- concerned, but which has a more low-level representation as far as Core-to-Core--- passes and the rest of the back end is concerned.------ You don't normally have to worry about this, as the utility functions in--- this module will automatically convert a source into a representation type--- if they are spotted, to the best of its abilities. If you don't want this--- to happen, use the equivalent functions from the "TcType" module.--{--************************************************************************-*                                                                      *-                Type representation-*                                                                      *-************************************************************************--Note [coreView vs tcView]-~~~~~~~~~~~~~~~~~~~~~~~~~-So far as the typechecker is concerned, 'Constraint' and 'TYPE-LiftedRep' are distinct kinds.--But in Core these two are treated as identical.--We implement this by making 'coreView' convert 'Constraint' to 'TYPE-LiftedRep' on the fly.  The function tcView (used in the type checker)-does not do this.--See also #11715, which tracks removing this inconsistency.---}---- | Gives the typechecker view of a type. This unwraps synonyms but--- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into--- TYPE LiftedRep. Returns Nothing if no unwrapping happens.--- See also Note [coreView vs tcView]-{-# INLINE tcView #-}-tcView :: Type -> Maybe Type-tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys-  = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')-               -- The free vars of 'rhs' should all be bound by 'tenv', so it's-               -- ok to use 'substTy' here.-               -- See also Note [The substitution invariant] in TyCoSubst.-               -- Its important to use mkAppTys, rather than (foldl AppTy),-               -- because the function part might well return a-               -- partially-applied type constructor; indeed, usually will!-tcView _ = Nothing--{-# INLINE coreView #-}-coreView :: Type -> Maybe Type--- ^ This function Strips off the /top layer only/ of a type synonym--- application (if any) its underlying representation type.--- Returns Nothing if there is nothing to look through.--- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@.------ By being non-recursive and inlined, this case analysis gets efficiently--- joined onto the case analysis that the caller is already doing-coreView ty@(TyConApp tc tys)-  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys-  = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')-    -- This equation is exactly like tcView--  -- At the Core level, Constraint = Type-  -- See Note [coreView vs tcView]-  | isConstraintKindCon tc-  = ASSERT2( null tys, ppr ty )-    Just liftedTypeKind--coreView _ = Nothing--------------------------------------------------expandTypeSynonyms :: Type -> Type--- ^ Expand out all type synonyms.  Actually, it'd suffice to expand out--- just the ones that discard type variables (e.g.  type Funny a = Int)--- But we don't know which those are currently, so we just expand all.------ 'expandTypeSynonyms' only expands out type synonyms mentioned in the type,--- not in the kinds of any TyCon or TyVar mentioned in the type.------ Keep this synchronized with 'synonymTyConsOfType'-expandTypeSynonyms ty-  = go (mkEmptyTCvSubst in_scope) ty-  where-    in_scope = mkInScopeSet (tyCoVarsOfType ty)--    go subst (TyConApp tc tys)-      | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys-      = let subst' = mkTvSubst in_scope (mkVarEnv tenv)-            -- Make a fresh substitution; rhs has nothing to-            -- do with anything that has happened so far-            -- NB: if you make changes here, be sure to build an-            --     /idempotent/ substitution, even in the nested case-            --        type T a b = a -> b-            --        type S x y = T y x-            -- (#11665)-        in  mkAppTys (go subst' rhs) tys'-      | otherwise-      = TyConApp tc expanded_tys-      where-        expanded_tys = (map (go subst) tys)--    go _     (LitTy l)     = LitTy l-    go subst (TyVarTy tv)  = substTyVar subst tv-    go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2)-    go subst ty@(FunTy _ arg res)-      = ty { ft_arg = go subst arg, ft_res = go subst res }-    go subst (ForAllTy (Bndr tv vis) t)-      = let (subst', tv') = substVarBndrUsing go subst tv in-        ForAllTy (Bndr tv' vis) (go subst' t)-    go subst (CastTy ty co)  = mkCastTy (go subst ty) (go_co subst co)-    go subst (CoercionTy co) = mkCoercionTy (go_co subst co)--    go_mco _     MRefl    = MRefl-    go_mco subst (MCo co) = MCo (go_co subst co)--    go_co subst (Refl ty)-      = mkNomReflCo (go subst ty)-    go_co subst (GRefl r ty mco)-      = mkGReflCo r (go subst ty) (go_mco subst mco)-       -- NB: coercions are always expanded upon creation-    go_co subst (TyConAppCo r tc args)-      = mkTyConAppCo r tc (map (go_co subst) args)-    go_co subst (AppCo co arg)-      = mkAppCo (go_co subst co) (go_co subst arg)-    go_co subst (ForAllCo tv kind_co co)-      = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in-        mkForAllCo tv' kind_co' (go_co subst' co)-    go_co subst (FunCo r co1 co2)-      = mkFunCo r (go_co subst co1) (go_co subst co2)-    go_co subst (CoVarCo cv)-      = substCoVar subst cv-    go_co subst (AxiomInstCo ax ind args)-      = mkAxiomInstCo ax ind (map (go_co subst) args)-    go_co subst (UnivCo p r t1 t2)-      = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2)-    go_co subst (SymCo co)-      = mkSymCo (go_co subst co)-    go_co subst (TransCo co1 co2)-      = mkTransCo (go_co subst co1) (go_co subst co2)-    go_co subst (NthCo r n co)-      = mkNthCo r n (go_co subst co)-    go_co subst (LRCo lr co)-      = mkLRCo lr (go_co subst co)-    go_co subst (InstCo co arg)-      = mkInstCo (go_co subst co) (go_co subst arg)-    go_co subst (KindCo co)-      = mkKindCo (go_co subst co)-    go_co subst (SubCo co)-      = mkSubCo (go_co subst co)-    go_co subst (AxiomRuleCo ax cs)-      = AxiomRuleCo ax (map (go_co subst) cs)-    go_co _ (HoleCo h)-      = pprPanic "expandTypeSynonyms hit a hole" (ppr h)--    go_prov subst (PhantomProv co)    = PhantomProv (go_co subst co)-    go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co)-    go_prov _     p@(PluginProv _)    = p--      -- the "False" and "const" are to accommodate the type of-      -- substForAllCoBndrUsing, which is general enough to-      -- handle coercion optimization (which sometimes swaps the-      -- order of a coercion)-    go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst----- | Extract the RuntimeRep classifier of a type from its kind. For example,--- @kindRep * = LiftedRep@; Panics if this is not possible.--- Treats * and Constraint as the same-kindRep :: HasDebugCallStack => Kind -> Type-kindRep k = case kindRep_maybe k of-              Just r  -> r-              Nothing -> pprPanic "kindRep" (ppr k)---- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr.--- For example, @kindRep_maybe * = Just LiftedRep@--- Returns 'Nothing' if the kind is not of form (TYPE rr)--- Treats * and Constraint as the same-kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type-kindRep_maybe kind-  | Just kind' <- coreView kind = kindRep_maybe kind'-  | TyConApp tc [arg] <- kind-  , tc `hasKey` tYPETyConKey    = Just arg-  | otherwise                   = Nothing---- | This version considers Constraint to be the same as *. Returns True--- if the argument is equivalent to Type/Constraint and False otherwise.--- See Note [Kind Constraint and kind Type]-isLiftedTypeKind :: Kind -> Bool-isLiftedTypeKind kind-  = case kindRep_maybe kind of-      Just rep -> isLiftedRuntimeRep rep-      Nothing  -> False--isLiftedRuntimeRep :: Type -> Bool--- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep--- False of type variables (a :: RuntimeRep)---   and of other reps e.g. (IntRep :: RuntimeRep)-isLiftedRuntimeRep rep-  | Just rep' <- coreView rep          = isLiftedRuntimeRep rep'-  | TyConApp rr_tc args <- rep-  , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True-  | otherwise                          = False---- | Returns True if the kind classifies unlifted types and False otherwise.--- Note that this returns False for levity-polymorphic kinds, which may--- be specialized to a kind that classifies unlifted types.-isUnliftedTypeKind :: Kind -> Bool-isUnliftedTypeKind kind-  = case kindRep_maybe kind of-      Just rep -> isUnliftedRuntimeRep rep-      Nothing  -> False--isUnliftedRuntimeRep :: Type -> Bool--- True of definitely-unlifted RuntimeReps--- False of           (LiftedRep :: RuntimeRep)---   and of variables (a :: RuntimeRep)-isUnliftedRuntimeRep rep-  | Just rep' <- coreView rep = isUnliftedRuntimeRep rep'-  | TyConApp rr_tc _ <- rep   -- NB: args might be non-empty-                              --     e.g. TupleRep [r1, .., rn]-  = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey)-        -- Avoid searching all the unlifted RuntimeRep type cons-        -- In the RuntimeRep data type, only LiftedRep is lifted-        -- But be careful of type families (F tys) :: RuntimeRep-  | otherwise {- Variables, applications -}-  = False---- | Is this the type 'RuntimeRep'?-isRuntimeRepTy :: Type -> Bool-isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty'-isRuntimeRepTy (TyConApp tc args)-  | tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True-isRuntimeRepTy _ = False---- | Is a tyvar of type 'RuntimeRep'?-isRuntimeRepVar :: TyVar -> Bool-isRuntimeRepVar = isRuntimeRepTy . tyVarKind---{- *********************************************************************-*                                                                      *-               mapType-*                                                                      *-************************************************************************--These functions do a map-like operation over types, performing some operation-on all variables and binding sites. Primarily used for zonking.--Note [Efficiency for mapCoercion ForAllCo case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As noted in Note [Forall coercions] in TyCoRep, a ForAllCo is a bit redundant.-It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches-the left-hand kind of the coercion. This is convenient lots of the time, but-not when mapping a function over a coercion.--The problem is that tcm_tybinder will affect the TyCoVar's kind and-mapCoercion will affect the Coercion, and we hope that the results will be-the same. Even if they are the same (which should generally happen with-correct algorithms), then there is an efficiency issue. In particular,-this problem seems to make what should be a linear algorithm into a potentially-exponential one. But it's only going to be bad in the case where there's-lots of foralls in the kinds of other foralls. Like this:--  forall a : (forall b : (forall c : ...). ...). ...--This construction seems unlikely. So we'll do the inefficient, easy way-for now.--Note [Specialising mappers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-These INLINABLE pragmas are indispensable. mapType/mapCoercion are used-to implement zonking, and it's vital that they get specialised to the TcM-monad. This specialisation happens automatically (that is, without a-SPECIALISE pragma) as long as the definitions are INLINABLE. For example,-this one change made a 20% allocation difference in perf/compiler/T5030.---}---- | This describes how a "map" operation over a type/coercion should behave-data TyCoMapper env m-  = TyCoMapper-      { tcm_tyvar :: env -> TyVar -> m Type-      , tcm_covar :: env -> CoVar -> m Coercion-      , tcm_hole  :: env -> CoercionHole -> m Coercion-          -- ^ What to do with coercion holes.-          -- See Note [Coercion holes] in TyCoRep.--      , tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar)-          -- ^ The returned env is used in the extended scope--      , tcm_tycon :: TyCon -> m TyCon-          -- ^ This is used only for TcTyCons-          -- a) To zonk TcTyCons-          -- b) To turn TcTyCons into TyCons.-          --    See Note [Type checking recursive type and class declarations]-          --    in TcTyClsDecls-      }--{-# INLINABLE mapType #-}  -- See Note [Specialising mappers]-mapType :: Monad m => TyCoMapper env m -> env -> Type -> m Type-mapType mapper@(TyCoMapper { tcm_tyvar = tyvar-                           , tcm_tycobinder = tycobinder-                           , tcm_tycon = tycon })-        env ty-  = go ty-  where-    go (TyVarTy tv)    = tyvar env tv-    go (AppTy t1 t2)   = mkAppTy <$> go t1 <*> go t2-    go ty@(LitTy {})   = return ty-    go (CastTy ty co)  = mkCastTy <$> go ty <*> mapCoercion mapper env co-    go (CoercionTy co) = CoercionTy <$> mapCoercion mapper env co--    go ty@(FunTy _ arg res)-      = do { arg' <- go arg; res' <- go res-           ; return (ty { ft_arg = arg', ft_res = res' }) }--    go ty@(TyConApp tc tys)-      | isTcTyCon tc-      = do { tc' <- tycon tc-           ; mkTyConApp tc' <$> mapM go tys }--      -- Not a TcTyCon-      | null tys    -- Avoid allocation in this very-      = return ty   -- common case (E.g. Int, LiftedRep etc)--      | otherwise-      = mkTyConApp tc <$> mapM go tys--    go (ForAllTy (Bndr tv vis) inner)-      = do { (env', tv') <- tycobinder env tv vis-           ; inner' <- mapType mapper env' inner-           ; return $ ForAllTy (Bndr tv' vis) inner' }--{-# INLINABLE mapCoercion #-}  -- See Note [Specialising mappers]-mapCoercion :: Monad m-            => TyCoMapper env m -> env -> Coercion -> m Coercion-mapCoercion mapper@(TyCoMapper { tcm_covar = covar-                               , tcm_hole = cohole-                               , tcm_tycobinder = tycobinder-                               , tcm_tycon = tycon })-            env co-  = go co-  where-    go_mco MRefl    = return MRefl-    go_mco (MCo co) = MCo <$> (go co)--    go (Refl ty) = Refl <$> mapType mapper env ty-    go (GRefl r ty mco) = mkGReflCo r <$> mapType mapper env ty <*> (go_mco mco)-    go (TyConAppCo r tc args)-      = do { tc' <- if isTcTyCon tc-                    then tycon tc-                    else return tc-           ; mkTyConAppCo r tc' <$> mapM go args }-    go (AppCo c1 c2) = mkAppCo <$> go c1 <*> go c2-    go (ForAllCo tv kind_co co)-      = do { kind_co' <- go kind_co-           ; (env', tv') <- tycobinder env tv Inferred-           ; co' <- mapCoercion mapper env' co-           ; return $ mkForAllCo tv' kind_co' co' }-        -- See Note [Efficiency for mapCoercion ForAllCo case]-    go (FunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2-    go (CoVarCo cv) = covar env cv-    go (AxiomInstCo ax i args)-      = mkAxiomInstCo ax i <$> mapM go args-    go (HoleCo hole) = cohole env hole-    go (UnivCo p r t1 t2)-      = mkUnivCo <$> go_prov p <*> pure r-                 <*> mapType mapper env t1 <*> mapType mapper env t2-    go (SymCo co) = mkSymCo <$> go co-    go (TransCo c1 c2) = mkTransCo <$> go c1 <*> go c2-    go (AxiomRuleCo r cos) = AxiomRuleCo r <$> mapM go cos-    go (NthCo r i co)      = mkNthCo r i <$> go co-    go (LRCo lr co)        = mkLRCo lr <$> go co-    go (InstCo co arg)     = mkInstCo <$> go co <*> go arg-    go (KindCo co)         = mkKindCo <$> go co-    go (SubCo co)          = mkSubCo <$> go co--    go_prov (PhantomProv co)    = PhantomProv <$> go co-    go_prov (ProofIrrelProv co) = ProofIrrelProv <$> go co-    go_prov p@(PluginProv _)    = return p---{--************************************************************************-*                                                                      *-\subsection{Constructor-specific functions}-*                                                                      *-************************************************************************-------------------------------------------------------------------------                                TyVarTy-                                ~~~~~~~--}---- | Attempts to obtain the type variable underlying a 'Type', and panics with the--- given message if this is not a type variable type. See also 'getTyVar_maybe'-getTyVar :: String -> Type -> TyVar-getTyVar msg ty = case getTyVar_maybe ty of-                    Just tv -> tv-                    Nothing -> panic ("getTyVar: " ++ msg)--isTyVarTy :: Type -> Bool-isTyVarTy ty = isJust (getTyVar_maybe ty)---- | Attempts to obtain the type variable underlying a 'Type'-getTyVar_maybe :: Type -> Maybe TyVar-getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty'-                  | otherwise               = repGetTyVar_maybe ty---- | If the type is a tyvar, possibly under a cast, returns it, along--- with the coercion. Thus, the co is :: kind tv ~N kind ty-getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN)-getCastedTyVar_maybe ty | Just ty' <- coreView ty = getCastedTyVar_maybe ty'-getCastedTyVar_maybe (CastTy (TyVarTy tv) co)     = Just (tv, co)-getCastedTyVar_maybe (TyVarTy tv)-  = Just (tv, mkReflCo Nominal (tyVarKind tv))-getCastedTyVar_maybe _                            = Nothing---- | Attempts to obtain the type variable underlying a 'Type', without--- any expansion-repGetTyVar_maybe :: Type -> Maybe TyVar-repGetTyVar_maybe (TyVarTy tv) = Just tv-repGetTyVar_maybe _            = Nothing--{------------------------------------------------------------------------                                AppTy-                                ~~~~~-We need to be pretty careful with AppTy to make sure we obey the-invariant that a TyConApp is always visibly so.  mkAppTy maintains the-invariant: use it.--Note [Decomposing fat arrow c=>t]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Can we unify (a b) with (Eq a => ty)?   If we do so, we end up with-a partial application like ((=>) Eq a) which doesn't make sense in-source Haskell.  In contrast, we *can* unify (a b) with (t1 -> t2).-Here's an example (#9858) of how you might do it:-   i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep-   i p = typeRep p--   j = i (Proxy :: Proxy (Eq Int => Int))-The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes,-but suppose we want that.  But then in the call to 'i', we end-up decomposing (Eq Int => Int), and we definitely don't want that.--This really only applies to the type checker; in Core, '=>' and '->'-are the same, as are 'Constraint' and '*'.  But for now I've put-the test in repSplitAppTy_maybe, which applies throughout, because-the other calls to splitAppTy are in Unify, which is also used by-the type checker (e.g. when matching type-function equations).---}---- | Applies a type to another, as in e.g. @k a@-mkAppTy :: Type -> Type -> Type-  -- See Note [Respecting definitional equality], invariant (EQ1).-mkAppTy (CastTy fun_ty co) arg_ty-  | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty]-  = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co--mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2])-mkAppTy ty1               ty2 = AppTy ty1 ty2-        -- Note that the TyConApp could be an-        -- under-saturated type synonym.  GHC allows that; e.g.-        --      type Foo k = k a -> k a-        --      type Id x = x-        --      foo :: Foo Id -> Foo Id-        ---        -- Here Id is partially applied in the type sig for Foo,-        -- but once the type synonyms are expanded all is well-        ---        -- Moreover in TcHsTypes.tcInferApps we build up a type-        --   (T t1 t2 t3) one argument at a type, thus forming-        --   (T t1), (T t1 t2), etc--mkAppTys :: Type -> [Type] -> Type-mkAppTys ty1                []   = ty1-mkAppTys (CastTy fun_ty co) arg_tys  -- much more efficient then nested mkAppTy-                                     -- Why do this? See (EQ1) of-                                     -- Note [Respecting definitional equality]-                                     -- in TyCoRep-  = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers-  where-    (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys-    (args_to_cast, leftovers) = splitAtList arg_cos arg_tys-    casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos-mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2)-mkAppTys ty1                tys2 = foldl' AppTy ty1 tys2----------------splitAppTy_maybe :: Type -> Maybe (Type, Type)--- ^ Attempt to take a type application apart, whether it is a--- function, type constructor, or plain type application. Note--- that type family applications are NEVER unsaturated by this!-splitAppTy_maybe ty | Just ty' <- coreView ty-                    = splitAppTy_maybe ty'-splitAppTy_maybe ty = repSplitAppTy_maybe ty----------------repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type)--- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that--- any Core view stuff is already done-repSplitAppTy_maybe (FunTy _ ty1 ty2)-  = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2)-  where-    rep1 = getRuntimeRep ty1-    rep2 = getRuntimeRep ty2--repSplitAppTy_maybe (AppTy ty1 ty2)-  = Just (ty1, ty2)--repSplitAppTy_maybe (TyConApp tc tys)-  | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc-  , Just (tys', ty') <- snocView tys-  = Just (TyConApp tc tys', ty')    -- Never create unsaturated type family apps!--repSplitAppTy_maybe _other = Nothing---- This one doesn't break apart (c => t).--- See Note [Decomposing fat arrow c=>t]--- Defined here to avoid module loops between Unify and TcType.-tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type)--- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that--- any coreView stuff is already done. Refuses to look through (c => t)-tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 })-  | InvisArg <- af-  = Nothing  -- See Note [Decomposing fat arrow c=>t]--  | otherwise-  = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2)-  where-    rep1 = getRuntimeRep ty1-    rep2 = getRuntimeRep ty2--tcRepSplitAppTy_maybe (AppTy ty1 ty2)    = Just (ty1, ty2)-tcRepSplitAppTy_maybe (TyConApp tc tys)-  | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc-  , Just (tys', ty') <- snocView tys-  = Just (TyConApp tc tys', ty')    -- Never create unsaturated type family apps!-tcRepSplitAppTy_maybe _other = Nothing----------------splitAppTy :: Type -> (Type, Type)--- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe',--- and panics if this is not possible-splitAppTy ty = case splitAppTy_maybe ty of-                Just pr -> pr-                Nothing -> panic "splitAppTy"----------------splitAppTys :: Type -> (Type, [Type])--- ^ Recursively splits a type as far as is possible, leaving a residual--- type being applied to and the type arguments applied to it. Never fails,--- even if that means returning an empty list of type applications.-splitAppTys ty = split ty ty []-  where-    split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args-    split _       (AppTy ty arg)        args = split ty ty (arg:args)-    split _       (TyConApp tc tc_args) args-      = let -- keep type families saturated-            n | mustBeSaturated tc = tyConArity tc-              | otherwise          = 0-            (tc_args1, tc_args2) = splitAt n tc_args-        in-        (TyConApp tc tc_args1, tc_args2 ++ args)-    split _   (FunTy _ ty1 ty2) args-      = ASSERT( null args )-        (TyConApp funTyCon [], [rep1, rep2, ty1, ty2])-      where-        rep1 = getRuntimeRep ty1-        rep2 = getRuntimeRep ty2--    split orig_ty _                     args  = (orig_ty, args)---- | Like 'splitAppTys', but doesn't look through type synonyms-repSplitAppTys :: HasDebugCallStack => Type -> (Type, [Type])-repSplitAppTys ty = split ty []-  where-    split (AppTy ty arg) args = split ty (arg:args)-    split (TyConApp tc tc_args) args-      = let n | mustBeSaturated tc = tyConArity tc-              | otherwise          = 0-            (tc_args1, tc_args2) = splitAt n tc_args-        in-        (TyConApp tc tc_args1, tc_args2 ++ args)-    split (FunTy _ ty1 ty2) args-      = ASSERT( null args )-        (TyConApp funTyCon [], [rep1, rep2, ty1, ty2])-      where-        rep1 = getRuntimeRep ty1-        rep2 = getRuntimeRep ty2--    split ty args = (ty, args)--{--                      LitTy-                      ~~~~~--}--mkNumLitTy :: Integer -> Type-mkNumLitTy n = LitTy (NumTyLit n)---- | Is this a numeric literal. We also look through type synonyms.-isNumLitTy :: Type -> Maybe Integer-isNumLitTy ty | Just ty1 <- coreView ty = isNumLitTy ty1-isNumLitTy (LitTy (NumTyLit n)) = Just n-isNumLitTy _                    = Nothing--mkStrLitTy :: FastString -> Type-mkStrLitTy s = LitTy (StrTyLit s)---- | Is this a symbol literal. We also look through type synonyms.-isStrLitTy :: Type -> Maybe FastString-isStrLitTy ty | Just ty1 <- coreView ty = isStrLitTy ty1-isStrLitTy (LitTy (StrTyLit s)) = Just s-isStrLitTy _                    = Nothing---- | Is this a type literal (symbol or numeric).-isLitTy :: Type -> Maybe TyLit-isLitTy ty | Just ty1 <- coreView ty = isLitTy ty1-isLitTy (LitTy l)                    = Just l-isLitTy _                            = Nothing---- | Is this type a custom user error?--- If so, give us the kind and the error message.-userTypeError_maybe :: Type -> Maybe Type-userTypeError_maybe t-  = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t-          -- There may be more than 2 arguments, if the type error is-          -- used as a type constructor (e.g. at kind `Type -> Type`).--       ; guard (tyConName tc == errorMessageTypeErrorFamName)-       ; return msg }---- | Render a type corresponding to a user type error into a SDoc.-pprUserTypeErrorTy :: Type -> SDoc-pprUserTypeErrorTy ty =-  case splitTyConApp_maybe ty of--    -- Text "Something"-    Just (tc,[txt])-      | tyConName tc == typeErrorTextDataConName-      , Just str <- isStrLitTy txt -> ftext str--    -- ShowType t-    Just (tc,[_k,t])-      | tyConName tc == typeErrorShowTypeDataConName -> ppr t--    -- t1 :<>: t2-    Just (tc,[t1,t2])-      | tyConName tc == typeErrorAppendDataConName ->-        pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2--    -- t1 :$$: t2-    Just (tc,[t1,t2])-      | tyConName tc == typeErrorVAppendDataConName ->-        pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2--    -- An unevaluated type function-    _ -> ppr ty-----{------------------------------------------------------------------------                                FunTy-                                ~~~~~--Note [Representation of function types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Functions (e.g. Int -> Char) can be thought of as being applications-of funTyCon (known in Haskell surface syntax as (->)),--    (->) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)-                   (a :: TYPE r1) (b :: TYPE r2).-            a -> b -> Type--However, for efficiency's sake we represent saturated applications of (->)-with FunTy. For instance, the type,--    (->) r1 r2 a b--is equivalent to,--    FunTy (Anon a) b--Note how the RuntimeReps are implied in the FunTy representation. For this-reason we must be careful when recontructing the TyConApp representation (see,-for instance, splitTyConApp_maybe).--In the compiler we maintain the invariant that all saturated applications of-(->) are represented with FunTy.--See #11714.--}--splitFunTy :: Type -> (Type, Type)--- ^ Attempts to extract the argument and result types from a type, and--- panics if that is not possible. See also 'splitFunTy_maybe'-splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty'-splitFunTy (FunTy _ arg res) = (arg, res)-splitFunTy other             = pprPanic "splitFunTy" (ppr other)--splitFunTy_maybe :: Type -> Maybe (Type, Type)--- ^ Attempts to extract the argument and result types from a type-splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty'-splitFunTy_maybe (FunTy _ arg res) = Just (arg, res)-splitFunTy_maybe _                 = Nothing--splitFunTys :: Type -> ([Type], Type)-splitFunTys ty = split [] ty ty-  where-    split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty'-    split args _       (FunTy _ arg res) = split (arg:args) res res-    split args orig_ty _                 = (reverse args, orig_ty)--funResultTy :: Type -> Type--- ^ Extract the function result type and panic if that is not possible-funResultTy ty | Just ty' <- coreView ty = funResultTy ty'-funResultTy (FunTy { ft_res = res }) = res-funResultTy ty                       = pprPanic "funResultTy" (ppr ty)--funArgTy :: Type -> Type--- ^ Extract the function argument type and panic if that is not possible-funArgTy ty | Just ty' <- coreView ty = funArgTy ty'-funArgTy (FunTy { ft_arg = arg })    = arg-funArgTy ty                           = pprPanic "funArgTy" (ppr ty)---- ^ Just like 'piResultTys' but for a single argument--- Try not to iterate 'piResultTy', because it's inefficient to substitute--- one variable at a time; instead use 'piResultTys"-piResultTy :: HasDebugCallStack => Type -> Type ->  Type-piResultTy ty arg = case piResultTy_maybe ty arg of-                      Just res -> res-                      Nothing  -> pprPanic "piResultTy" (ppr ty $$ ppr arg)--piResultTy_maybe :: Type -> Type -> Maybe Type--- We don't need a 'tc' version, because--- this function behaves the same for Type and Constraint-piResultTy_maybe ty arg-  | Just ty' <- coreView ty = piResultTy_maybe ty' arg--  | FunTy { ft_res = res } <- ty-  = Just res--  | ForAllTy (Bndr tv _) res <- ty-  = let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $-                      tyCoVarsOfTypes [arg,res]-    in Just (substTy (extendTCvSubst empty_subst tv arg) res)--  | otherwise-  = Nothing---- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn)---   where f :: f_ty--- 'piResultTys' is interesting because:---      1. 'f_ty' may have more for-alls than there are args---      2. Less obviously, it may have fewer for-alls--- For case 2. think of:---   piResultTys (forall a.a) [forall b.b, Int]--- This really can happen, but only (I think) in situations involving--- undefined.  For example:---       undefined :: forall a. a--- Term: undefined @(forall b. b->b) @Int--- This term should have type (Int -> Int), but notice that--- there are more type args than foralls in 'undefined's type.---- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism] in GHC.Core.Lint---- This is a heavily used function (e.g. from typeKind),--- so we pay attention to efficiency, especially in the special case--- where there are no for-alls so we are just dropping arrows from--- a function type/kind.-piResultTys :: HasDebugCallStack => Type -> [Type] -> Type-piResultTys ty [] = ty-piResultTys ty orig_args@(arg:args)-  | Just ty' <- coreView ty-  = piResultTys ty' orig_args--  | FunTy { ft_res = res } <- ty-  = piResultTys res args--  | ForAllTy (Bndr tv _) res <- ty-  = go (extendTCvSubst init_subst tv arg) res args--  | otherwise-  = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args)-  where-    init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args))--    go :: TCvSubst -> Type -> [Type] -> Type-    go subst ty [] = substTyUnchecked subst ty--    go subst ty all_args@(arg:args)-      | Just ty' <- coreView ty-      = go subst ty' all_args--      | FunTy { ft_res = res } <- ty-      = go subst res args--      | ForAllTy (Bndr tv _) res <- ty-      = go (extendTCvSubst subst tv arg) res args--      | not (isEmptyTCvSubst subst)  -- See Note [Care with kind instantiation]-      = go init_subst-          (substTy subst ty)-          all_args--      | otherwise-      = -- We have not run out of arguments, but the function doesn't-        -- have the right kind to apply to them; so panic.-        -- Without the explicit isEmptyVarEnv test, an ill-kinded type-        -- would give an infinite loop, which is very unhelpful-        -- c.f. #15473-        pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args)--applyTysX :: [TyVar] -> Type -> [Type] -> Type--- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys--- Assumes that (/\tvs. body_ty) is closed-applyTysX tvs body_ty arg_tys-  = ASSERT2( arg_tys `lengthAtLeast` n_tvs, pp_stuff )-    ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff )-    mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty)-             (drop n_tvs arg_tys)-  where-    pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys]-    n_tvs = length tvs----{- Note [Care with kind instantiation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-  T :: forall k. k-and we are finding the kind of-  T (forall b. b -> b) * Int-Then-  T (forall b. b->b) :: k[ k :-> forall b. b->b]-                     :: forall b. b -> b-So-  T (forall b. b->b) * :: (b -> b)[ b :-> *]-                       :: * -> *--In other words we must instantiate the forall!--Similarly (#15428)-   S :: forall k f. k -> f k-and we are finding the kind of-   S * (* ->) Int Bool-We have-   S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)]-              :: * -> * -> *-So again we must instantiate.--The same thing happens in GHC.CoreToIface.toIfaceAppArgsX.-----------------------------------------Note [mkTyConApp and Type]--Whilst benchmarking it was observed in #17292 that GHC allocated a lot-of `TyConApp` constructors. Upon further inspection a large number of these-TyConApp constructors were all duplicates of `Type` applied to no arguments.--```-(From a sample of 100000 TyConApp closures)-0x45f3523    - 28732 - `Type`-0x420b840702 - 9629  - generic type constructors-0x42055b7e46 - 9596-0x420559b582 - 9511-0x420bb15a1e - 9509-0x420b86c6ba - 9501-0x42055bac1e - 9496-0x45e68fd    - 538 - `TYPE ...`-```--Therefore in `mkTyConApp` we have a special case for `Type` to ensure that-only one `TyConApp 'Type []` closure is allocated during the course of-compilation. In order to avoid a potentially expensive series of checks in-`mkTyConApp` only this egregious case is special cased at the moment.-------------------------------------------------------------------------                                TyConApp-                                ~~~~~~~~--}---- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to--- its arguments.  Applies its arguments to the constructor from left to right.-mkTyConApp :: TyCon -> [Type] -> Type-mkTyConApp tycon tys-  | isFunTyCon tycon-  , [_rep1,_rep2,ty1,ty2] <- tys-  -- The FunTyCon (->) is always a visible one-  = FunTy { ft_af = VisArg, ft_arg = ty1, ft_res = ty2 }-  -- Note [mkTyConApp and Type]-  | tycon == liftedTypeKindTyCon-  = ASSERT2( null tys, ppr tycon $$ ppr tys )-    liftedTypeKindTyConApp-  | otherwise-  = TyConApp tycon tys---- This is a single, global definition of the type `Type`--- Defined here so it is only allocated once.--- See Note [mkTyConApp and Type]-liftedTypeKindTyConApp :: Type-liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon []---- splitTyConApp "looks through" synonyms, because they don't--- mean a distinct type, but all other type-constructor applications--- including functions are returned as Just ..---- | Retrieve the tycon heading this type, if there is one. Does /not/--- look through synonyms.-tyConAppTyConPicky_maybe :: Type -> Maybe TyCon-tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc-tyConAppTyConPicky_maybe (FunTy {})      = Just funTyCon-tyConAppTyConPicky_maybe _               = Nothing----- | The same as @fst . splitTyConApp@-tyConAppTyCon_maybe :: Type -> Maybe TyCon-tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty'-tyConAppTyCon_maybe (TyConApp tc _) = Just tc-tyConAppTyCon_maybe (FunTy {})      = Just funTyCon-tyConAppTyCon_maybe _               = Nothing--tyConAppTyCon :: Type -> TyCon-tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty)---- | The same as @snd . splitTyConApp@-tyConAppArgs_maybe :: Type -> Maybe [Type]-tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty'-tyConAppArgs_maybe (TyConApp _ tys) = Just tys-tyConAppArgs_maybe (FunTy _ arg res)-  | Just rep1 <- getRuntimeRep_maybe arg-  , Just rep2 <- getRuntimeRep_maybe res-  = Just [rep1, rep2, arg, res]-tyConAppArgs_maybe _  = Nothing--tyConAppArgs :: Type -> [Type]-tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)--tyConAppArgN :: Int -> Type -> Type--- Executing Nth-tyConAppArgN n ty-  = case tyConAppArgs_maybe ty of-      Just tys -> ASSERT2( tys `lengthExceeds` n, ppr n <+> ppr tys ) tys `getNth` n-      Nothing  -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty)---- | Attempts to tease a type apart into a type constructor and the application--- of a number of arguments to that constructor. Panics if that is not possible.--- See also 'splitTyConApp_maybe'-splitTyConApp :: Type -> (TyCon, [Type])-splitTyConApp ty = case splitTyConApp_maybe ty of-                   Just stuff -> stuff-                   Nothing    -> pprPanic "splitTyConApp" (ppr ty)---- | Attempts to tease a type apart into a type constructor and the application--- of a number of arguments to that constructor-splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])-splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty'-splitTyConApp_maybe ty                           = repSplitTyConApp_maybe ty---- | Split a type constructor application into its type constructor and--- applied types. Note that this may fail in the case of a 'FunTy' with an--- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind--- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your--- type before using this function.------ If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'.-tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])--- Defined here to avoid module loops between Unify and TcType.-tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'-tcSplitTyConApp_maybe ty                         = repSplitTyConApp_maybe ty----------------------repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])--- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This--- assumes the synonyms have already been dealt with.------ Moreover, for a FunTy, it only succeeds if the argument types--- have enough info to extract the runtime-rep arguments that--- the funTyCon requires.  This will usually be true;--- but may be temporarily false during canonicalization:---     see Note [FunTy and decomposing tycon applications] in TcCanonical----repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)-repSplitTyConApp_maybe (FunTy _ arg res)-  | Just arg_rep <- getRuntimeRep_maybe arg-  , Just res_rep <- getRuntimeRep_maybe res-  = Just (funTyCon, [arg_rep, res_rep, arg, res])-repSplitTyConApp_maybe _ = Nothing------------------------ | Attempts to tease a list type apart and gives the type of the elements if--- successful (looks through type synonyms)-splitListTyConApp_maybe :: Type -> Maybe Type-splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of-  Just (tc,[e]) | tc == listTyCon -> Just e-  _other                          -> Nothing--nextRole :: Type -> Role-nextRole ty-  | Just (tc, tys) <- splitTyConApp_maybe ty-  , let num_tys = length tys-  , num_tys < tyConArity tc-  = tyConRoles tc `getNth` num_tys--  | otherwise-  = Nominal--newTyConInstRhs :: TyCon -> [Type] -> Type--- ^ Unwrap one 'layer' of newtype on a type constructor and its--- arguments, using an eta-reduced version of the @newtype@ if possible.--- This requires tys to have at least @newTyConInstArity tycon@ elements.-newTyConInstRhs tycon tys-    = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs )-      applyTysX tvs rhs tys-  where-    (tvs, rhs) = newTyConEtadRhs tycon--{------------------------------------------------------------------------                           CastTy-                           ~~~~~~-A casted type has its *kind* casted into something new.--}--splitCastTy_maybe :: Type -> Maybe (Type, Coercion)-splitCastTy_maybe ty | Just ty' <- coreView ty = splitCastTy_maybe ty'-splitCastTy_maybe (CastTy ty co)               = Just (ty, co)-splitCastTy_maybe _                            = Nothing---- | Make a 'CastTy'. The Coercion must be nominal. Checks the--- Coercion for reflexivity, dropping it if it's reflexive.--- See Note [Respecting definitional equality] in TyCoRep-mkCastTy :: Type -> Coercion -> Type-mkCastTy ty co | isReflexiveCo co = ty  -- (EQ2) from the Note--- NB: Do the slow check here. This is important to keep the splitXXX--- functions working properly. Otherwise, we may end up with something--- like (((->) |> something_reflexive_but_not_obviously_so) biz baz)--- fails under splitFunTy_maybe. This happened with the cheaper check--- in test dependent/should_compile/dynamic-paper.--mkCastTy (CastTy ty co1) co2-  -- (EQ3) from the Note-  = mkCastTy ty (co1 `mkTransCo` co2)-      -- call mkCastTy again for the reflexivity check--mkCastTy (ForAllTy (Bndr tv vis) inner_ty) co-  -- (EQ4) from the Note-  | isTyVar tv-  , let fvs = tyCoVarsOfCo co-  = -- have to make sure that pushing the co in doesn't capture the bound var!-    if tv `elemVarSet` fvs-    then let empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs)-             (subst, tv') = substVarBndr empty_subst tv-         in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mkCastTy` co)-    else ForAllTy (Bndr tv vis) (inner_ty `mkCastTy` co)--mkCastTy ty co = CastTy ty co--tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder]--- Return the tyConBinders in TyCoBinder form-tyConBindersTyCoBinders = map to_tyb-  where-    to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis)-    to_tyb (Bndr tv (AnonTCB af))   = Anon af (varType tv)---- | Drop the cast on a type, if any. If there is no--- cast, just return the original type. This is rarely what--- you want. The CastTy data constructor (in TyCoRep) has the--- invariant that another CastTy is not inside. See the--- data constructor for a full description of this invariant.--- Since CastTy cannot be nested, the result of discardCast--- cannot be a CastTy.-discardCast :: Type -> Type-discardCast (CastTy ty _) = ASSERT(not (isCastTy ty)) ty-  where-  isCastTy CastTy{} = True-  isCastTy _        = False-discardCast ty            = ty---{-----------------------------------------------------------------------                            CoercionTy-                            ~~~~~~~~~~-CoercionTy allows us to inject coercions into types. A CoercionTy-should appear only in the right-hand side of an application.--}--mkCoercionTy :: Coercion -> Type-mkCoercionTy = CoercionTy--isCoercionTy :: Type -> Bool-isCoercionTy (CoercionTy _) = True-isCoercionTy _              = False--isCoercionTy_maybe :: Type -> Maybe Coercion-isCoercionTy_maybe (CoercionTy co) = Just co-isCoercionTy_maybe _               = Nothing--stripCoercionTy :: Type -> Coercion-stripCoercionTy (CoercionTy co) = co-stripCoercionTy ty              = pprPanic "stripCoercionTy" (ppr ty)--{------------------------------------------------------------------------                                SynTy-                                ~~~~~--Notes on type synonyms-~~~~~~~~~~~~~~~~~~~~~~-The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try-to return type synonyms wherever possible. Thus--        type Foo a = a -> a--we want-        splitFunTys (a -> Foo a) = ([a], Foo a)-not                                ([a], a -> a)--The reason is that we then get better (shorter) type signatures in-interfaces.  Notably this plays a role in tcTySigs in TcBinds.hs.-------------------------------------------------------------------------                                ForAllTy-                                ~~~~~~~~--}---- | Make a dependent forall over an 'Inferred' variable-mkTyCoInvForAllTy :: TyCoVar -> Type -> Type-mkTyCoInvForAllTy tv ty-  | isCoVar tv-  , not (tv `elemVarSet` tyCoVarsOfType ty)-  = mkVisFunTy (varType tv) ty-  | otherwise-  = ForAllTy (Bndr tv Inferred) ty---- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar-mkInvForAllTy :: TyVar -> Type -> Type-mkInvForAllTy tv ty = ASSERT( isTyVar tv )-                      ForAllTy (Bndr tv Inferred) ty---- | Like 'mkForAllTys', but assumes all variables are dependent and--- 'Inferred', a common case-mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type-mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs---- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar-mkInvForAllTys :: [TyVar] -> Type -> Type-mkInvForAllTys tvs ty = foldr mkInvForAllTy ty tvs---- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified',--- a common case-mkSpecForAllTy :: TyVar -> Type -> Type-mkSpecForAllTy tv ty = ASSERT( isTyVar tv )-                       -- covar is always Inferred, so input should be tyvar-                       ForAllTy (Bndr tv Specified) ty---- | Like 'mkForAllTys', but assumes all variables are dependent and--- 'Specified', a common case-mkSpecForAllTys :: [TyVar] -> Type -> Type-mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs---- | Like mkForAllTys, but assumes all variables are dependent and visible-mkVisForAllTys :: [TyVar] -> Type -> Type-mkVisForAllTys tvs = ASSERT( all isTyVar tvs )-                     -- covar is always Inferred, so all inputs should be tyvar-                     mkForAllTys [ Bndr tv Required | tv <- tvs ]--mkLamType  :: Var -> Type -> Type--- ^ Makes a @(->)@ type or an implicit forall type, depending--- on whether it is given a type variable or a term variable.--- This is used, for example, when producing the type of a lambda.--- Always uses Inferred binders.-mkLamTypes :: [Var] -> Type -> Type--- ^ 'mkLamType' for multiple type or value arguments--mkLamType v body_ty-   | isTyVar v-   = ForAllTy (Bndr v Inferred) body_ty--   | isCoVar v-   , v `elemVarSet` tyCoVarsOfType body_ty-   = ForAllTy (Bndr v Required) body_ty--   | isPredTy arg_ty  -- See Note [mkLamType: dictionary arguments]-   = mkInvisFunTy arg_ty body_ty--   | otherwise-   = mkVisFunTy arg_ty body_ty-   where-     arg_ty = varType v--mkLamTypes vs ty = foldr mkLamType ty vs--{- Note [mkLamType: dictionary arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have (\ (d :: Ord a). blah), we want to give it type-           (Ord a => blah_ty)-with a fat arrow; that is, using mkInvisFunTy, not mkVisFunTy.--Why? After all, we are in Core, where (=>) and (->) behave the same.-Yes, but the /specialiser/ does treat dictionary arguments specially.-Suppose we do w/w on 'foo' in module A, thus (#11272, #6056)-   foo :: Ord a => Int -> blah-   foo a d x = case x of I# x' -> $wfoo @a d x'--   $wfoo :: Ord a => Int# -> blah--Now in module B we see (foo @Int dOrdInt).  The specialiser will-specialise this to $sfoo, where-   $sfoo :: Int -> blah-   $sfoo x = case x of I# x' -> $wfoo @Int dOrdInt x'--Now we /must/ also specialise $wfoo!  But it wasn't user-written,-and has a type built with mkLamTypes.--Conclusion: the easiest thing is to make mkLamType build-            (c => ty)-when the argument is a predicate type.  See TyCoRep-Note [Types for coercions, predicates, and evidence]--}---- | Given a list of type-level vars and the free vars of a result kind,--- makes TyCoBinders, preferring anonymous binders--- if the variable is, in fact, not dependent.--- e.g.    mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k)--- We want (k:*) Named, (b:k) Anon, (c:k) Anon------ All non-coercion binders are /visible/.-mkTyConBindersPreferAnon :: [TyVar]      -- ^ binders-                         -> TyCoVarSet   -- ^ free variables of result-                         -> [TyConBinder]-mkTyConBindersPreferAnon vars inner_tkvs = ASSERT( all isTyVar vars)-                                           fst (go vars)-  where-    go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars-    go [] = ([], inner_tkvs)-    go (v:vs) | v `elemVarSet` fvs-              = ( Bndr v (NamedTCB Required) : binders-                , fvs `delVarSet` v `unionVarSet` kind_vars )-              | otherwise-              = ( Bndr v (AnonTCB VisArg) : binders-                , fvs `unionVarSet` kind_vars )-      where-        (binders, fvs) = go vs-        kind_vars      = tyCoVarsOfType $ tyVarKind v---- | Take a ForAllTy apart, returning the list of tycovars and the result type.--- This always succeeds, even if it returns only an empty list. Note that the--- result type returned may have free variables that were bound by a forall.-splitForAllTys :: Type -> ([TyCoVar], Type)-splitForAllTys ty = split ty ty []-  where-    split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs-    split _       (ForAllTy (Bndr tv _) ty)    tvs = split ty ty (tv:tvs)-    split orig_ty _                            tvs = (reverse tvs, orig_ty)---- | Like 'splitForAllTys', but only splits a 'ForAllTy' if--- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility--- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided--- as an argument to this function.-splitForAllTysSameVis :: ArgFlag -> Type -> ([TyCoVar], Type)-splitForAllTysSameVis supplied_argf ty = split ty ty []-  where-    split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs-    split _       (ForAllTy (Bndr tv argf) ty) tvs-      | argf `sameVis` supplied_argf               = split ty ty (tv:tvs)-    split orig_ty _                            tvs = (reverse tvs, orig_ty)---- | Like splitForAllTys, but split only for tyvars.--- This always succeeds, even if it returns only an empty list. Note that the--- result type returned may have free variables that were bound by a forall.-splitTyVarForAllTys :: Type -> ([TyVar], Type)-splitTyVarForAllTys ty = split ty ty []-  where-    split orig_ty ty tvs | Just ty' <- coreView ty     = split orig_ty ty' tvs-    split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs)-    split orig_ty _                   tvs              = (reverse tvs, orig_ty)---- | Checks whether this is a proper forall (with a named binder)-isForAllTy :: Type -> Bool-isForAllTy ty | Just ty' <- coreView ty = isForAllTy ty'-isForAllTy (ForAllTy {}) = True-isForAllTy _             = False---- | Like `isForAllTy`, but returns True only if it is a tyvar binder-isForAllTy_ty :: Type -> Bool-isForAllTy_ty ty | Just ty' <- coreView ty = isForAllTy_ty ty'-isForAllTy_ty (ForAllTy (Bndr tv _) _) | isTyVar tv = True-isForAllTy_ty _             = False---- | Like `isForAllTy`, but returns True only if it is a covar binder-isForAllTy_co :: Type -> Bool-isForAllTy_co ty | Just ty' <- coreView ty = isForAllTy_co ty'-isForAllTy_co (ForAllTy (Bndr tv _) _) | isCoVar tv = True-isForAllTy_co _             = False---- | Is this a function or forall?-isPiTy :: Type -> Bool-isPiTy ty | Just ty' <- coreView ty = isPiTy ty'-isPiTy (ForAllTy {}) = True-isPiTy (FunTy {})    = True-isPiTy _             = False---- | Is this a function?-isFunTy :: Type -> Bool-isFunTy ty | Just ty' <- coreView ty = isFunTy ty'-isFunTy (FunTy {}) = True-isFunTy _          = False---- | Take a forall type apart, or panics if that is not possible.-splitForAllTy :: Type -> (TyCoVar, Type)-splitForAllTy ty-  | Just answer <- splitForAllTy_maybe ty = answer-  | otherwise                             = pprPanic "splitForAllTy" (ppr ty)---- | Drops all ForAllTys-dropForAlls :: Type -> Type-dropForAlls ty = go ty-  where-    go ty | Just ty' <- coreView ty = go ty'-    go (ForAllTy _ res)            = go res-    go res                         = res---- | Attempts to take a forall type apart, but only if it's a proper forall,--- with a named binder-splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type)-splitForAllTy_maybe ty = go ty-  where-    go ty | Just ty' <- coreView ty = go ty'-    go (ForAllTy (Bndr tv _) ty)    = Just (tv, ty)-    go _                            = Nothing---- | Like splitForAllTy_maybe, but only returns Just if it is a tyvar binder.-splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type)-splitForAllTy_ty_maybe ty = go ty-  where-    go ty | Just ty' <- coreView ty = go ty'-    go (ForAllTy (Bndr tv _) ty) | isTyVar tv = Just (tv, ty)-    go _                            = Nothing---- | Like splitForAllTy_maybe, but only returns Just if it is a covar binder.-splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type)-splitForAllTy_co_maybe ty = go ty-  where-    go ty | Just ty' <- coreView ty = go ty'-    go (ForAllTy (Bndr tv _) ty) | isCoVar tv = Just (tv, ty)-    go _                            = Nothing---- | Attempts to take a forall type apart; works with proper foralls and--- functions-splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type)-splitPiTy_maybe ty = go ty-  where-    go ty | Just ty' <- coreView ty = go ty'-    go (ForAllTy bndr ty) = Just (Named bndr, ty)-    go (FunTy { ft_af = af, ft_arg = arg, ft_res = res})-                          = Just (Anon af arg, res)-    go _                  = Nothing---- | Takes a forall type apart, or panics-splitPiTy :: Type -> (TyCoBinder, Type)-splitPiTy ty-  | Just answer <- splitPiTy_maybe ty = answer-  | otherwise                         = pprPanic "splitPiTy" (ppr ty)---- | Split off all TyCoBinders to a type, splitting both proper foralls--- and functions-splitPiTys :: Type -> ([TyCoBinder], Type)-splitPiTys ty = split ty ty []-  where-    split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs-    split _       (ForAllTy b res) bs = split res res (Named b  : bs)-    split _       (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) bs-                                      = split res res (Anon af arg : bs)-    split orig_ty _                bs = (reverse bs, orig_ty)---- | Like 'splitPiTys' but split off only /named/ binders---   and returns TyCoVarBinders rather than TyCoBinders-splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type)-splitForAllVarBndrs ty = split ty ty []-  where-    split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs-    split _       (ForAllTy b res) bs = split res res (b:bs)-    split orig_ty _                bs = (reverse bs, orig_ty)-{-# INLINE splitForAllVarBndrs #-}--invisibleTyBndrCount :: Type -> Int--- Returns the number of leading invisible forall'd binders in the type--- Includes invisible predicate arguments; e.g. for---    e.g.  forall {k}. (k ~ *) => k -> k--- returns 2 not 1-invisibleTyBndrCount ty = length (fst (splitPiTysInvisible ty))---- Like splitPiTys, but returns only *invisible* binders, including constraints--- Stops at the first visible binder-splitPiTysInvisible :: Type -> ([TyCoBinder], Type)-splitPiTysInvisible ty = split ty ty []-   where-    split orig_ty ty bs-      | Just ty' <- coreView ty  = split orig_ty ty' bs-    split _ (ForAllTy b res) bs-      | Bndr _ vis <- b-      , isInvisibleArgFlag vis   = split res res (Named b  : bs)-    split _ (FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res })  bs-                                 = split res res (Anon InvisArg arg : bs)-    split orig_ty _          bs  = (reverse bs, orig_ty)--splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type)--- Same as splitPiTysInvisible, but stop when---   - you have found 'n' TyCoBinders,---   - or you run out of invisible binders-splitPiTysInvisibleN n ty = split n ty ty []-   where-    split n orig_ty ty bs-      | n == 0                  = (reverse bs, orig_ty)-      | Just ty' <- coreView ty = split n orig_ty ty' bs-      | ForAllTy b res <- ty-      , Bndr _ vis <- b-      , isInvisibleArgFlag vis  = split (n-1) res res (Named b  : bs)-      | FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res } <- ty-                                = split (n-1) res res (Anon InvisArg arg : bs)-      | otherwise               = (reverse bs, orig_ty)---- | Given a 'TyCon' and a list of argument types, filter out any invisible--- (i.e., 'Inferred' or 'Specified') arguments.-filterOutInvisibleTypes :: TyCon -> [Type] -> [Type]-filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys---- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred'--- arguments.-filterOutInferredTypes :: TyCon -> [Type] -> [Type]-filterOutInferredTypes tc tys =-  filterByList (map (/= Inferred) $ tyConArgFlags tc tys) tys---- | Given a 'TyCon' and a list of argument types, partition the arguments--- into:------ 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and------ 2. 'Required' (i.e., visible) arguments-partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type])-partitionInvisibleTypes tc tys =-  partitionByList (map isInvisibleArgFlag $ tyConArgFlags tc tys) tys---- | Given a list of things paired with their visibilities, partition the--- things into (invisible things, visible things).-partitionInvisibles :: [(a, ArgFlag)] -> ([a], [a])-partitionInvisibles = partitionWith pick_invis-  where-    pick_invis :: (a, ArgFlag) -> Either a a-    pick_invis (thing, vis) | isInvisibleArgFlag vis = Left thing-                            | otherwise              = Right thing---- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is--- applied, determine each argument's visibility--- ('Inferred', 'Specified', or 'Required').------ Wrinkle: consider the following scenario:------ > T :: forall k. k -> k--- > tyConArgFlags T [forall m. m -> m -> m, S, R, Q]------ After substituting, we get------ > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n------ Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again,--- and @Q@ is visible.-tyConArgFlags :: TyCon -> [Type] -> [ArgFlag]-tyConArgFlags tc = fun_kind_arg_flags (tyConKind tc)---- | Given a 'Type' and a list of argument types to which the 'Type' is--- applied, determine each argument's visibility--- ('Inferred', 'Specified', or 'Required').------ Most of the time, the arguments will be 'Required', but not always. Consider--- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is--- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely--- this sort of higher-rank situation in which 'appTyArgFlags' comes in handy,--- since @f Type Bool@ would be represented in Core using 'AppTy's.--- (See also #15792).-appTyArgFlags :: Type -> [Type] -> [ArgFlag]-appTyArgFlags ty = fun_kind_arg_flags (typeKind ty)---- | Given a function kind and a list of argument types (where each argument's--- kind aligns with the corresponding position in the argument kind), determine--- each argument's visibility ('Inferred', 'Specified', or 'Required').-fun_kind_arg_flags :: Kind -> [Type] -> [ArgFlag]-fun_kind_arg_flags = go emptyTCvSubst-  where-    go subst ki arg_tys-      | Just ki' <- coreView ki = go subst ki' arg_tys-    go _ _ [] = []-    go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys)-      = argf : go subst' res_ki arg_tys-      where-        subst' = extendTvSubst subst tv arg_ty-    go subst (TyVarTy tv) arg_tys-      | Just ki <- lookupTyVar subst tv = go subst ki arg_tys-    -- This FunTy case is important to handle kinds with nested foralls, such-    -- as this kind (inspired by #16518):-    ---    --   forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type-    ---    -- Here, we want to get the following ArgFlags:-    ---    -- [Inferred,   Specified, Required, Required, Specified, Required]-    -- forall {k1}. forall k2. k1 ->     k2 ->     forall k3. k3 ->     Type-    go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys)-      = argf : go subst res_ki arg_tys-      where-        argf = case af of-                 VisArg   -> Required-                 InvisArg -> Inferred-    go _ _ arg_tys = map (const Required) arg_tys-                        -- something is ill-kinded. But this can happen-                        -- when printing errors. Assume everything is Required.---- @isTauTy@ tests if a type has no foralls-isTauTy :: Type -> Bool-isTauTy ty | Just ty' <- coreView ty = isTauTy ty'-isTauTy (TyVarTy _)           = True-isTauTy (LitTy {})            = True-isTauTy (TyConApp tc tys)     = all isTauTy tys && isTauTyCon tc-isTauTy (AppTy a b)           = isTauTy a && isTauTy b-isTauTy (FunTy _ a b)         = isTauTy a && isTauTy b-isTauTy (ForAllTy {})         = False-isTauTy (CastTy ty _)         = isTauTy ty-isTauTy (CoercionTy _)        = False  -- Not sure about this--{--%************************************************************************-%*                                                                      *-   TyCoBinders-%*                                                                      *-%************************************************************************--}---- | Make an anonymous binder-mkAnonBinder :: AnonArgFlag -> Type -> TyCoBinder-mkAnonBinder = Anon---- | Does this binder bind a variable that is /not/ erased? Returns--- 'True' for anonymous binders.-isAnonTyCoBinder :: TyCoBinder -> Bool-isAnonTyCoBinder (Named {}) = False-isAnonTyCoBinder (Anon {})  = True--tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar-tyCoBinderVar_maybe (Named tv) = Just $ binderVar tv-tyCoBinderVar_maybe _          = Nothing--tyCoBinderType :: TyCoBinder -> Type-tyCoBinderType (Named tvb) = binderType tvb-tyCoBinderType (Anon _ ty) = ty--tyBinderType :: TyBinder -> Type-tyBinderType (Named (Bndr tv _))-  = ASSERT( isTyVar tv )-    tyVarKind tv-tyBinderType (Anon _ ty)   = ty---- | Extract a relevant type, if there is one.-binderRelevantType_maybe :: TyCoBinder -> Maybe Type-binderRelevantType_maybe (Named {})  = Nothing-binderRelevantType_maybe (Anon _ ty) = Just ty--{--************************************************************************-*                                                                      *-\subsection{Type families}-*                                                                      *-************************************************************************--}--mkFamilyTyConApp :: TyCon -> [Type] -> Type--- ^ Given a family instance TyCon and its arg types, return the--- corresponding family type.  E.g:------ > data family T a--- > data instance T (Maybe b) = MkT b------ Where the instance tycon is :RTL, so:------ > mkFamilyTyConApp :RTL Int  =  T (Maybe Int)-mkFamilyTyConApp tc tys-  | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc-  , let tvs = tyConTyVars tc-        fam_subst = ASSERT2( tvs `equalLength` tys, ppr tc <+> ppr tys )-                    zipTvSubst tvs tys-  = mkTyConApp fam_tc (substTys fam_subst fam_tys)-  | otherwise-  = mkTyConApp tc tys---- | Get the type on the LHS of a coercion induced by a type/data--- family instance.-coAxNthLHS :: CoAxiom br -> Int -> Type-coAxNthLHS ax ind =-  mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind))--isFamFreeTy :: Type -> Bool-isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty'-isFamFreeTy (TyVarTy _)       = True-isFamFreeTy (LitTy {})        = True-isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc-isFamFreeTy (AppTy a b)       = isFamFreeTy a && isFamFreeTy b-isFamFreeTy (FunTy _ a b)     = isFamFreeTy a && isFamFreeTy b-isFamFreeTy (ForAllTy _ ty)   = isFamFreeTy ty-isFamFreeTy (CastTy ty _)     = isFamFreeTy ty-isFamFreeTy (CoercionTy _)    = False  -- Not sure about this---- | Does this type classify a core (unlifted) Coercion?--- At either role nominal or representational---    (t1 ~# t2) or (t1 ~R# t2)--- See Note [Types for coercions, predicates, and evidence] in TyCoRep-isCoVarType :: Type -> Bool-  -- ToDo: should we check saturation?-isCoVarType ty-  | Just tc <- tyConAppTyCon_maybe ty-  = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey-  | otherwise-  = False--buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind   -- ^ /result/ kind-              -> [Role] -> KnotTied Type -> TyCon--- This function is here beucase here is where we have---   isFamFree and isTauTy-buildSynTyCon name binders res_kind roles rhs-  = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free-  where-    is_tau      = isTauTy rhs-    is_fam_free = isFamFreeTy rhs--{--************************************************************************-*                                                                      *-\subsection{Liftedness}-*                                                                      *-************************************************************************--}---- | Returns Just True if this type is surely lifted, Just False--- if it is surely unlifted, Nothing if we can't be sure (i.e., it is--- levity polymorphic), and panics if the kind does not have the shape--- TYPE r.-isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool-isLiftedType_maybe ty = go (getRuntimeRep ty)-  where-    go rr | Just rr' <- coreView rr = go rr'-          | isLiftedRuntimeRep rr  = Just True-          | TyConApp {} <- rr      = Just False  -- Everything else is unlifted-          | otherwise              = Nothing     -- levity polymorphic---- | See "Type#type_classification" for what an unlifted type is.--- Panics on levity polymorphic types; See 'mightBeUnliftedType' for--- a more approximate predicate that behaves better in the presence of--- levity polymorphism.-isUnliftedType :: HasDebugCallStack => Type -> Bool-        -- isUnliftedType returns True for forall'd unlifted types:-        --      x :: forall a. Int#-        -- I found bindings like these were getting floated to the top level.-        -- They are pretty bogus types, mind you.  It would be better never to-        -- construct them-isUnliftedType ty-  = not (isLiftedType_maybe ty `orElse`-         pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty)))---- | Returns:------ * 'False' if the type is /guaranteed/ lifted or--- * 'True' if it is unlifted, OR we aren't sure (e.g. in a levity-polymorphic case)-mightBeUnliftedType :: Type -> Bool-mightBeUnliftedType ty-  = case isLiftedType_maybe ty of-      Just is_lifted -> not is_lifted-      Nothing -> True---- | Is this a type of kind RuntimeRep? (e.g. LiftedRep)-isRuntimeRepKindedTy :: Type -> Bool-isRuntimeRepKindedTy = isRuntimeRepTy . typeKind---- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g.--- dropping 'LiftedRep arguments of unboxed tuple TyCon applications:------   dropRuntimeRepArgs [ 'LiftedRep, 'IntRep---                      , String, Int# ] == [String, Int#]----dropRuntimeRepArgs :: [Type] -> [Type]-dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy---- | Extract the RuntimeRep classifier of a type. For instance,--- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not--- possible.-getRuntimeRep_maybe :: HasDebugCallStack-                    => Type -> Maybe Type-getRuntimeRep_maybe = kindRep_maybe . typeKind---- | Extract the RuntimeRep classifier of a type. For instance,--- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible.-getRuntimeRep :: HasDebugCallStack => Type -> Type-getRuntimeRep ty-  = case getRuntimeRep_maybe ty of-      Just r  -> r-      Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty))--isUnboxedTupleType :: Type -> Bool-isUnboxedTupleType ty-  = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey-  -- NB: Do not use typePrimRep, as that can't tell the difference between-  -- unboxed tuples and unboxed sums---isUnboxedSumType :: Type -> Bool-isUnboxedSumType ty-  = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey---- | See "Type#type_classification" for what an algebraic type is.--- Should only be applied to /types/, as opposed to e.g. partially--- saturated type constructors-isAlgType :: Type -> Bool-isAlgType ty-  = case splitTyConApp_maybe ty of-      Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )-                            isAlgTyCon tc-      _other             -> False---- | Check whether a type is a data family type-isDataFamilyAppType :: Type -> Bool-isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of-                           Just tc -> isDataFamilyTyCon tc-                           _       -> False---- | Computes whether an argument (or let right hand side) should--- be computed strictly or lazily, based only on its type.--- Currently, it's just 'isUnliftedType'. Panics on levity-polymorphic types.-isStrictType :: HasDebugCallStack => Type -> Bool-isStrictType = isUnliftedType--isPrimitiveType :: Type -> Bool--- ^ Returns true of types that are opaque to Haskell.-isPrimitiveType ty = case splitTyConApp_maybe ty of-                        Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )-                                              isPrimTyCon tc-                        _                  -> False--{--************************************************************************-*                                                                      *-\subsection{Join points}-*                                                                      *-************************************************************************--}---- | Determine whether a type could be the type of a join point of given total--- arity, according to the polymorphism rule. A join point cannot be polymorphic--- in its return type, since given---   join j @a @b x y z = e1 in e2,--- the types of e1 and e2 must be the same, and a and b are not in scope for e2.--- (See Note [The polymorphism rule of join points] in GHC.Core.) Returns False--- also if the type simply doesn't have enough arguments.------ Note that we need to know how many arguments (type *and* value) the putative--- join point takes; for instance, if---   j :: forall a. a -> Int--- then j could be a binary join point returning an Int, but it could *not* be a--- unary join point returning a -> Int.------ TODO: See Note [Excess polymorphism and join points]-isValidJoinPointType :: JoinArity -> Type -> Bool-isValidJoinPointType arity ty-  = valid_under emptyVarSet arity ty-  where-    valid_under tvs arity ty-      | arity == 0-      = isEmptyVarSet (tvs `intersectVarSet` tyCoVarsOfType ty)-      | Just (t, ty') <- splitForAllTy_maybe ty-      = valid_under (tvs `extendVarSet` t) (arity-1) ty'-      | Just (_, res_ty) <- splitFunTy_maybe ty-      = valid_under tvs (arity-1) res_ty-      | otherwise-      = False--{- Note [Excess polymorphism and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In principle, if a function would be a join point except that it fails-the polymorphism rule (see Note [The polymorphism rule of join points] in-GHC.Core), it can still be made a join point with some effort. This is because-all tail calls must return the same type (they return to the same context!), and-thus if the return type depends on an argument, that argument must always be the-same.--For instance, consider:--  let f :: forall a. a -> Char -> [a]-      f @a x c = ... f @a y 'a' ...-  in ... f @Int 1 'b' ... f @Int 2 'c' ...--(where the calls are tail calls). `f` fails the polymorphism rule because its-return type is [a], where [a] is bound. But since the type argument is always-'Int', we can rewrite it as:--  let f' :: Int -> Char -> [Int]-      f' x c = ... f' y 'a' ...-  in ... f' 1 'b' ... f 2 'c' ...--and now we can make f' a join point:--  join f' :: Int -> Char -> [Int]-       f' x c = ... jump f' y 'a' ...-  in ... jump f' 1 'b' ... jump f' 2 'c' ...--It's not clear that this comes up often, however. TODO: Measure how often and-add this analysis if necessary.  See #14620.---************************************************************************-*                                                                      *-\subsection{Sequencing on types}-*                                                                      *-************************************************************************--}--seqType :: Type -> ()-seqType (LitTy n)                   = n `seq` ()-seqType (TyVarTy tv)                = tv `seq` ()-seqType (AppTy t1 t2)               = seqType t1 `seq` seqType t2-seqType (FunTy _ t1 t2)             = seqType t1 `seq` seqType t2-seqType (TyConApp tc tys)           = tc `seq` seqTypes tys-seqType (ForAllTy (Bndr tv _) ty)   = seqType (varType tv) `seq` seqType ty-seqType (CastTy ty co)              = seqType ty `seq` seqCo co-seqType (CoercionTy co)             = seqCo co--seqTypes :: [Type] -> ()-seqTypes []       = ()-seqTypes (ty:tys) = seqType ty `seq` seqTypes tys--{--************************************************************************-*                                                                      *-                Comparison for types-        (We don't use instances so that we know where it happens)-*                                                                      *-************************************************************************--Note [Equality on AppTys]-~~~~~~~~~~~~~~~~~~~~~~~~~-In our cast-ignoring equality, we want to say that the following two-are equal:--  (Maybe |> co) (Int |> co')   ~?       Maybe Int--But the left is an AppTy while the right is a TyConApp. The solution is-to use repSplitAppTy_maybe to break up the TyConApp into its pieces and-then continue. Easy to do, but also easy to forget to do.---}--eqType :: Type -> Type -> Bool--- ^ Type equality on source types. Does not look through @newtypes@ or--- 'PredType's, but it does look through type synonyms.--- This first checks that the kinds of the types are equal and then--- checks whether the types are equal, ignoring casts and coercions.--- (The kind check is a recursive call, but since all kinds have type--- @Type@, there is no need to check the types of kinds.)--- See also Note [Non-trivial definitional equality] in TyCoRep.-eqType t1 t2 = isEqual $ nonDetCmpType t1 t2-  -- It's OK to use nonDetCmpType here and eqType is deterministic,-  -- nonDetCmpType does equality deterministically---- | Compare types with respect to a (presumably) non-empty 'RnEnv2'.-eqTypeX :: RnEnv2 -> Type -> Type -> Bool-eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2-  -- It's OK to use nonDetCmpType here and eqTypeX is deterministic,-  -- nonDetCmpTypeX does equality deterministically---- | Type equality on lists of types, looking through type synonyms--- but not newtypes.-eqTypes :: [Type] -> [Type] -> Bool-eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2-  -- It's OK to use nonDetCmpType here and eqTypes is deterministic,-  -- nonDetCmpTypes does equality deterministically--eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2--- Check that the var lists are the same length--- and have matching kinds; if so, extend the RnEnv2--- Returns Nothing if they don't match-eqVarBndrs env [] []- = Just env-eqVarBndrs env (tv1:tvs1) (tv2:tvs2)- | eqTypeX env (varType tv1) (varType tv2)- = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2-eqVarBndrs _ _ _= Nothing---- Now here comes the real worker--{--Note [nonDetCmpType nondeterminism]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX-uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for-ordering leads to nondeterminism. We hit the same problem in the TyVarTy case,-comparing type variables is nondeterministic, note the call to nonDetCmpVar in-nonDetCmpTypeX.-See Note [Unique Determinism] for more details.--}--nonDetCmpType :: Type -> Type -> Ordering-nonDetCmpType t1 t2-  -- we know k1 and k2 have the same kind, because they both have kind *.-  = nonDetCmpTypeX rn_env t1 t2-  where-    rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2]))--nonDetCmpTypes :: [Type] -> [Type] -> Ordering-nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2-  where-    rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2)))---- | An ordering relation between two 'Type's (known below as @t1 :: k1@--- and @t2 :: k2@)-data TypeOrdering = TLT  -- ^ @t1 < t2@-                  | TEQ  -- ^ @t1 ~ t2@ and there are no casts in either,-                         -- therefore we can conclude @k1 ~ k2@-                  | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so-                         -- they may differ in kind.-                  | TGT  -- ^ @t1 > t2@-                  deriving (Eq, Ord, Enum, Bounded)--nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering  -- Main workhorse-    -- See Note [Non-trivial definitional equality] in TyCoRep-nonDetCmpTypeX env orig_t1 orig_t2 =-    case go env orig_t1 orig_t2 of-      -- If there are casts then we also need to do a comparison of the kinds of-      -- the types being compared-      TEQX          -> toOrdering $ go env k1 k2-      ty_ordering   -> toOrdering ty_ordering-  where-    k1 = typeKind orig_t1-    k2 = typeKind orig_t2--    toOrdering :: TypeOrdering -> Ordering-    toOrdering TLT  = LT-    toOrdering TEQ  = EQ-    toOrdering TEQX = EQ-    toOrdering TGT  = GT--    liftOrdering :: Ordering -> TypeOrdering-    liftOrdering LT = TLT-    liftOrdering EQ = TEQ-    liftOrdering GT = TGT--    thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering-    thenCmpTy TEQ  rel  = rel-    thenCmpTy TEQX rel  = hasCast rel-    thenCmpTy rel  _    = rel--    hasCast :: TypeOrdering -> TypeOrdering-    hasCast TEQ = TEQX-    hasCast rel = rel--    -- Returns both the resulting ordering relation between the two types-    -- and whether either contains a cast.-    go :: RnEnv2 -> Type -> Type -> TypeOrdering-    go env t1 t2-      | Just t1' <- coreView t1 = go env t1' t2-      | Just t2' <- coreView t2 = go env t1 t2'--    go env (TyVarTy tv1)       (TyVarTy tv2)-      = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2-    go env (ForAllTy (Bndr tv1 _) t1) (ForAllTy (Bndr tv2 _) t2)-      = go env (varType tv1) (varType tv2)-        `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2-        -- See Note [Equality on AppTys]-    go env (AppTy s1 t1) ty2-      | Just (s2, t2) <- repSplitAppTy_maybe ty2-      = go env s1 s2 `thenCmpTy` go env t1 t2-    go env ty1 (AppTy s2 t2)-      | Just (s1, t1) <- repSplitAppTy_maybe ty1-      = go env s1 s2 `thenCmpTy` go env t1 t2-    go env (FunTy _ s1 t1) (FunTy _ s2 t2)-      = go env s1 s2 `thenCmpTy` go env t1 t2-    go env (TyConApp tc1 tys1) (TyConApp tc2 tys2)-      = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2-    go _   (LitTy l1)          (LitTy l2)          = liftOrdering (compare l1 l2)-    go env (CastTy t1 _)       t2                  = hasCast $ go env t1 t2-    go env t1                  (CastTy t2 _)       = hasCast $ go env t1 t2--    go _   (CoercionTy {})     (CoercionTy {})     = TEQ--        -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy-    go _ ty1 ty2-      = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2)-      where get_rank :: Type -> Int-            get_rank (CastTy {})-              = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2])-            get_rank (TyVarTy {})    = 0-            get_rank (CoercionTy {}) = 1-            get_rank (AppTy {})      = 3-            get_rank (LitTy {})      = 4-            get_rank (TyConApp {})   = 5-            get_rank (FunTy {})      = 6-            get_rank (ForAllTy {})   = 7--    gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering-    gos _   []         []         = TEQ-    gos _   []         _          = TLT-    gos _   _          []         = TGT-    gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2----------------nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering-nonDetCmpTypesX _   []        []        = EQ-nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2-                                          `thenCmp`-                                          nonDetCmpTypesX env tys1 tys2-nonDetCmpTypesX _   []        _         = LT-nonDetCmpTypesX _   _         []        = GT------------------ | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as--- recognized by Kind.isConstraintKindCon) which is considered a synonym for--- 'Type' in Core.--- See Note [Kind Constraint and kind Type] in Kind.--- See Note [nonDetCmpType nondeterminism]-nonDetCmpTc :: TyCon -> TyCon -> Ordering-nonDetCmpTc tc1 tc2-  = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) )-    u1 `nonDetCmpUnique` u2-  where-    u1  = tyConUnique tc1-    u2  = tyConUnique tc2--{--************************************************************************-*                                                                      *-        The kind of a type-*                                                                      *-************************************************************************--Note [typeKind vs tcTypeKind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We have two functions to get the kind of a type--  * typeKind   ignores  the distinction between Constraint and *-  * tcTypeKind respects the distinction between Constraint and *--tcTypeKind is used by the type inference engine, for which Constraint-and * are different; after that we use typeKind.--See also Note [coreView vs tcView]--Note [Kinding rules for types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In typeKind we consider Constraint and (TYPE LiftedRep) to be identical.-We then have--         t1 : TYPE rep1-         t2 : TYPE rep2-   (FUN) -----------------         t1 -> t2 : Type--         ty : TYPE rep-         `a` is not free in rep-(FORALL) ------------------------         forall a. ty : TYPE rep--In tcTypeKind we consider Constraint and (TYPE LiftedRep) to be distinct:--          t1 : TYPE rep1-          t2 : TYPE rep2-    (FUN) -----------------          t1 -> t2 : Type--          t1 : Constraint-          t2 : TYPE rep-  (PRED1) -----------------          t1 => t2 : Type--          t1 : Constraint-          t2 : Constraint-  (PRED2) ----------------------          t1 => t2 : Constraint--          ty : TYPE rep-          `a` is not free in rep-(FORALL1) ------------------------          forall a. ty : TYPE rep--          ty : Constraint-(FORALL2) --------------------------          forall a. ty : Constraint--Note that:-* The only way we distinguish '->' from '=>' is by the fact-  that the argument is a PredTy.  Both are FunTys--Note [Phantom type variables in kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--  type K (r :: RuntimeRep) = Type   -- Note 'r' is unused-  data T r :: K r                   -- T :: forall r -> K r-  foo :: forall r. T r--The body of the forall in foo's type has kind (K r), and-normally it would make no sense to have-   forall r. (ty :: K r)-because the kind of the forall would escape the binding-of 'r'.  But in this case it's fine because (K r) exapands-to Type, so we expliclity /permit/ the type-   forall r. T r--To accommodate such a type, in typeKind (forall a.ty) we use-occCheckExpand to expand any type synonyms in the kind of 'ty'-to eliminate 'a'.  See kinding rule (FORALL) in-Note [Kinding rules for types]--And in TcValidity.checkEscapingKind, we use also use-occCheckExpand, for the same reason.--}--------------------------------typeKind :: HasDebugCallStack => Type -> Kind--- No need to expand synonyms-typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys-typeKind (LitTy l)         = typeLiteralKind l-typeKind (FunTy {})        = liftedTypeKind-typeKind (TyVarTy tyvar)   = tyVarKind tyvar-typeKind (CastTy _ty co)   = coercionRKind co-typeKind (CoercionTy co)   = coercionType co--typeKind (AppTy fun arg)-  = go fun [arg]-  where-    -- Accumulate the type arguments, so we can call piResultTys,-    -- rather than a succession of calls to piResultTy (which is-    -- asymptotically costly as the number of arguments increases)-    go (AppTy fun arg) args = go fun (arg:args)-    go fun             args = piResultTys (typeKind fun) args--typeKind ty@(ForAllTy {})-  = case occCheckExpand tvs body_kind of-      -- We must make sure tv does not occur in kind-      -- As it is already out of scope!-      -- See Note [Phantom type variables in kinds]-      Just k' -> k'-      Nothing -> pprPanic "typeKind"-                  (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind)-  where-    (tvs, body) = splitTyVarForAllTys ty-    body_kind   = typeKind body-------------------------------------------------- Utilities to be used in Unify, which uses "tc" functions------------------------------------------------tcTypeKind :: HasDebugCallStack => Type -> Kind--- No need to expand synonyms-tcTypeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys-tcTypeKind (LitTy l)         = typeLiteralKind l-tcTypeKind (TyVarTy tyvar)   = tyVarKind tyvar-tcTypeKind (CastTy _ty co)   = coercionRKind co-tcTypeKind (CoercionTy co)   = coercionType co--tcTypeKind (FunTy { ft_af = af, ft_res = res })-  | InvisArg <- af-  , tcIsConstraintKind (tcTypeKind res)-  = constraintKind     -- Eq a => Ord a         :: Constraint-  | otherwise          -- Eq a => a -> a        :: TYPE LiftedRep-  = liftedTypeKind     -- Eq a => Array# Int    :: Type LiftedRep (not TYPE PtrRep)--tcTypeKind (AppTy fun arg)-  = go fun [arg]-  where-    -- Accumulate the type arguments, so we can call piResultTys,-    -- rather than a succession of calls to piResultTy (which is-    -- asymptotically costly as the number of arguments increases)-    go (AppTy fun arg) args = go fun (arg:args)-    go fun             args = piResultTys (tcTypeKind fun) args--tcTypeKind ty@(ForAllTy {})-  | tcIsConstraintKind body_kind-  = constraintKind--  | otherwise-  = case occCheckExpand tvs body_kind of-      -- We must make sure tv does not occur in kind-      -- As it is already out of scope!-      -- See Note [Phantom type variables in kinds]-      Just k' -> k'-      Nothing -> pprPanic "tcTypeKind"-                  (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind)-  where-    (tvs, body) = splitTyVarForAllTys ty-    body_kind = tcTypeKind body---isPredTy :: HasDebugCallStack => Type -> Bool--- See Note [Types for coercions, predicates, and evidence] in TyCoRep-isPredTy ty = tcIsConstraintKind (tcTypeKind ty)---- tcIsConstraintKind stuff only makes sense in the typechecker--- After that Constraint = Type--- See Note [coreView vs tcView]--- Defined here because it is used in isPredTy and tcRepSplitAppTy_maybe (sigh)-tcIsConstraintKind :: Kind -> Bool-tcIsConstraintKind ty-  | Just (tc, args) <- tcSplitTyConApp_maybe ty    -- Note: tcSplit here-  , isConstraintKindCon tc-  = ASSERT2( null args, ppr ty ) True--  | otherwise-  = False---- | Is this kind equivalent to @*@?------ This considers 'Constraint' to be distinct from @*@. For a version that--- treats them as the same type, see 'isLiftedTypeKind'.-tcIsLiftedTypeKind :: Kind -> Bool-tcIsLiftedTypeKind ty-  | Just (tc, [arg]) <- tcSplitTyConApp_maybe ty    -- Note: tcSplit here-  , tc `hasKey` tYPETyConKey-  = isLiftedRuntimeRep arg-  | otherwise-  = False---- | Is this kind equivalent to @TYPE r@ (for some unknown r)?------ This considers 'Constraint' to be distinct from @*@.-tcIsRuntimeTypeKind :: Kind -> Bool-tcIsRuntimeTypeKind ty-  | Just (tc, _) <- tcSplitTyConApp_maybe ty    -- Note: tcSplit here-  , tc `hasKey` tYPETyConKey-  = True-  | otherwise-  = False--tcReturnsConstraintKind :: Kind -> Bool--- True <=> the Kind ultimately returns a Constraint---   E.g.  * -> Constraint---         forall k. k -> Constraint-tcReturnsConstraintKind kind-  | Just kind' <- tcView kind = tcReturnsConstraintKind kind'-tcReturnsConstraintKind (ForAllTy _ ty)         = tcReturnsConstraintKind ty-tcReturnsConstraintKind (FunTy { ft_res = ty }) = tcReturnsConstraintKind ty-tcReturnsConstraintKind (TyConApp tc _)         = isConstraintKindCon tc-tcReturnsConstraintKind _                       = False-----------------------------typeLiteralKind :: TyLit -> Kind-typeLiteralKind (NumTyLit {}) = typeNatKind-typeLiteralKind (StrTyLit {}) = typeSymbolKind---- | Returns True if a type is levity polymorphic. Should be the same--- as (isKindLevPoly . typeKind) but much faster.--- Precondition: The type has kind (TYPE blah)-isTypeLevPoly :: Type -> Bool-isTypeLevPoly = go-  where-    go ty@(TyVarTy {})                           = check_kind ty-    go ty@(AppTy {})                             = check_kind ty-    go ty@(TyConApp tc _) | not (isTcLevPoly tc) = False-                          | otherwise            = check_kind ty-    go (ForAllTy _ ty)                           = go ty-    go (FunTy {})                                = False-    go (LitTy {})                                = False-    go ty@(CastTy {})                            = check_kind ty-    go ty@(CoercionTy {})                        = pprPanic "isTypeLevPoly co" (ppr ty)--    check_kind = isKindLevPoly . typeKind---- | Looking past all pi-types, is the end result potentially levity polymorphic?--- Example: True for (forall r (a :: TYPE r). String -> a)--- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type)-resultIsLevPoly :: Type -> Bool-resultIsLevPoly = isTypeLevPoly . snd . splitPiTys---{- **********************************************************************-*                                                                       *-           Occurs check expansion-%*                                                                      *-%********************************************************************* -}--{- Note [Occurs check expansion]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid-of occurrences of tv outside type function arguments, if that is-possible; otherwise, it returns Nothing.--For example, suppose we have-  type F a b = [a]-Then-  occCheckExpand b (F Int b) = Just [Int]-but-  occCheckExpand a (F a Int) = Nothing--We don't promise to do the absolute minimum amount of expanding-necessary, but we try not to do expansions we don't need to.  We-prefer doing inner expansions first.  For example,-  type F a b = (a, Int, a, [a])-  type G b   = Char-We have-  occCheckExpand b (F (G b)) = Just (F Char)-even though we could also expand F to get rid of b.--}--occCheckExpand :: [Var] -> Type -> Maybe Type--- See Note [Occurs check expansion]--- We may have needed to do some type synonym unfolding in order to--- get rid of the variable (or forall), so we also return the unfolded--- version of the type, which is guaranteed to be syntactically free--- of the given type variable.  If the type is already syntactically--- free of the variable, then the same type is returned.-occCheckExpand vs_to_avoid ty-  | null vs_to_avoid  -- Efficient shortcut-  = Just ty           -- Can happen, eg. GHC.Core.Utils.mkSingleAltCase--  | otherwise-  = go (mkVarSet vs_to_avoid, emptyVarEnv) ty-  where-    go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type-          -- The VarSet is the set of variables we are trying to avoid-          -- The VarEnv carries mappings necessary-          -- because of kind expansion-    go cxt@(as, env) (TyVarTy tv')-      | tv' `elemVarSet` as               = Nothing-      | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'')-      | otherwise                         = do { tv'' <- go_var cxt tv'-                                               ; return (mkTyVarTy tv'') }--    go _   ty@(LitTy {}) = return ty-    go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1-                                ; ty2' <- go cxt ty2-                                ; return (mkAppTy ty1' ty2') }-    go cxt ty@(FunTy _ ty1 ty2)-       = do { ty1' <- go cxt ty1-            ; ty2' <- go cxt ty2-            ; return (ty { ft_arg = ty1', ft_res = ty2' }) }-    go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty)-       = do { ki' <- go cxt (varType tv)-            ; let tv' = setVarType tv ki'-                  env' = extendVarEnv env tv tv'-                  as'  = as `delVarSet` tv-            ; body' <- go (as', env') body_ty-            ; return (ForAllTy (Bndr tv' vis) body') }--    -- For a type constructor application, first try expanding away the-    -- offending variable from the arguments.  If that doesn't work, next-    -- see if the type constructor is a type synonym, and if so, expand-    -- it and try again.-    go cxt ty@(TyConApp tc tys)-      = case mapM (go cxt) tys of-          Just tys' -> return (mkTyConApp tc tys')-          Nothing | Just ty' <- tcView ty -> go cxt ty'-                  | otherwise             -> Nothing-                      -- Failing that, try to expand a synonym--    go cxt (CastTy ty co) =  do { ty' <- go cxt ty-                                ; co' <- go_co cxt co-                                ; return (mkCastTy ty' co') }-    go cxt (CoercionTy co) = do { co' <- go_co cxt co-                                ; return (mkCoercionTy co') }--    -------------------    go_var cxt v = do { k' <- go cxt (varType v)-                      ; return (setVarType v k') }-           -- Works for TyVar and CoVar-           -- See Note [Occurrence checking: look inside kinds]--    -------------------    go_mco _   MRefl = return MRefl-    go_mco ctx (MCo co) = MCo <$> go_co ctx co--    -------------------    go_co cxt (Refl ty)                 = do { ty' <- go cxt ty-                                             ; return (mkNomReflCo ty') }-    go_co cxt (GRefl r ty mco)          = do { mco' <- go_mco cxt mco-                                             ; ty' <- go cxt ty-                                             ; return (mkGReflCo r ty' mco') }-      -- Note: Coercions do not contain type synonyms-    go_co cxt (TyConAppCo r tc args)    = do { args' <- mapM (go_co cxt) args-                                             ; return (mkTyConAppCo r tc args') }-    go_co cxt (AppCo co arg)            = do { co' <- go_co cxt co-                                             ; arg' <- go_co cxt arg-                                             ; return (mkAppCo co' arg') }-    go_co cxt@(as, env) (ForAllCo tv kind_co body_co)-      = do { kind_co' <- go_co cxt kind_co-           ; let tv' = setVarType tv $-                       coercionLKind kind_co'-                 env' = extendVarEnv env tv tv'-                 as'  = as `delVarSet` tv-           ; body' <- go_co (as', env') body_co-           ; return (ForAllCo tv' kind_co' body') }-    go_co cxt (FunCo r co1 co2)         = do { co1' <- go_co cxt co1-                                             ; co2' <- go_co cxt co2-                                             ; return (mkFunCo r co1' co2') }-    go_co cxt@(as,env) (CoVarCo c)-      | c `elemVarSet` as               = Nothing-      | Just c' <- lookupVarEnv env c   = return (mkCoVarCo c')-      | otherwise                       = do { c' <- go_var cxt c-                                             ; return (mkCoVarCo c') }-    go_co cxt (HoleCo h)                = do { c' <- go_var cxt (ch_co_var h)-                                             ; return (HoleCo (h { ch_co_var = c' })) }-    go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args-                                             ; return (mkAxiomInstCo ax ind args') }-    go_co cxt (UnivCo p r ty1 ty2)      = do { p' <- go_prov cxt p-                                             ; ty1' <- go cxt ty1-                                             ; ty2' <- go cxt ty2-                                             ; return (mkUnivCo p' r ty1' ty2') }-    go_co cxt (SymCo co)                = do { co' <- go_co cxt co-                                             ; return (mkSymCo co') }-    go_co cxt (TransCo co1 co2)         = do { co1' <- go_co cxt co1-                                             ; co2' <- go_co cxt co2-                                             ; return (mkTransCo co1' co2') }-    go_co cxt (NthCo r n co)            = do { co' <- go_co cxt co-                                             ; return (mkNthCo r n co') }-    go_co cxt (LRCo lr co)              = do { co' <- go_co cxt co-                                             ; return (mkLRCo lr co') }-    go_co cxt (InstCo co arg)           = do { co' <- go_co cxt co-                                             ; arg' <- go_co cxt arg-                                             ; return (mkInstCo co' arg') }-    go_co cxt (KindCo co)               = do { co' <- go_co cxt co-                                             ; return (mkKindCo co') }-    go_co cxt (SubCo co)                = do { co' <- go_co cxt co-                                             ; return (mkSubCo co') }-    go_co cxt (AxiomRuleCo ax cs)       = do { cs' <- mapM (go_co cxt) cs-                                             ; return (mkAxiomRuleCo ax cs') }--    -------------------    go_prov cxt (PhantomProv co)    = PhantomProv <$> go_co cxt co-    go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co-    go_prov _   p@(PluginProv _)    = return p---{--%************************************************************************-%*                                                                      *-        Miscellaneous functions-%*                                                                      *-%************************************************************************---}--- | All type constructors occurring in the type; looking through type---   synonyms, but not newtypes.---  When it finds a Class, it returns the class TyCon.-tyConsOfType :: Type -> UniqSet TyCon-tyConsOfType ty-  = go ty-  where-     go :: Type -> UniqSet TyCon  -- The UniqSet does duplicate elim-     go ty | Just ty' <- coreView ty = go ty'-     go (TyVarTy {})                = emptyUniqSet-     go (LitTy {})                  = emptyUniqSet-     go (TyConApp tc tys)           = go_tc tc `unionUniqSets` go_s tys-     go (AppTy a b)                 = go a `unionUniqSets` go b-     go (FunTy _ a b)               = go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon-     go (ForAllTy (Bndr tv _) ty)   = go ty `unionUniqSets` go (varType tv)-     go (CastTy ty co)              = go ty `unionUniqSets` go_co co-     go (CoercionTy co)             = go_co co--     go_co (Refl ty)               = go ty-     go_co (GRefl _ ty mco)        = go ty `unionUniqSets` go_mco mco-     go_co (TyConAppCo _ tc args)  = go_tc tc `unionUniqSets` go_cos args-     go_co (AppCo co arg)          = go_co co `unionUniqSets` go_co arg-     go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co-     go_co (FunCo _ co1 co2)       = go_co co1 `unionUniqSets` go_co co2-     go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args-     go_co (UnivCo p _ t1 t2)      = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2-     go_co (CoVarCo {})            = emptyUniqSet-     go_co (HoleCo {})             = emptyUniqSet-     go_co (SymCo co)              = go_co co-     go_co (TransCo co1 co2)       = go_co co1 `unionUniqSets` go_co co2-     go_co (NthCo _ _ co)          = go_co co-     go_co (LRCo _ co)             = go_co co-     go_co (InstCo co arg)         = go_co co `unionUniqSets` go_co arg-     go_co (KindCo co)             = go_co co-     go_co (SubCo co)              = go_co co-     go_co (AxiomRuleCo _ cs)      = go_cos cs--     go_mco MRefl    = emptyUniqSet-     go_mco (MCo co) = go_co co--     go_prov (PhantomProv co)    = go_co co-     go_prov (ProofIrrelProv co) = go_co co-     go_prov (PluginProv _)      = emptyUniqSet-        -- this last case can happen from the tyConsOfType used from-        -- checkTauTvUpdate--     go_s tys     = foldr (unionUniqSets . go)     emptyUniqSet tys-     go_cos cos   = foldr (unionUniqSets . go_co)  emptyUniqSet cos--     go_tc tc = unitUniqSet tc-     go_ax ax = go_tc $ coAxiomTyCon ax---- | Find the result 'Kind' of a type synonym,--- after applying it to its 'arity' number of type variables--- Actually this function works fine on data types too,--- but they'd always return '*', so we never need to ask-synTyConResKind :: TyCon -> Kind-synTyConResKind tycon = piResultTys (tyConKind tycon) (mkTyVarTys (tyConTyVars tycon))---- | Retrieve the free variables in this type, splitting them based--- on whether they are used visibly or invisibly. Invisible ones come--- first.-splitVisVarsOfType :: Type -> Pair TyCoVarSet-splitVisVarsOfType orig_ty = Pair invis_vars vis_vars-  where-    Pair invis_vars1 vis_vars = go orig_ty-    invis_vars = invis_vars1 `minusVarSet` vis_vars--    go (TyVarTy tv)      = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv)-    go (AppTy t1 t2)     = go t1 `mappend` go t2-    go (TyConApp tc tys) = go_tc tc tys-    go (FunTy _ t1 t2)   = go t1 `mappend` go t2-    go (ForAllTy (Bndr tv _) ty)-      = ((`delVarSet` tv) <$> go ty) `mappend`-        (invisible (tyCoVarsOfType $ varType tv))-    go (LitTy {}) = mempty-    go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co)-    go (CoercionTy co) = invisible $ tyCoVarsOfCo co--    invisible vs = Pair vs emptyVarSet--    go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in-                   invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis--splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet-splitVisVarsOfTypes = foldMap splitVisVarsOfType--modifyJoinResTy :: Int            -- Number of binders to skip-                -> (Type -> Type) -- Function to apply to result type-                -> Type           -- Type of join point-                -> Type           -- New type--- INVARIANT: If any of the first n binders are foralls, those tyvars cannot--- appear in the original result type. See isValidJoinPointType.-modifyJoinResTy orig_ar f orig_ty-  = go orig_ar orig_ty-  where-    go 0 ty = f ty-    go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty-            = mkPiTy arg_bndr (go (n-1) res_ty)-            | otherwise-            = pprPanic "modifyJoinResTy" (ppr orig_ar <+> ppr orig_ty)--setJoinResTy :: Int  -- Number of binders to skip-             -> Type -- New result type-             -> Type -- Type of join point-             -> Type -- New type--- INVARIANT: Same as for modifyJoinResTy-setJoinResTy ar new_res_ty ty-  = modifyJoinResTy ar (const new_res_ty) ty--{--************************************************************************-*                                                                      *-        Functions over Kinds-*                                                                      *-************************************************************************--Note [Kind Constraint and kind Type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The kind Constraint is the kind of classes and other type constraints.-The special thing about types of kind Constraint is that- * They are displayed with double arrow:-     f :: Ord a => a -> a- * They are implicitly instantiated at call sites; so the type inference-   engine inserts an extra argument of type (Ord a) at every call site-   to f.--However, once type inference is over, there is *no* distinction between-Constraint and Type. Indeed we can have coercions between the two. Consider-   class C a where-     op :: a -> a-For this single-method class we may generate a newtype, which in turn-generates an axiom witnessing-    C a ~ (a -> a)-so on the left we have Constraint, and on the right we have Type.-See #7451.--Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with-distinct uniques, they are treated as equal at all times except-during type inference.--}--isConstraintKindCon :: TyCon -> Bool-isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey---- | Tests whether the given kind (which should look like @TYPE x@)--- is something other than a constructor tree (that is, constructors at every node).--- E.g.  True of   TYPE k, TYPE (F Int)---       False of  TYPE 'LiftedRep-isKindLevPoly :: Kind -> Bool-isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k )-                    -- the isLiftedTypeKind check is necessary b/c of Constraint-                  go k-  where-    go ty | Just ty' <- coreView ty = go ty'-    go TyVarTy{}         = True-    go AppTy{}           = True  -- it can't be a TyConApp-    go (TyConApp tc tys) = isFamilyTyCon tc || any go tys-    go ForAllTy{}        = True-    go (FunTy _ t1 t2)   = go t1 || go t2-    go LitTy{}           = False-    go CastTy{}          = True-    go CoercionTy{}      = True--    _is_type = classifiesTypeWithValues k----------------------------------------------              Subkinding--- The tc variants are used during type-checking, where ConstraintKind--- is distinct from all other kinds--- After type-checking (in core), Constraint and liftedTypeKind are--- indistinguishable---- | Does this classify a type allowed to have values? Responds True to things--- like *, #, TYPE Lifted, TYPE v, Constraint.-classifiesTypeWithValues :: Kind -> Bool--- ^ True of any sub-kind of OpenTypeKind-classifiesTypeWithValues k = isJust (kindRep_maybe k)--{--%************************************************************************-%*                                                                      *-         Pretty-printing-%*                                                                      *-%************************************************************************--Most pretty-printing is either in TyCoRep or GHC.Iface.Type.---}---- | Does a 'TyCon' (that is applied to some number of arguments) need to be--- ascribed with an explicit kind signature to resolve ambiguity if rendered as--- a source-syntax type?--- (See @Note [When does a tycon application need an explicit kind signature?]@--- for a full explanation of what this function checks for.)-tyConAppNeedsKindSig-  :: Bool  -- ^ Should specified binders count towards injective positions in-           --   the kind of the TyCon? (If you're using visible kind-           --   applications, then you want True here.-  -> TyCon-  -> Int   -- ^ The number of args the 'TyCon' is applied to.-  -> Bool  -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the-           --   number of arguments)-tyConAppNeedsKindSig spec_inj_pos tc n_args-  | LT <- listLengthCmp tc_binders n_args-  = False-  | otherwise-  = let (dropped_binders, remaining_binders)-          = splitAt n_args tc_binders-        result_kind  = mkTyConKind remaining_binders tc_res_kind-        result_vars  = tyCoVarsOfType result_kind-        dropped_vars = fvVarSet $-                       mapUnionFV injective_vars_of_binder dropped_binders--    in not (subVarSet result_vars dropped_vars)-  where-    tc_binders  = tyConBinders tc-    tc_res_kind = tyConResKind tc--    -- Returns the variables that would be fixed by knowing a TyConBinder. See-    -- Note [When does a tycon application need an explicit kind signature?]-    -- for a more detailed explanation of what this function does.-    injective_vars_of_binder :: TyConBinder -> FV-    injective_vars_of_binder (Bndr tv vis) =-      case vis of-        AnonTCB VisArg -> injectiveVarsOfType False -- conservative choice-                                              (varType tv)-        NamedTCB argf  | source_of_injectivity argf-                       -> unitFV tv `unionFV`-                          injectiveVarsOfType False (varType tv)-        _              -> emptyFV--    source_of_injectivity Required  = True-    source_of_injectivity Specified = spec_inj_pos-    source_of_injectivity Inferred  = False--{--Note [When does a tycon application need an explicit kind signature?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are a couple of places in GHC where we convert Core Types into forms that-more closely resemble user-written syntax. These include:--1. Template Haskell Type reification (see, for instance, TcSplice.reify_tc_app)-2. Converting Types to LHsTypes (in GHC.Hs.Utils.typeToLHsType, or in Haddock)--This conversion presents a challenge: how do we ensure that the resulting type-has enough kind information so as not to be ambiguous? To better motivate this-question, consider the following Core type:--  -- Foo :: Type -> Type-  type Foo = Proxy Type--There is nothing ambiguous about the RHS of Foo in Core. But if we were to,-say, reify it into a TH Type, then it's tempting to just drop the invisible-Type argument and simply return `Proxy`. But now we've lost crucial kind-information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool`-or `Proxy Int` or something else! We've inadvertently introduced ambiguity.--Unlike in other situations in GHC, we can't just turn on--fprint-explicit-kinds, as we need to produce something which has the same-structure as a source-syntax type. Moreover, we can't rely on visible kind-application, since the first kind argument to Proxy is inferred, not specified.-Our solution is to annotate certain tycons with their kinds whenever they-appear in applied form in order to resolve the ambiguity. For instance, we-would reify the RHS of Foo like so:--  type Foo = (Proxy :: Type -> Type)--We need to devise an algorithm that determines precisely which tycons need-these explicit kind signatures. We certainly don't want to annotate _every_-tycon with a kind signature, or else we might end up with horribly bloated-types like the following:--  (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type)--We only want to annotate tycons that absolutely require kind signatures in-order to resolve some sort of ambiguity, and nothing more.--Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type-require a kind signature? It might require it when we need to fill in any of-T's omitted arguments. By "omitted argument", we mean one that is dropped when-reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and-specified arguments (e.g., TH reification in TcSplice), and sometimes the-omitted arguments are only the inferred ones (e.g., in GHC.Hs.Utils.typeToLHsType,-which reifies specified arguments through visible kind application).-Regardless, the key idea is that _some_ arguments are going to be omitted after-reification, and the only mechanism we have at our disposal for filling them in-is through explicit kind signatures.--What do we mean by "fill in"? Let's consider this small example:--  T :: forall {k}. Type -> (k -> Type) -> k--Moreover, we have this application of T:--  T @{j} Int aty--When we reify this type, we omit the inferred argument @{j}. Is it fixed by the-other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then-we'll generate an equality constraint (kappa -> Type) and, assuming we can-solve it, that will fix `kappa`. (Here, `kappa` is the unification variable-that we instantiate `k` with.)--Therefore, for any application of a tycon T to some arguments, the Question We-Must Answer is:--* Given the first n arguments of T, do the kinds of the non-omitted arguments-  fill in the omitted arguments?--(This is still a bit hand-wavey, but we'll refine this question incrementally-as we explain more of the machinery underlying this process.)--Answering this question is precisely the role that the `injectiveVarsOfType`-and `injective_vars_of_binder` functions exist to serve. If an omitted argument-`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing-`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a-bit.)--More formally, if-`a` is in `injectiveVarsOfType ty`-and  S1(ty) ~ S2(ty),-then S1(a)  ~ S2(a),-where S1 and S2 are arbitrary substitutions.--For example, is `F` is a non-injective type family, then--  injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c}--Now that we know what this function does, here is a second attempt at the-Question We Must Answer:--* Given the first n arguments of T (ty_1 ... ty_n), consider the binders-  of T that are instantiated by non-omitted arguments. Do the injective-  variables of these binders fill in the remainder of T's kind?--Alright, we're getting closer. Next, we need to clarify what the injective-variables of a tycon binder are. This the role that the-`injective_vars_of_binder` function serves. Here is what this function does for-each form of tycon binder:--* Anonymous binders are injective positions. For example, in the promoted data-  constructor '(:):--    '(:) :: forall a. a -> [a] -> [a]--  The second and third tyvar binders (of kinds `a` and `[a]`) are both-  anonymous, so if we had '(:) 'True '[], then the kinds of 'True and-  '[] would contribute to the kind of '(:) 'True '[]. Therefore,-  injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}.-  (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.)-* Named binders:-  - Inferred binders are never injective positions. For example, in this data-    type:--      data Proxy a-      Proxy :: forall {k}. k -> Type--    If we had Proxy 'True, then the kind of 'True would not contribute to the-    kind of Proxy 'True. Therefore,-    injective_vars_of_binder(forall {k}. ...) = {}.-  - Required binders are injective positions. For example, in this data type:--      data Wurble k (a :: k) :: k-      Wurble :: forall k -> k -> k--  The first tyvar binder (of kind `forall k`) has required visibility, so if-  we had Wurble (Maybe a) Nothing, then the kind of Maybe a would-  contribute to the kind of Wurble (Maybe a) Nothing. Hence,-  injective_vars_of_binder(forall a -> ...) = {a}.-  - Specified binders /might/ be injective positions, depending on how you-    approach things. Continuing the '(:) example:--      '(:) :: forall a. a -> [a] -> [a]--    Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind-    of '(:) 'True '[], since it's not explicitly instantiated by the user. But-    if visible kind application is enabled, then this is possible, since the-    user can write '(:) @Bool 'True '[]. (In that case,-    injective_vars_of_binder(forall a. ...) = {a}.)--    There are some situations where using visible kind application is appropriate-    (e.g., GHC.Hs.Utils.typeToLHsType) and others where it is not (e.g., TH-    reification), so the `injective_vars_of_binder` function is parametrized by-    a Bool which decides if specified binders should be counted towards-    injective positions or not.--Now that we've defined injective_vars_of_binder, we can refine the Question We-Must Answer once more:--* Given the first n arguments of T (ty_1 ... ty_n), consider the binders-  of T that are instantiated by non-omitted arguments. For each such binder-  b_i, take the union of all injective_vars_of_binder(b_i). Is this set a-  superset of the free variables of the remainder of T's kind?--If the answer to this question is "no", then (T ty_1 ... ty_n) needs an-explicit kind signature, since T's kind has kind variables leftover that-aren't fixed by the non-omitted arguments.--One last sticking point: what does "the remainder of T's kind" mean? You might-be tempted to think that it corresponds to all of the arguments in the kind of-T that would normally be instantiated by omitted arguments. But this isn't-quite right, strictly speaking. Consider the following (silly) example:--  S :: forall {k}. Type -> Type--And suppose we have this application of S:--  S Int Bool--The Int argument would be omitted, and-injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which-might suggest that (S Bool) needs an explicit kind signature. But-(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature-only affects the /result/ of the application, not all of the individual-arguments. So adding a kind signature here won't make a difference. Therefore,-the fourth (and final) iteration of the Question We Must Answer is:--* Given the first n arguments of T (ty_1 ... ty_n), consider the binders-  of T that are instantiated by non-omitted arguments. For each such binder-  b_i, take the union of all injective_vars_of_binder(b_i). Is this set a-  superset of the free variables of the kind of (T ty_1 ... ty_n)?--Phew, that was a lot of work!--How can be sure that this is correct? That is, how can we be sure that in the-event that we leave off a kind annotation, that one could infer the kind of the-tycon application from its arguments? It's essentially a proof by induction: if-we can infer the kinds of every subtree of a type, then the whole tycon-application will have an inferrable kind--unless, of course, the remainder of-the tycon application's kind has uninstantiated kind variables.--What happens if T is oversaturated? That is, if T's kind has fewer than n-arguments, in the case that the concrete application instantiates a result-kind variable with an arrow kind? If we run out of arguments, we do not attach-a kind annotation. This should be a rare case, indeed. Here is an example:--   data T1 :: k1 -> k2 -> *-   data T2 :: k1 -> k2 -> *--   type family G (a :: k) :: k-   type instance G T1 = T2--   type instance F Char = (G T1 Bool :: (* -> *) -> *)   -- F from above--Here G's kind is (forall k. k -> k), and the desugared RHS of that last-instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to-the algorithm above, there are 3 arguments to G so we should peel off 3-arguments in G's kind. But G's kind has only two arguments. This is the-rare special case, and we choose not to annotate the application of G with-a kind signature. After all, we needn't do this, since that instance would-be reified as:--   type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool--So the kind of G isn't ambiguous anymore due to the explicit kind annotation-on its argument. See #8953 and test th/T8953.--}
− compiler/types/Type.hs-boot 
@@ -1,26 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Type where--import GhcPrelude-import TyCon-import {-# SOURCE #-} TyCoRep( Type, Coercion )-import Util--isPredTy     :: HasDebugCallStack => Type -> Bool-isCoercionTy :: Type -> Bool--mkAppTy    :: Type -> Type -> Type-mkCastTy   :: Type -> Coercion -> Type-piResultTy :: HasDebugCallStack => Type -> Type -> Type--eqType :: Type -> Type -> Bool--coreView :: Type -> Maybe Type-tcView :: Type -> Maybe Type-isRuntimeRepTy :: Type -> Bool-isLiftedTypeKind :: Type -> Bool--splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])--partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type])
− compiler/types/Unify.hs 
@@ -1,1592 +0,0 @@--- (c) The University of Glasgow 2006--{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}--module Unify (-        tcMatchTy, tcMatchTyKi,-        tcMatchTys, tcMatchTyKis,-        tcMatchTyX, tcMatchTysX, tcMatchTyKisX,-        tcMatchTyX_BM, ruleMatchTyKiX,--        -- * Rough matching-        roughMatchTcs, instanceCantMatch,-        typesCantMatch,--        -- Side-effect free unification-        tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis,-        tcUnifyTysFG, tcUnifyTyWithTFs,-        BindFlag(..),-        UnifyResult, UnifyResultM(..),--        -- Matching a type against a lifted type (coercion)-        liftCoMatch-   ) where--#include "HsVersions.h"--import GhcPrelude--import Var-import VarEnv-import VarSet-import Name( Name )-import Type hiding ( getTvSubstEnv )-import Coercion hiding ( getCvSubstEnv )-import TyCon-import TyCoRep-import TyCoFVs ( tyCoVarsOfCoList, tyCoFVsOfTypes )-import TyCoSubst ( mkTvSubst )-import FV( FV, fvVarSet, fvVarList )-import Util-import Pair-import Outputable-import UniqFM-import UniqSet--import Control.Monad-import qualified Control.Monad.Fail as MonadFail-import Control.Applicative hiding ( empty )-import qualified Control.Applicative--{---Unification is much tricker than you might think.--1. The substitution we generate binds the *template type variables*-   which are given to us explicitly.--2. We want to match in the presence of foralls;-        e.g     (forall a. t1) ~ (forall b. t2)--   That is what the RnEnv2 is for; it does the alpha-renaming-   that makes it as if a and b were the same variable.-   Initialising the RnEnv2, so that it can generate a fresh-   binder when necessary, entails knowing the free variables of-   both types.--3. We must be careful not to bind a template type variable to a-   locally bound variable.  E.g.-        (forall a. x) ~ (forall b. b)-   where x is the template type variable.  Then we do not want to-   bind x to a/b!  This is a kind of occurs check.-   The necessary locals accumulate in the RnEnv2.--Note [tcMatchTy vs tcMatchTyKi]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This module offers two variants of matching: with kinds and without.-The TyKi variant takes two types, of potentially different kinds,-and matches them. Along the way, it necessarily also matches their-kinds. The Ty variant instead assumes that the kinds are already-eqType and so skips matching up the kinds.--How do you choose between them?--1. If you know that the kinds of the two types are eqType, use-   the Ty variant. It is more efficient, as it does less work.--2. If the kinds of variables in the template type might mention type families,-   use the Ty variant (and do other work to make sure the kinds-   work out). These pure unification functions do a straightforward-   syntactic unification and do no complex reasoning about type-   families. Note that the types of the variables in instances can indeed-   mention type families, so instance lookup must use the Ty variant.--   (Nothing goes terribly wrong -- no panics -- if there might be type-   families in kinds in the TyKi variant. You just might get match-   failure even though a reducing a type family would lead to success.)--3. Otherwise, if you're sure that the variable kinds do not mention-   type families and you're not already sure that the kind of the template-   equals the kind of the target, then use the TyKi version.--}---- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1))--- @s@ such that @s(t1)@ equals @t2@.--- The returned substitution might bind coercion variables,--- if the variable is an argument to a GADT constructor.------ Precondition: typeKind ty1 `eqType` typeKind ty2------ We don't pass in a set of "template variables" to be bound--- by the match, because tcMatchTy (and similar functions) are--- always used on top-level types, so we can bind any of the--- free variables of the LHS.--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTy :: Type -> Type -> Maybe TCvSubst-tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2]--tcMatchTyX_BM :: (TyVar -> BindFlag) -> TCvSubst-              -> Type -> Type -> Maybe TCvSubst-tcMatchTyX_BM bind_me subst ty1 ty2-  = tc_match_tys_x bind_me False subst [ty1] [ty2]---- | Like 'tcMatchTy', but allows the kinds of the types to differ,--- and thus matches them as well.--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTyKi :: Type -> Type -> Maybe TCvSubst-tcMatchTyKi ty1 ty2-  = tc_match_tys (const BindMe) True [ty1] [ty2]---- | This is similar to 'tcMatchTy', but extends a substitution--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTyX :: TCvSubst            -- ^ Substitution to extend-           -> Type                -- ^ Template-           -> Type                -- ^ Target-           -> Maybe TCvSubst-tcMatchTyX subst ty1 ty2-  = tc_match_tys_x (const BindMe) False subst [ty1] [ty2]---- | Like 'tcMatchTy' but over a list of types.--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTys :: [Type]         -- ^ Template-           -> [Type]         -- ^ Target-           -> Maybe TCvSubst -- ^ One-shot; in principle the template-                             -- variables could be free in the target-tcMatchTys tys1 tys2-  = tc_match_tys (const BindMe) False tys1 tys2---- | Like 'tcMatchTyKi' but over a list of types.--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTyKis :: [Type]         -- ^ Template-             -> [Type]         -- ^ Target-             -> Maybe TCvSubst -- ^ One-shot substitution-tcMatchTyKis tys1 tys2-  = tc_match_tys (const BindMe) True tys1 tys2---- | Like 'tcMatchTys', but extending a substitution--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTysX :: TCvSubst       -- ^ Substitution to extend-            -> [Type]         -- ^ Template-            -> [Type]         -- ^ Target-            -> Maybe TCvSubst -- ^ One-shot substitution-tcMatchTysX subst tys1 tys2-  = tc_match_tys_x (const BindMe) False subst tys1 tys2---- | Like 'tcMatchTyKis', but extending a substitution--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTyKisX :: TCvSubst        -- ^ Substitution to extend-              -> [Type]          -- ^ Template-              -> [Type]          -- ^ Target-              -> Maybe TCvSubst  -- ^ One-shot substitution-tcMatchTyKisX subst tys1 tys2-  = tc_match_tys_x (const BindMe) True subst tys1 tys2---- | Same as tc_match_tys_x, but starts with an empty substitution-tc_match_tys :: (TyVar -> BindFlag)-               -> Bool          -- ^ match kinds?-               -> [Type]-               -> [Type]-               -> Maybe TCvSubst-tc_match_tys bind_me match_kis tys1 tys2-  = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) tys1 tys2-  where-    in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2)---- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX'-tc_match_tys_x :: (TyVar -> BindFlag)-               -> Bool          -- ^ match kinds?-               -> TCvSubst-               -> [Type]-               -> [Type]-               -> Maybe TCvSubst-tc_match_tys_x bind_me match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2-  = case tc_unify_tys bind_me-                      False  -- Matching, not unifying-                      False  -- Not an injectivity check-                      match_kis-                      (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of-      Unifiable (tv_env', cv_env')-        -> Just $ TCvSubst in_scope tv_env' cv_env'-      _ -> Nothing---- | This one is called from the expression matcher,--- which already has a MatchEnv in hand-ruleMatchTyKiX-  :: TyCoVarSet          -- ^ template variables-  -> RnEnv2-  -> TvSubstEnv          -- ^ type substitution to extend-  -> Type                -- ^ Template-  -> Type                -- ^ Target-  -> Maybe TvSubstEnv-ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target--- See Note [Kind coercions in Unify]-  = case tc_unify_tys (matchBindFun tmpl_tvs) False False-                      True -- <-- this means to match the kinds-                      rn_env tenv emptyCvSubstEnv [tmpl] [target] of-      Unifiable (tenv', _) -> Just tenv'-      _                    -> Nothing--matchBindFun :: TyCoVarSet -> TyVar -> BindFlag-matchBindFun tvs tv = if tv `elemVarSet` tvs then BindMe else Skolem---{- *********************************************************************-*                                                                      *-                Rough matching-*                                                                      *-********************************************************************* -}---- See Note [Rough match] field in InstEnv--roughMatchTcs :: [Type] -> [Maybe Name]-roughMatchTcs tys = map rough tys-  where-    rough ty-      | Just (ty', _) <- splitCastTy_maybe ty   = rough ty'-      | Just (tc,_)   <- splitTyConApp_maybe ty = Just (tyConName tc)-      | otherwise                               = Nothing--instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool--- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot--- possibly be instantiated to actual, nor vice versa;--- False is non-committal-instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as-instanceCantMatch _         _         =  False  -- Safe--itemCantMatch :: Maybe Name -> Maybe Name -> Bool-itemCantMatch (Just t) (Just a) = t /= a-itemCantMatch _        _        = False---{--************************************************************************-*                                                                      *-                GADTs-*                                                                      *-************************************************************************--Note [Pruning dead case alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider        data T a where-                   T1 :: T Int-                   T2 :: T a--                newtype X = MkX Int-                newtype Y = MkY Char--                type family F a-                type instance F Bool = Int--Now consider    case x of { T1 -> e1; T2 -> e2 }--The question before the house is this: if I know something about the type-of x, can I prune away the T1 alternative?--Suppose x::T Char.  It's impossible to construct a (T Char) using T1,-        Answer = YES we can prune the T1 branch (clearly)--Suppose x::T (F a), where 'a' is in scope.  Then 'a' might be instantiated-to 'Bool', in which case x::T Int, so-        ANSWER = NO (clearly)--We see here that we want precisely the apartness check implemented within-tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely-apart. Note that since we are simply dropping dead code, a conservative test-suffices.--}---- | Given a list of pairs of types, are any two members of a pair surely--- apart, even after arbitrary type function evaluation and substitution?-typesCantMatch :: [(Type,Type)] -> Bool--- See Note [Pruning dead case alternatives]-typesCantMatch prs = any (uncurry cant_match) prs-  where-    cant_match :: Type -> Type -> Bool-    cant_match t1 t2 = case tcUnifyTysFG (const BindMe) [t1] [t2] of-      SurelyApart -> True-      _           -> False--{--************************************************************************-*                                                                      *-             Unification-*                                                                      *-************************************************************************--Note [Fine-grained unification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" ---no substitution to finite types makes these match. But, a substitution to-*infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ].-Why do we care? Consider these two type family instances:--type instance F x x   = Int-type instance F [y] y = Bool--If we also have--type instance Looper = [Looper]--then the instances potentially overlap. The solution is to use unification-over infinite terms. This is possible (see [1] for lots of gory details), but-a full algorithm is a little more power than we need. Instead, we make a-conservative approximation and just omit the occurs check.--[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf--tcUnifyTys considers an occurs-check problem as the same as general unification-failure.--tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check-failure ("MaybeApart"), or general failure ("SurelyApart").--See also #8162.--It's worth noting that unification in the presence of infinite types is not-complete. This means that, sometimes, a closed type family does not reduce-when it should. See test case indexed-types/should_fail/Overlap15 for an-example.--Note [The substitution in MaybeApart]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why?-Because consider unifying these:--(a, a, Int) ~ (b, [b], Bool)--If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we-apply the subst we have so far and discover that we need [b |-> [b]]. Because-this fails the occurs check, we say that the types are MaybeApart (see above-Note [Fine-grained unification]). But, we can't stop there! Because if we-continue, we discover that Int is SurelyApart from Bool, and therefore the-types are apart. This has practical consequences for the ability for closed-type family applications to reduce. See test case-indexed-types/should_compile/Overlap14.--Note [Unifying with skolems]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we discover that two types unify if and only if a skolem variable is-substituted, we can't properly unify the types. But, that skolem variable-may later be instantiated with a unifyable type. So, we return maybeApart-in these cases.--}---- | Simple unification of two types; all type variables are bindable--- Precondition: the kinds are already equal-tcUnifyTy :: Type -> Type       -- All tyvars are bindable-          -> Maybe TCvSubst-                       -- A regular one-shot (idempotent) substitution-tcUnifyTy t1 t2 = tcUnifyTys (const BindMe) [t1] [t2]---- | Like 'tcUnifyTy', but also unifies the kinds-tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst-tcUnifyTyKi t1 t2 = tcUnifyTyKis (const BindMe) [t1] [t2]---- | Unify two types, treating type family applications as possibly unifying--- with anything and looking through injective type family applications.--- Precondition: kinds are the same-tcUnifyTyWithTFs :: Bool  -- ^ True <=> do two-way unification;-                          --   False <=> do one-way matching.-                          --   See end of sec 5.2 from the paper-                 -> Type -> Type -> Maybe TCvSubst--- This algorithm is an implementation of the "Algorithm U" presented in--- the paper "Injective type families for Haskell", Figures 2 and 3.--- The code is incorporated with the standard unifier for convenience, but--- its operation should match the specification in the paper.-tcUnifyTyWithTFs twoWay t1 t2-  = case tc_unify_tys (const BindMe) twoWay True False-                       rn_env emptyTvSubstEnv emptyCvSubstEnv-                       [t1] [t2] of-      Unifiable  (subst, _) -> Just $ maybe_fix subst-      MaybeApart (subst, _) -> Just $ maybe_fix subst-      -- we want to *succeed* in questionable cases. This is a-      -- pre-unification algorithm.-      SurelyApart      -> Nothing-  where-    in_scope = mkInScopeSet $ tyCoVarsOfTypes [t1, t2]-    rn_env   = mkRnEnv2 in_scope--    maybe_fix | twoWay    = niFixTCvSubst-              | otherwise = mkTvSubst in_scope -- when matching, don't confuse-                                               -- domain with range--------------------tcUnifyTys :: (TyCoVar -> BindFlag)-           -> [Type] -> [Type]-           -> Maybe TCvSubst-                                -- ^ A regular one-shot (idempotent) substitution-                                -- that unifies the erased types. See comments-                                -- for 'tcUnifyTysFG'---- The two types may have common type variables, and indeed do so in the--- second call to tcUnifyTys in FunDeps.checkClsFD-tcUnifyTys bind_fn tys1 tys2-  = case tcUnifyTysFG bind_fn tys1 tys2 of-      Unifiable result -> Just result-      _                -> Nothing---- | Like 'tcUnifyTys' but also unifies the kinds-tcUnifyTyKis :: (TyCoVar -> BindFlag)-             -> [Type] -> [Type]-             -> Maybe TCvSubst-tcUnifyTyKis bind_fn tys1 tys2-  = case tcUnifyTyKisFG bind_fn tys1 tys2 of-      Unifiable result -> Just result-      _                -> Nothing---- This type does double-duty. It is used in the UM (unifier monad) and to--- return the final result. See Note [Fine-grained unification]-type UnifyResult = UnifyResultM TCvSubst-data UnifyResultM a = Unifiable a        -- the subst that unifies the types-                    | MaybeApart a       -- the subst has as much as we know-                                         -- it must be part of a most general unifier-                                         -- See Note [The substitution in MaybeApart]-                    | SurelyApart-                    deriving Functor--instance Applicative UnifyResultM where-  pure  = Unifiable-  (<*>) = ap--instance Monad UnifyResultM where--  SurelyApart  >>= _ = SurelyApart-  MaybeApart x >>= f = case f x of-                         Unifiable y -> MaybeApart y-                         other       -> other-  Unifiable x  >>= f = f x--instance Alternative UnifyResultM where-  empty = SurelyApart--  a@(Unifiable {})  <|> _                 = a-  _                 <|> b@(Unifiable {})  = b-  a@(MaybeApart {}) <|> _                 = a-  _                 <|> b@(MaybeApart {}) = b-  SurelyApart       <|> SurelyApart       = SurelyApart--instance MonadPlus UnifyResultM---- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose--- domain elements all respond 'BindMe' to @bind_tv@) such that--- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned--- Coercions. This version requires that the kinds of the types are the same,--- if you unify left-to-right.-tcUnifyTysFG :: (TyVar -> BindFlag)-             -> [Type] -> [Type]-             -> UnifyResult-tcUnifyTysFG bind_fn tys1 tys2-  = tc_unify_tys_fg False bind_fn tys1 tys2--tcUnifyTyKisFG :: (TyVar -> BindFlag)-               -> [Type] -> [Type]-               -> UnifyResult-tcUnifyTyKisFG bind_fn tys1 tys2-  = tc_unify_tys_fg True bind_fn tys1 tys2--tc_unify_tys_fg :: Bool-                -> (TyVar -> BindFlag)-                -> [Type] -> [Type]-                -> UnifyResult-tc_unify_tys_fg match_kis bind_fn tys1 tys2-  = do { (env, _) <- tc_unify_tys bind_fn True False match_kis env-                                  emptyTvSubstEnv emptyCvSubstEnv-                                  tys1 tys2-       ; return $ niFixTCvSubst env }-  where-    vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2-    env  = mkRnEnv2 $ mkInScopeSet vars---- | This function is actually the one to call the unifier -- a little--- too general for outside clients, though.-tc_unify_tys :: (TyVar -> BindFlag)-             -> AmIUnifying -- ^ True <=> unify; False <=> match-             -> Bool        -- ^ True <=> doing an injectivity check-             -> Bool        -- ^ True <=> treat the kinds as well-             -> RnEnv2-             -> TvSubstEnv  -- ^ substitution to extend-             -> CvSubstEnv-             -> [Type] -> [Type]-             -> UnifyResultM (TvSubstEnv, CvSubstEnv)--- NB: It's tempting to ASSERT here that, if we're not matching kinds, then--- the kinds of the types should be the same. However, this doesn't work,--- as the types may be a dependent telescope, where later types have kinds--- that mention variables occurring earlier in the list of types. Here's an--- example (from typecheck/should_fail/T12709):---   template: [rep :: RuntimeRep,       a :: TYPE rep]---   target:   [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep]--- We can see that matching the first pair will make the kinds of the second--- pair equal. Yet, we still don't need a separate pass to unify the kinds--- of these types, so it's appropriate to use the Ty variant of unification.--- See also Note [tcMatchTy vs tcMatchTyKi].-tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2-  = initUM tv_env cv_env $-    do { when match_kis $-         unify_tys env kis1 kis2-       ; unify_tys env tys1 tys2-       ; (,) <$> getTvSubstEnv <*> getCvSubstEnv }-  where-    env = UMEnv { um_bind_fun = bind_fn-                , um_skols    = emptyVarSet-                , um_unif     = unif-                , um_inj_tf   = inj_check-                , um_rn_env   = rn_env }--    kis1 = map typeKind tys1-    kis2 = map typeKind tys2--instance Outputable a => Outputable (UnifyResultM a) where-  ppr SurelyApart    = text "SurelyApart"-  ppr (Unifiable x)  = text "Unifiable" <+> ppr x-  ppr (MaybeApart x) = text "MaybeApart" <+> ppr x--{--************************************************************************-*                                                                      *-                Non-idempotent substitution-*                                                                      *-************************************************************************--Note [Non-idempotent substitution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-During unification we use a TvSubstEnv/CvSubstEnv pair that is-  (a) non-idempotent-  (b) loop-free; ie repeatedly applying it yields a fixed point--Note [Finding the substitution fixpoint]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Finding the fixpoint of a non-idempotent substitution arising from a-unification is much trickier than it looks, because of kinds.  Consider-   T k (H k (f:k)) ~ T * (g:*)-If we unify, we get the substitution-   [ k -> *-   , g -> H k (f:k) ]-To make it idempotent we don't want to get just-   [ k -> *-   , g -> H * (f:k) ]-We also want to substitute inside f's kind, to get-   [ k -> *-   , g -> H k (f:*) ]-If we don't do this, we may apply the substitution to something,-and get an ill-formed type, i.e. one where typeKind will fail.-This happened, for example, in #9106.--It gets worse.  In #14164 we wanted to take the fixpoint of-this substitution-   [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6)-                        (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6))-   , a_aY6  :-> a_aXQ ]--We have to apply the substitution for a_aY6 two levels deep inside-the invocation of F!  We don't have a function that recursively-applies substitutions inside the kinds of variable occurrences (and-probably rightly so).--So, we work as follows:-- 1. Start with the current substitution (which we are-    trying to fixpoint-       [ xs :-> F a (z :: a) (rest :: G a (z :: a))-       , a  :-> b ]-- 2. Take all the free vars of the range of the substitution:-       {a, z, rest, b}-    NB: the free variable finder closes over-    the kinds of variable occurrences-- 3. If none are in the domain of the substitution, stop.-    We have found a fixpoint.-- 4. Remove the variables that are bound by the substitution, leaving-       {z, rest, b}-- 5. Do a topo-sort to put them in dependency order:-       [ b :: *, z :: a, rest :: G a z ]-- 6. Apply the substitution left-to-right to the kinds of these-    tyvars, extending it each time with a new binding, so we-    finish up with-       [ xs   :-> ..as before..-       , a    :-> b-       , b    :-> b    :: *-       , z    :-> z    :: b-       , rest :-> rest :: G b (z :: b) ]-    Note that rest now has the right kind-- 7. Apply this extended substitution (once) to the range of-    the /original/ substitution.  (Note that we do the-    extended substitution would go on forever if you tried-    to find its fixpoint, because it maps z to z.)-- 8. And go back to step 1--In Step 6 we use the free vars from Step 2 as the initial-in-scope set, because all of those variables appear in the-range of the substitution, so they must all be in the in-scope-set.  But NB that the type substitution engine does not look up-variables in the in-scope set; it is used only to ensure no-shadowing.--}--niFixTCvSubst :: TvSubstEnv -> TCvSubst--- Find the idempotent fixed point of the non-idempotent substitution--- This is surprisingly tricky:---   see Note [Finding the substitution fixpoint]--- ToDo: use laziness instead of iteration?-niFixTCvSubst tenv-  | not_fixpoint = niFixTCvSubst (mapVarEnv (substTy subst) tenv)-  | otherwise    = subst-  where-    range_fvs :: FV-    range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv)-          -- It's OK to use nonDetEltsUFM here because the-          -- order of range_fvs, range_tvs is immaterial--    range_tvs :: [TyVar]-    range_tvs = fvVarList range_fvs--    not_fixpoint  = any in_domain range_tvs-    in_domain tv  = tv `elemVarEnv` tenv--    free_tvs = scopedSort (filterOut in_domain range_tvs)--    -- See Note [Finding the substitution fixpoint], Step 6-    init_in_scope = mkInScopeSet (fvVarSet range_fvs)-    subst = foldl' add_free_tv-                  (mkTvSubst init_in_scope tenv)-                  free_tvs--    add_free_tv :: TCvSubst -> TyVar -> TCvSubst-    add_free_tv subst tv-      = extendTvSubst subst tv (mkTyVarTy tv')-     where-        tv' = updateTyVarKind (substTy subst) tv--niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet--- Apply the non-idempotent substitution to a set of type variables,--- remembering that the substitution isn't necessarily idempotent--- This is used in the occurs check, before extending the substitution-niSubstTvSet tsubst tvs-  = nonDetFoldUniqSet (unionVarSet . get) emptyVarSet tvs-  -- It's OK to nonDetFoldUFM here because we immediately forget the-  -- ordering by creating a set.-  where-    get tv-      | Just ty <- lookupVarEnv tsubst tv-      = niSubstTvSet tsubst (tyCoVarsOfType ty)--      | otherwise-      = unitVarSet tv--{--************************************************************************-*                                                                      *-                unify_ty: the main workhorse-*                                                                      *-************************************************************************--Note [Specification of unification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The pure unifier, unify_ty, defined in this module, tries to work out-a substitution to make two types say True to eqType. NB: eqType is-itself not purely syntactic; it accounts for CastTys;-see Note [Non-trivial definitional equality] in TyCoRep--Unlike the "impure unifiers" in the typechecker (the eager unifier in-TcUnify, and the constraint solver itself in TcCanonical), the pure-unifier It does /not/ work up to ~.--The algorithm implemented here is rather delicate, and we depend on it-to uphold certain properties. This is a summary of these required-properties. Any reference to "flattening" refers to the flattening-algorithm in FamInstEnv (See Note [Flattening] in FamInstEnv), not-the flattening algorithm in the solver.--Notation:- θ,φ    substitutions- ξ    type-function-free types- τ,σ  other types- τ♭   type τ, flattened-- ≡    eqType--(U1) Soundness.-     If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂).-     θ is a most general unifier for τ₁ and τ₂.--(U2) Completeness.-     If (unify ξ₁ ξ₂) = SurelyApart,-     then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂).--These two properties are stated as Property 11 in the "Closed Type Families"-paper (POPL'14). Below, this paper is called [CTF].--(U3) Apartness under substitution.-     If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart,-     for any θ. (Property 12 from [CTF])--(U4) Apart types do not unify.-     If (unify ξ τ♭) = SurelyApart, then there exists no θ-     such that θ(ξ) = θ(τ). (Property 13 from [CTF])--THEOREM. Completeness w.r.t ~-    If (unify τ₁♭ τ₂♭) = SurelyApart,-    then there exists no proof that (τ₁ ~ τ₂).--PROOF. See appendix of [CTF].---The unification algorithm is used for type family injectivity, as described-in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run-in this mode, it has the following properties.--(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even-     after arbitrary type family reductions. Note that σ and τ are-     not flattened here.--(I2) If (unify σ τ) = MaybeApart θ, and if some-     φ exists such that φ(σ) ~ φ(τ), then φ extends θ.---Furthermore, the RULES matching algorithm requires this property,-but only when using this algorithm for matching:--(M1) If (match σ τ) succeeds with θ, then all matchable tyvars-     in σ are bound in θ.--     Property M1 means that we must extend the substitution with,-     say (a ↦ a) when appropriate during matching.-     See also Note [Self-substitution when matching].--(M2) Completeness of matching.-     If θ(σ) = τ, then (match σ τ) = Unifiable φ,-     where θ is an extension of φ.--Sadly, property M2 and I2 conflict. Consider--type family F1 a b where-  F1 Int    Bool   = Char-  F1 Double String = Char--Consider now two matching problems:--P1. match (F1 a Bool) (F1 Int Bool)-P2. match (F1 a Bool) (F1 Double String)--In case P1, we must find (a ↦ Int) to satisfy M2.-In case P2, we must /not/ find (a ↦ Double), in order to satisfy I2. (Note-that the correct mapping for I2 is (a ↦ Int). There is no way to discover-this, but we musn't map a to anything else!)--We thus must parameterize the algorithm over whether it's being used-for an injectivity check (refrain from looking at non-injective arguments-to type families) or not (do indeed look at those arguments).  This is-implemented  by the uf_inj_tf field of UmEnv.--(It's all a question of whether or not to include equation (7) from Fig. 2-of [ITF].)--This extra parameter is a bit fiddly, perhaps, but seemingly less so than-having two separate, almost-identical algorithms.--Note [Self-substitution when matching]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-What should happen when we're *matching* (not unifying) a1 with a1? We-should get a substitution [a1 |-> a1]. A successful match should map all-the template variables (except ones that disappear when expanding synonyms).-But when unifying, we don't want to do this, because we'll then fall into-a loop.--This arrangement affects the code in three places:- - If we're matching a refined template variable, don't recur. Instead, just-   check for equality. That is, if we know [a |-> Maybe a] and are matching-   (a ~? Maybe Int), we want to just fail.-- - Skip the occurs check when matching. This comes up in two places, because-   matching against variables is handled separately from matching against-   full-on types.--Note that this arrangement was provoked by a real failure, where the same-unique ended up in the template as in the target. (It was a rule firing when-compiling Data.List.NonEmpty.)--Note [Matching coercion variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this:--   type family F a--   data G a where-     MkG :: F a ~ Bool => G a--   type family Foo (x :: G a) :: F a-   type instance Foo MkG = False--We would like that to be accepted. For that to work, we need to introduce-a coercion variable on the left and then use it on the right. Accordingly,-at use sites of Foo, we need to be able to use matching to figure out the-value for the coercion. (See the desugared version:--   axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c)--) We never want this action to happen during *unification* though, when-all bets are off.--Note [Kind coercions in Unify]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We wish to match/unify while ignoring casts. But, we can't just ignore-them completely, or we'll end up with ill-kinded substitutions. For example,-say we're matching `a` with `ty |> co`. If we just drop the cast, we'll-return [a |-> ty], but `a` and `ty` might have different kinds. We can't-just match/unify their kinds, either, because this might gratuitously-fail. After all, `co` is the witness that the kinds are the same -- they-may look nothing alike.--So, we pass a kind coercion to the match/unify worker. This coercion witnesses-the equality between the substed kind of the left-hand type and the substed-kind of the right-hand type. Note that we do not unify kinds at the leaves-(as we did previously). We thus have--INVARIANT: In the call-    unify_ty ty1 ty2 kco-it must be that subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)), where-`subst` is the ambient substitution in the UM monad.--To get this coercion, we first have to match/unify-the kinds before looking at the types. Happily, we need look only one level-up, as all kinds are guaranteed to have kind *.--When we're working with type applications (either TyConApp or AppTy) we-need to worry about establishing INVARIANT, as the kinds of the function-& arguments aren't (necessarily) included in the kind of the result.-When unifying two TyConApps, this is easy, because the two TyCons are-the same. Their kinds are thus the same. As long as we unify left-to-right,-we'll be sure to unify types' kinds before the types themselves. (For example,-think about Proxy :: forall k. k -> *. Unifying the first args matches up-the kinds of the second args.)--For AppTy, we must unify the kinds of the functions, but once these are-unified, we can continue unifying arguments without worrying further about-kinds.--The interface to this module includes both "...Ty" functions and-"...TyKi" functions. The former assume that INVARIANT is already-established, either because the kinds are the same or because the-list of types being passed in are the well-typed arguments to some-type constructor (see two paragraphs above). The latter take a separate-pre-pass over the kinds to establish INVARIANT. Sometimes, it's important-not to take the second pass, as it caused #12442.--We thought, at one point, that this was all unnecessary: why should-casts be in types in the first place? But they are sometimes. In-dependent/should_compile/KindEqualities2, we see, for example the-constraint Num (Int |> (blah ; sym blah)).  We naturally want to find-a dictionary for that constraint, which requires dealing with-coercions in this manner.--Note [Matching in the presence of casts (1)]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When matching, it is crucial that no variables from the template-end up in the range of the matching substitution (obviously!).-When unifying, that's not a constraint; instead we take the fixpoint-of the substitution at the end.--So what should we do with this, when matching?-   unify_ty (tmpl |> co) tgt kco--Previously, wrongly, we pushed 'co' in the (horrid) accumulating-'kco' argument like this:-   unify_ty (tmpl |> co) tgt kco-     = unify_ty tmpl tgt (kco ; co)--But that is obviously wrong because 'co' (from the template) ends-up in 'kco', which in turn ends up in the range of the substitution.--This all came up in #13910.  Because we match tycon arguments-left-to-right, the ambient substitution will already have a matching-substitution for any kinds; so there is an easy fix: just apply-the substitution-so-far to the coercion from the LHS.--Note that--* When matching, the first arg of unify_ty is always the template;-  we never swap round.--* The above argument is distressingly indirect. We seek a-  better way.--* One better way is to ensure that type patterns (the template-  in the matching process) have no casts.  See #14119.--Note [Matching in the presence of casts (2)]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is another wrinkle (#17395).  Suppose (T :: forall k. k -> Type)-and we are matching-   tcMatchTy (T k (a::k))  (T j (b::j))--Then we'll match k :-> j, as expected. But then in unify_tys-we invoke-   unify_tys env (a::k) (b::j) (Refl j)--Although we have unified k and j, it's very important that we put-(Refl j), /not/ (Refl k) as the fourth argument to unify_tys.-If we put (Refl k) we'd end up with the substitution-  a :-> b |> Refl k-which is bogus because one of the template variables, k,-appears in the range of the substitution.  Eek.--Similar care is needed in unify_ty_app.---Note [Polykinded tycon applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose  T :: forall k. Type -> K-and we are unifying-  ty1:  T @Type         Int       :: Type-  ty2:  T @(Type->Type) Int Int   :: Type--These two TyConApps have the same TyCon at the front but they-(legitimately) have different numbers of arguments.  They-are surelyApart, so we can report that without looking any-further (see #15704).--}---------------- unify_ty: the main workhorse -------------type AmIUnifying = Bool   -- True  <=> Unifying-                          -- False <=> Matching--unify_ty :: UMEnv-         -> Type -> Type  -- Types to be unified and a co-         -> CoercionN     -- A coercion between their kinds-                          -- See Note [Kind coercions in Unify]-         -> UM ()--- See Note [Specification of unification]--- Respects newtypes, PredTypes--unify_ty env ty1 ty2 kco-    -- TODO: More commentary needed here-  | Just ty1' <- tcView ty1   = unify_ty env ty1' ty2 kco-  | Just ty2' <- tcView ty2   = unify_ty env ty1 ty2' kco-  | CastTy ty1' co <- ty1     = if um_unif env-                                then unify_ty env ty1' ty2 (co `mkTransCo` kco)-                                else -- See Note [Matching in the presence of casts (1)]-                                     do { subst <- getSubst env-                                        ; let co' = substCo subst co-                                        ; unify_ty env ty1' ty2 (co' `mkTransCo` kco) }-  | CastTy ty2' co <- ty2     = unify_ty env ty1 ty2' (kco `mkTransCo` mkSymCo co)--unify_ty env (TyVarTy tv1) ty2 kco-  = uVar env tv1 ty2 kco-unify_ty env ty1 (TyVarTy tv2) kco-  | um_unif env  -- If unifying, can swap args-  = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco)--unify_ty env ty1 ty2 _kco-  | Just (tc1, tys1) <- mb_tc_app1-  , Just (tc2, tys2) <- mb_tc_app2-  , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2)-  = if isInjectiveTyCon tc1 Nominal-    then unify_tys env tys1 tys2-    else do { let inj | isTypeFamilyTyCon tc1-                      = case tyConInjectivityInfo tc1 of-                               NotInjective -> repeat False-                               Injective bs -> bs-                      | otherwise-                      = repeat False--                  (inj_tys1, noninj_tys1) = partitionByList inj tys1-                  (inj_tys2, noninj_tys2) = partitionByList inj tys2--            ; unify_tys env inj_tys1 inj_tys2-            ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]-              don'tBeSoSure $ unify_tys env noninj_tys1 noninj_tys2 }--  | Just (tc1, _) <- mb_tc_app1-  , not (isGenerativeTyCon tc1 Nominal)-    -- E.g.   unify_ty (F ty1) b  =  MaybeApart-    --        because the (F ty1) behaves like a variable-    --        NB: if unifying, we have already dealt-    --            with the 'ty2 = variable' case-  = maybeApart--  | Just (tc2, _) <- mb_tc_app2-  , not (isGenerativeTyCon tc2 Nominal)-  , um_unif env-    -- E.g.   unify_ty [a] (F ty2) =  MaybeApart, when unifying (only)-    --        because the (F ty2) behaves like a variable-    --        NB: we have already dealt with the 'ty1 = variable' case-  = maybeApart--  where-    mb_tc_app1 = tcSplitTyConApp_maybe ty1-    mb_tc_app2 = tcSplitTyConApp_maybe ty2--        -- Applications need a bit of care!-        -- They can match FunTy and TyConApp, so use splitAppTy_maybe-        -- NB: we've already dealt with type variables,-        -- so if one type is an App the other one jolly well better be too-unify_ty env (AppTy ty1a ty1b) ty2 _kco-  | Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2-  = unify_ty_app env ty1a [ty1b] ty2a [ty2b]--unify_ty env ty1 (AppTy ty2a ty2b) _kco-  | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1-  = unify_ty_app env ty1a [ty1b] ty2a [ty2b]--unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return ()--unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco-  = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind)-       ; let env' = umRnBndr2 env tv1 tv2-       ; unify_ty env' ty1 ty2 kco }---- See Note [Matching coercion variables]-unify_ty env (CoercionTy co1) (CoercionTy co2) kco-  = do { c_subst <- getCvSubstEnv-       ; case co1 of-           CoVarCo cv-             | not (um_unif env)-             , not (cv `elemVarEnv` c_subst)-             , BindMe <- tvBindFlag env cv-             -> do { checkRnEnv env (tyCoVarsOfCo co2)-                   ; let (co_l, co_r) = decomposeFunCo Nominal kco-                      -- cv :: t1 ~ t2-                      -- co2 :: s1 ~ s2-                      -- co_l :: t1 ~ s1-                      -- co_r :: t2 ~ s2-                   ; extendCvEnv cv (co_l `mkTransCo`-                                     co2 `mkTransCo`-                                     mkSymCo co_r) }-           _ -> return () }--unify_ty _ _ _ _ = surelyApart--unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM ()-unify_ty_app env ty1 ty1args ty2 ty2args-  | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1-  , Just (ty2', ty2a) <- repSplitAppTy_maybe ty2-  = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args)--  | otherwise-  = do { let ki1 = typeKind ty1-             ki2 = typeKind ty2-           -- See Note [Kind coercions in Unify]-       ; unify_ty  env ki1 ki2 (mkNomReflCo liftedTypeKind)-       ; unify_ty  env ty1 ty2 (mkNomReflCo ki2)-                 -- Very important: 'ki2' not 'ki1'-                 -- See Note [Matching in the presence of casts (2)]-       ; unify_tys env ty1args ty2args }--unify_tys :: UMEnv -> [Type] -> [Type] -> UM ()-unify_tys env orig_xs orig_ys-  = go orig_xs orig_ys-  where-    go []     []     = return ()-    go (x:xs) (y:ys)-      -- See Note [Kind coercions in Unify]-      = do { unify_ty env x y (mkNomReflCo $ typeKind y)-                 -- Very important: 'y' not 'x'-                 -- See Note [Matching in the presence of casts (2)]-           ; go xs ys }-    go _ _ = surelyApart-      -- Possibly different saturations of a polykinded tycon-      -- See Note [Polykinded tycon applications]------------------------------------uVar :: UMEnv-     -> InTyVar         -- Variable to be unified-     -> Type            -- with this Type-     -> Coercion        -- :: kind tv ~N kind ty-     -> UM ()--uVar env tv1 ty kco- = do { -- Apply the ambient renaming-        let tv1' = umRnOccL env tv1--        -- Check to see whether tv1 is refined by the substitution-      ; subst <- getTvSubstEnv-      ; case (lookupVarEnv subst tv1') of-          Just ty' | um_unif env                -- Unifying, so call-                   -> unify_ty env ty' ty kco   -- back into unify-                   | otherwise-                   -> -- Matching, we don't want to just recur here.-                      -- this is because the range of the subst is the target-                      -- type, not the template type. So, just check for-                      -- normal type equality.-                      guard ((ty' `mkCastTy` kco) `eqType` ty)-          Nothing  -> uUnrefined env tv1' ty ty kco } -- No, continue--uUnrefined :: UMEnv-           -> OutTyVar          -- variable to be unified-           -> Type              -- with this Type-           -> Type              -- (version w/ expanded synonyms)-           -> Coercion          -- :: kind tv ~N kind ty-           -> UM ()---- We know that tv1 isn't refined--uUnrefined env tv1' ty2 ty2' kco-  | Just ty2'' <- coreView ty2'-  = uUnrefined env tv1' ty2 ty2'' kco    -- Unwrap synonyms-                -- This is essential, in case we have-                --      type Foo a = a-                -- and then unify a ~ Foo a--  | TyVarTy tv2 <- ty2'-  = do { let tv2' = umRnOccR env tv2-       ; unless (tv1' == tv2' && um_unif env) $ do-           -- If we are unifying a ~ a, just return immediately-           -- Do not extend the substitution-           -- See Note [Self-substitution when matching]--          -- Check to see whether tv2 is refined-       { subst <- getTvSubstEnv-       ; case lookupVarEnv subst tv2 of-         {  Just ty' | um_unif env -> uUnrefined env tv1' ty' ty' kco-         ;  _ ->--    do {   -- So both are unrefined-           -- Bind one or the other, depending on which is bindable-       ; let b1  = tvBindFlag env tv1'-             b2  = tvBindFlag env tv2'-             ty1 = mkTyVarTy tv1'-       ; case (b1, b2) of-           (BindMe, _) -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco)-           (_, BindMe) | um_unif env-                       -> bindTv (umSwapRn env) tv2 (ty1 `mkCastTy` kco)--           _ | tv1' == tv2' -> return ()-             -- How could this happen? If we're only matching and if-             -- we're comparing forall-bound variables.--           _ -> maybeApart -- See Note [Unification with skolems]-  }}}}--uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable-  = case tvBindFlag env tv1' of-      Skolem -> maybeApart  -- See Note [Unification with skolems]-      BindMe -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco)--bindTv :: UMEnv -> OutTyVar -> Type -> UM ()--- OK, so we want to extend the substitution with tv := ty--- But first, we must do a couple of checks-bindTv env tv1 ty2-  = do  { let free_tvs2 = tyCoVarsOfType ty2--        -- Make sure tys mentions no local variables-        -- E.g.  (forall a. b) ~ (forall a. [a])-        -- We should not unify b := [a]!-        ; checkRnEnv env free_tvs2--        -- Occurs check, see Note [Fine-grained unification]-        -- Make sure you include 'kco' (which ty2 does) #14846-        ; occurs <- occursCheck env tv1 free_tvs2--        ; if occurs then maybeApart-                    else extendTvEnv tv1 ty2 }--occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool-occursCheck env tv free_tvs-  | um_unif env-  = do { tsubst <- getTvSubstEnv-       ; return (tv `elemVarSet` niSubstTvSet tsubst free_tvs) }--  | otherwise      -- Matching; no occurs check-  = return False   -- See Note [Self-substitution when matching]--{--%************************************************************************-%*                                                                      *-                Binding decisions-*                                                                      *-************************************************************************--}--data BindFlag-  = BindMe      -- A regular type variable--  | Skolem      -- This type variable is a skolem constant-                -- Don't bind it; it only matches itself-  deriving Eq--{--************************************************************************-*                                                                      *-                Unification monad-*                                                                      *-************************************************************************--}--data UMEnv-  = UMEnv { um_unif :: AmIUnifying--          , um_inj_tf :: Bool-            -- Checking for injectivity?-            -- See (end of) Note [Specification of unification]--          , um_rn_env :: RnEnv2-            -- Renaming InTyVars to OutTyVars; this eliminates-            -- shadowing, and lines up matching foralls on the left-            -- and right--          , um_skols :: TyVarSet-            -- OutTyVars bound by a forall in this unification;-            -- Do not bind these in the substitution!-            -- See the function tvBindFlag--          , um_bind_fun :: TyVar -> BindFlag-            -- User-supplied BindFlag function,-            -- for variables not in um_skols-          }--data UMState = UMState-                   { um_tv_env   :: TvSubstEnv-                   , um_cv_env   :: CvSubstEnv }--newtype UM a = UM { unUM :: UMState -> UnifyResultM (UMState, a) }-    deriving (Functor)--instance Applicative UM where-      pure a = UM (\s -> pure (s, a))-      (<*>)  = ap--instance Monad UM where-#if !MIN_VERSION_base(4,13,0)-  fail     = MonadFail.fail-#endif-  m >>= k  = UM (\state ->-                  do { (state', v) <- unUM m state-                     ; unUM (k v) state' })---- need this instance because of a use of 'guard' above-instance Alternative UM where-  empty     = UM (\_ -> Control.Applicative.empty)-  m1 <|> m2 = UM (\state ->-                  unUM m1 state <|>-                  unUM m2 state)--instance MonadPlus UM--instance MonadFail.MonadFail UM where-    fail _   = UM (\_ -> SurelyApart) -- failed pattern match--initUM :: TvSubstEnv  -- subst to extend-       -> CvSubstEnv-       -> UM a -> UnifyResultM a-initUM subst_env cv_subst_env um-  = case unUM um state of-      Unifiable (_, subst)  -> Unifiable subst-      MaybeApart (_, subst) -> MaybeApart subst-      SurelyApart           -> SurelyApart-  where-    state = UMState { um_tv_env = subst_env-                    , um_cv_env = cv_subst_env }--tvBindFlag :: UMEnv -> OutTyVar -> BindFlag-tvBindFlag env tv-  | tv `elemVarSet` um_skols env = Skolem-  | otherwise                    = um_bind_fun env tv--getTvSubstEnv :: UM TvSubstEnv-getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state)--getCvSubstEnv :: UM CvSubstEnv-getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state)--getSubst :: UMEnv -> UM TCvSubst-getSubst env = do { tv_env <- getTvSubstEnv-                  ; cv_env <- getCvSubstEnv-                  ; let in_scope = rnInScopeSet (um_rn_env env)-                  ; return (mkTCvSubst in_scope (tv_env, cv_env)) }--extendTvEnv :: TyVar -> Type -> UM ()-extendTvEnv tv ty = UM $ \state ->-  Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ())--extendCvEnv :: CoVar -> Coercion -> UM ()-extendCvEnv cv co = UM $ \state ->-  Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ())--umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv-umRnBndr2 env v1 v2-  = env { um_rn_env = rn_env', um_skols = um_skols env `extendVarSet` v' }-  where-    (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2--checkRnEnv :: UMEnv -> VarSet -> UM ()-checkRnEnv env varset-  | isEmptyVarSet skol_vars           = return ()-  | varset `disjointVarSet` skol_vars = return ()-  | otherwise                         = maybeApart-               -- ToDo: why MaybeApart?-               -- I think SurelyApart would be right-  where-    skol_vars = um_skols env-    -- NB: That isEmptyVarSet guard is a critical optimization;-    -- it means we don't have to calculate the free vars of-    -- the type, often saving quite a bit of allocation.---- | Converts any SurelyApart to a MaybeApart-don'tBeSoSure :: UM () -> UM ()-don'tBeSoSure um = UM $ \ state ->-  case unUM um state of-    SurelyApart -> MaybeApart (state, ())-    other       -> other--umRnOccL :: UMEnv -> TyVar -> TyVar-umRnOccL env v = rnOccL (um_rn_env env) v--umRnOccR :: UMEnv -> TyVar -> TyVar-umRnOccR env v = rnOccR (um_rn_env env) v--umSwapRn :: UMEnv -> UMEnv-umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) }--maybeApart :: UM ()-maybeApart = UM (\state -> MaybeApart (state, ()))--surelyApart :: UM a-surelyApart = UM (\_ -> SurelyApart)--{--%************************************************************************-%*                                                                      *-            Matching a (lifted) type against a coercion-%*                                                                      *-%************************************************************************--This section defines essentially an inverse to liftCoSubst. It is defined-here to avoid a dependency from Coercion on this module.---}--data MatchEnv = ME { me_tmpls :: TyVarSet-                   , me_env   :: RnEnv2 }---- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'.  In particular, if---   @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@,---   where @==@ there means that the result of 'liftCoSubst' has the same---   type as the original co; but may be different under the hood.---   That is, it matches a type against a coercion of the same---   "shape", and returns a lifting substitution which could have been---   used to produce the given coercion from the given type.---   Note that this function is incomplete -- it might return Nothing---   when there does indeed exist a possible lifting context.------ This function is incomplete in that it doesn't respect the equality--- in `eqType`. That is, it's possible that this will succeed for t1 and--- fail for t2, even when t1 `eqType` t2. That's because it depends on--- there being a very similar structure between the type and the coercion.--- This incompleteness shouldn't be all that surprising, especially because--- it depends on the structure of the coercion, which is a silly thing to do.------ The lifting context produced doesn't have to be exacting in the roles--- of the mappings. This is because any use of the lifting context will--- also require a desired role. Thus, this algorithm prefers mapping to--- nominal coercions where it can do so.-liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext-liftCoMatch tmpls ty co-  = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co-       ; cenv2 <- ty_co_match menv cenv1       ty co-                              (mkNomReflCo co_lkind) (mkNomReflCo co_rkind)-       ; return (LC (mkEmptyTCvSubst in_scope) cenv2) }-  where-    menv     = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope }-    in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co)-    -- Like tcMatchTy, assume all the interesting variables-    -- in ty are in tmpls--    ki       = typeKind ty-    ki_co    = promoteCoercion co-    ki_ki_co = mkNomReflCo liftedTypeKind--    Pair co_lkind co_rkind = coercionKind ki_co---- | 'ty_co_match' does all the actual work for 'liftCoMatch'.-ty_co_match :: MatchEnv   -- ^ ambient helpful info-            -> LiftCoEnv  -- ^ incoming subst-            -> Type       -- ^ ty, type to match-            -> Coercion   -- ^ co, coercion to match against-            -> Coercion   -- ^ :: kind of L type of substed ty ~N L kind of co-            -> Coercion   -- ^ :: kind of R type of substed ty ~N R kind of co-            -> Maybe LiftCoEnv-ty_co_match menv subst ty co lkco rkco-  | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco--  -- handle Refl case:-  | tyCoVarsOfType ty `isNotInDomainOf` subst-  , Just (ty', _) <- isReflCo_maybe co-  , ty `eqType` ty'-  = Just subst--  where-    isNotInDomainOf :: VarSet -> VarEnv a -> Bool-    isNotInDomainOf set env-      = noneSet (\v -> elemVarEnv v env) set--    noneSet :: (Var -> Bool) -> VarSet -> Bool-    noneSet f = allVarSet (not . f)--ty_co_match menv subst ty co lkco rkco-  | CastTy ty' co' <- ty-     -- See Note [Matching in the presence of casts (1)]-  = let empty_subst  = mkEmptyTCvSubst (rnInScopeSet (me_env menv))-        substed_co_l = substCo (liftEnvSubstLeft empty_subst subst)  co'-        substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co'-    in-    ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco)-                                  (substed_co_r `mkTransCo` rkco)--  | SymCo co' <- co-  = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco--  -- Match a type variable against a non-refl coercion-ty_co_match menv subst (TyVarTy tv1) co lkco rkco-  | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1-  = if eqCoercionX (nukeRnEnvL rn_env) co1' co-    then Just subst-    else Nothing       -- no match since tv1 matches two different coercions--  | tv1' `elemVarSet` me_tmpls menv           -- tv1' is a template var-  = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co)-    then Nothing      -- occurs check failed-    else Just $ extendVarEnv subst tv1' $-                castCoercionKindI co (mkSymCo lkco) (mkSymCo rkco)--  | otherwise-  = Nothing--  where-    rn_env = me_env menv-    tv1' = rnOccL rn_env tv1--  -- just look through SubCo's. We don't really care about roles here.-ty_co_match menv subst ty (SubCo co) lkco rkco-  = ty_co_match menv subst ty co lkco rkco--ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco-  | Just (co2, arg2) <- splitAppCo_maybe co     -- c.f. Unify.match on AppTy-  = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2]-ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco-  | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1-       -- yes, the one from Type, not TcType; this is for coercion optimization-  = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2]--ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco-  = ty_co_match_tc menv subst tc1 tys tc2 cos-ty_co_match menv subst (FunTy _ ty1 ty2) co _lkco _rkco-    -- Despite the fact that (->) is polymorphic in four type variables (two-    -- runtime rep and two types), we shouldn't need to explicitly unify the-    -- runtime reps here; unifying the types themselves should be sufficient.-    -- See Note [Representation of function types].-  | Just (tc, [_,_,co1,co2]) <- splitTyConAppCo_maybe co-  , tc == funTyCon-  = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co1,co2]-    in ty_co_match_args menv subst [ty1, ty2] [co1, co2] lkcos rkcos--ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1)-                       (ForAllCo tv2 kind_co2 co2)-                       lkco rkco-  | isTyVar tv1 && isTyVar tv2-  = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2-                               ki_ki_co ki_ki_co-       ; let rn_env0 = me_env menv-             rn_env1 = rnBndr2 rn_env0 tv1 tv2-             menv'   = menv { me_env = rn_env1 }-       ; ty_co_match menv' subst1 ty1 co2 lkco rkco }-  where-    ki_ki_co = mkNomReflCo liftedTypeKind---- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1)---                        (ForAllCo cv2 kind_co2 co2)---                        lkco rkco---   | isCoVar cv1 && isCoVar cv2---   We seems not to have enough information for this case---   1. Given:---        cv1      :: (s1 :: k1) ~r (s2 :: k2)---        kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2)---        eta1      = mkNthCo role 2 (downgradeRole r Nominal kind_co2)---                 :: s1' ~ t1---        eta2      = mkNthCo role 3 (downgradeRole r Nominal kind_co2)---                 :: s2' ~ t2---      Wanted:---        subst1 <- ty_co_match menv subst  s1 eta1 kco1 kco2---        subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4---      Question: How do we get kcoi?---   2. Given:---        lkco :: <*>    -- See Note [Weird typing rule for ForAllTy] in Type---        rkco :: <*>---      Wanted:---        ty_co_match menv' subst2 ty1 co2 lkco' rkco'---      Question: How do we get lkco' and rkco'?--ty_co_match _ subst (CoercionTy {}) _ _ _-  = Just subst -- don't inspect coercions--ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco-  =  ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co)--ty_co_match menv subst ty co1 lkco rkco-  | Just (CastTy t co, r) <- isReflCo_maybe co1-  -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us-  -- t |> co ~ t ; <t> ; t ~ t |> co-  -- But transitive coercions are not helpful. Therefore we deal-  -- with it here: we do recursion on the smaller reflexive coercion,-  -- while propagating the correct kind coercions.-  = let kco' = mkSymCo co-    in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco')-                                                (rkco `mkTransCo` kco')---ty_co_match menv subst ty co lkco rkco-  | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco-  | otherwise               = Nothing--ty_co_match_tc :: MatchEnv -> LiftCoEnv-               -> TyCon -> [Type]-               -> TyCon -> [Coercion]-               -> Maybe LiftCoEnv-ty_co_match_tc menv subst tc1 tys1 tc2 cos2-  = do { guard (tc1 == tc2)-       ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos }-  where-    Pair lkcos rkcos-      = traverse (fmap mkNomReflCo . coercionKind) cos2--ty_co_match_app :: MatchEnv -> LiftCoEnv-                -> Type -> [Type] -> Coercion -> [Coercion]-                -> Maybe LiftCoEnv-ty_co_match_app menv subst ty1 ty1args co2 co2args-  | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1-  , Just (co2', co2a) <- splitAppCo_maybe co2-  = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args)--  | otherwise-  = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co-       ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2-       ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco-       ; let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) co2args-       ; ty_co_match_args menv subst2 ty1args co2args lkcos rkcos }-  where-    ki1 = typeKind ty1-    ki2 = promoteCoercion co2-    ki_ki_co = mkNomReflCo liftedTypeKind--ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type]-                 -> [Coercion] -> [Coercion] -> [Coercion]-                 -> Maybe LiftCoEnv-ty_co_match_args _    subst []       []         _ _ = Just subst-ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos)-  = do { subst' <- ty_co_match menv subst ty arg lkco rkco-       ; ty_co_match_args menv subst' tys args lkcos rkcos }-ty_co_match_args _    _     _        _          _ _ = Nothing--pushRefl :: Coercion -> Maybe Coercion-pushRefl co =-  case (isReflCo_maybe co) of-    Just (AppTy ty1 ty2, Nominal)-      -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2))-    Just (FunTy _ ty1 ty2, r)-      | Just rep1 <- getRuntimeRep_maybe ty1-      , Just rep2 <- getRuntimeRep_maybe ty2-      ->  Just (TyConAppCo r funTyCon [ mkReflCo r rep1, mkReflCo r rep2-                                       , mkReflCo r ty1,  mkReflCo r ty2 ])-    Just (TyConApp tc tys, r)-      -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys))-    Just (ForAllTy (Bndr tv _) ty, r)-      -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty))-    -- NB: NoRefl variant. Otherwise, we get a loop!-    _ -> Nothing
compiler/utils/Binary.hs view
@@ -31,10 +31,8 @@ --   closeBin,     seekBin,-   seekBy,    tellBin,    castBin,-   isEOFBin,    withBinBuffer,     writeBinMem,@@ -66,14 +64,14 @@  import GhcPrelude -import {-# SOURCE #-} Name (Name)+import {-# SOURCE #-} GHC.Types.Name (Name) import FastString import PlainPanic-import UniqFM+import GHC.Types.Unique.FM import FastMutInt import Fingerprint-import BasicTypes-import SrcLoc+import GHC.Types.Basic+import GHC.Types.SrcLoc  import Foreign import Data.Array@@ -184,21 +182,6 @@         then do expandBin h p; writeFastMutInt ix_r p         else writeFastMutInt ix_r p -seekBy :: BinHandle -> Int -> IO ()-seekBy h@(BinMem _ ix_r sz_r _) !off = do-  sz <- readFastMutInt sz_r-  ix <- readFastMutInt ix_r-  let ix' = ix + off-  if (ix' >= sz)-        then do expandBin h ix'; writeFastMutInt ix_r ix'-        else writeFastMutInt ix_r ix'--isEOFBin :: BinHandle -> IO Bool-isEOFBin (BinMem _ ix_r sz_r _) = do-  ix <- readFastMutInt ix_r-  sz <- readFastMutInt sz_r-  return (ix >= sz)- writeBinMem :: BinHandle -> FilePath -> IO () writeBinMem (BinMem _ ix_r _ arr_r) fn = do   h <- openBinaryFile fn WriteMode@@ -846,12 +829,10 @@     put_ bh AddrRep         = putByte bh 9     put_ bh FloatRep        = putByte bh 10     put_ bh DoubleRep       = putByte bh 11-#if __GLASGOW_HASKELL__ >= 807     put_ bh Int8Rep         = putByte bh 12     put_ bh Word8Rep        = putByte bh 13     put_ bh Int16Rep        = putByte bh 14     put_ bh Word16Rep       = putByte bh 15-#endif #if __GLASGOW_HASKELL__ >= 809     put_ bh Int32Rep        = putByte bh 16     put_ bh Word32Rep       = putByte bh 17@@ -872,12 +853,10 @@           9  -> pure AddrRep           10 -> pure FloatRep           11 -> pure DoubleRep-#if __GLASGOW_HASKELL__ >= 807           12 -> pure Int8Rep           13 -> pure Word8Rep           14 -> pure Int16Rep           15 -> pure Word16Rep-#endif #if __GLASGOW_HASKELL__ >= 809           16 -> pure Int32Rep           17 -> pure Word32Rep
compiler/utils/BooleanFormula.hs view
@@ -24,9 +24,9 @@ import MonadUtils import Outputable import Binary-import SrcLoc-import Unique-import UniqSet+import GHC.Types.SrcLoc+import GHC.Types.Unique+import GHC.Types.Unique.Set  ---------------------------------------------------------------------- -- Boolean formula type and smart constructors
compiler/utils/Digraph.hs view
@@ -58,8 +58,8 @@ import qualified Data.Graph as G import Data.Graph hiding (Graph, Edge, transposeG, reachable) import Data.Tree-import Unique-import UniqFM+import GHC.Types.Unique+import GHC.Types.Unique.FM  {- ************************************************************************
compiler/utils/FV.hs view
@@ -28,8 +28,8 @@  import GhcPrelude -import Var-import VarSet+import GHC.Types.Var+import GHC.Types.Var.Set  -- | Predicate on possible free variables: returns @True@ iff the variable is -- interesting@@ -40,7 +40,7 @@ -- When computing free variables, the order in which you get them affects -- the results of floating and specialization. If you use UniqFM to collect -- them and then turn that into a list, you get them in nondeterministic--- order as described in Note [Deterministic UniqFM] in UniqDFM.+-- order as described in Note [Deterministic UniqFM] in GHC.Types.Unique.DFM.  -- A naive algorithm for free variables relies on merging sets of variables. -- Merging costs O(n+m) for UniqFM and for UniqDFM there's an additional log@@ -54,7 +54,7 @@ type VarAcc = ([Var], VarSet)  -- List to preserve ordering and set to check for membership,                                -- so that the list doesn't have duplicates                                -- For explanation of why using `VarSet` is not deterministic see-                               -- Note [Deterministic UniqFM] in UniqDFM.+                               -- Note [Deterministic UniqFM] in GHC.Types.Unique.DFM.  -- Note [FV naming conventions] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/utils/FastString.hs view
@@ -531,16 +531,22 @@  do r <- memcmp ptr1 ptr2 len     return (r == 0) - hashStr  :: Ptr Word8 -> Int -> Int  -- use the Addr to produce a hash value between 0 & m (inclusive) hashStr (Ptr a#) (I# len#) = loop 0# 0#-   where-    loop h n | isTrue# (n ==# len#) = I# h-             | otherwise  = loop h2 (n +# 1#)-          where-            !c = ord# (indexCharOffAddr# a# n)-            !h2 = (h *# 16777619#) `xorI#` c+  where+    loop h n =+      if isTrue# (n ==# len#) then+        I# h+      else+        let+          -- DO NOT move this let binding! indexCharOffAddr# reads from the+          -- pointer so we need to evaluate this based on the length check+          -- above. Not doing this right caused #17909.+          !c = ord# (indexCharOffAddr# a# n)+          !h2 = (h *# 16777619#) `xorI#` c+        in+          loop h2 (n +# 1#)  -- ----------------------------------------------------------------------------- -- Operations
compiler/utils/FastStringEnv.hs view
@@ -29,14 +29,14 @@  import GhcPrelude -import UniqFM-import UniqDFM+import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM import Maybes import FastString   -- | A non-deterministic set of FastStrings.--- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why it's not -- deterministic and why it matters. Use DFastStringEnv if the set eventually -- gets converted into a list or folded over in a way where the order -- changes the generated code.@@ -82,7 +82,7 @@ lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n)  -- Deterministic FastStringEnv--- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need -- DFastStringEnv.  type DFastStringEnv a = UniqDFM a  -- Domain is FastString
compiler/utils/IOEnv.hs view
@@ -35,7 +35,7 @@  import GHC.Driver.Session import Exception-import Module+import GHC.Types.Module import Panic  import Data.IORef       ( IORef, newIORef, readIORef, writeIORef, modifyIORef,@@ -43,7 +43,6 @@ import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO        ( fixIO ) import Control.Monad-import qualified Control.Monad.Fail as MonadFail import MonadUtils import Control.Applicative (Alternative(..)) @@ -60,11 +59,8 @@ instance Monad (IOEnv m) where     (>>=)  = thenM     (>>)   = (*>)-#if !MIN_VERSION_base(4,13,0)-    fail   = MonadFail.fail-#endif -instance MonadFail.MonadFail (IOEnv m) where+instance MonadFail (IOEnv m) where     fail _ = failM -- Ignore the string  instance Applicative (IOEnv m) where
compiler/utils/MonadUtils.hs view
@@ -88,7 +88,7 @@ zipWithAndUnzipM :: Monad m                  => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) {-# INLINABLE zipWithAndUnzipM #-}--- See Note [flatten_many performance] in TcFlatten for why this+-- See Note [flatten_args performance] in TcFlatten for why this -- pragma is essential. zipWithAndUnzipM f (x:xs) (y:ys)   = do { (c, d) <- f x y
compiler/utils/Outputable.hs view
@@ -71,7 +71,7 @@         neverQualify, neverQualifyNames, neverQualifyModules,         alwaysQualifyPackages, neverQualifyPackages,         QualifyName(..), queryQual,-        sdocWithDynFlags, sdocWithPlatform, sdocOption,+        sdocWithDynFlags, sdocOption,         updSDocContext,         SDocContext (..), sdocWithContext,         getPprStyle, withPprStyle, setStyleColoured,@@ -96,17 +96,16 @@  import {-# SOURCE #-}   GHC.Driver.Session                            ( DynFlags, hasPprDebug, hasNoDebugOutput-                           , targetPlatform, pprUserLength, pprCols+                           , pprUserLength, pprCols                            , unsafeGlobalDynFlags, initSDocContext                            )-import {-# SOURCE #-}   Module( UnitId, Module, ModuleName, moduleName )-import {-# SOURCE #-}   OccName( OccName )+import {-# SOURCE #-}   GHC.Types.Module( UnitId, Module, ModuleName, moduleName )+import {-# SOURCE #-}   GHC.Types.Name.Occurrence( OccName )  import BufWrite (BufHandle) import FastString import qualified Pretty import Util-import GHC.Platform import qualified PprColour as Col import Pretty           ( Doc, Mode(..) ) import Panic@@ -346,7 +345,6 @@       -- ^ True if Unicode encoding is supported       -- and not disable by GHC_NO_UNICODE environment variable   , sdocHexWordLiterals             :: !Bool-  , sdocDebugLevel                  :: !Int   , sdocPprDebug                    :: !Bool   , sdocPrintUnicodeSyntax          :: !Bool   , sdocPrintCaseAsLet              :: !Bool@@ -421,9 +419,6 @@  sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx--sdocWithPlatform :: (Platform -> SDoc) -> SDoc-sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)  sdocWithContext :: (SDocContext -> SDoc) -> SDoc sdocWithContext f = SDoc $ \ctx -> runSDoc (f ctx) ctx
compiler/utils/TrieMap.hs view
@@ -31,9 +31,9 @@  import GhcPrelude -import Literal-import UniqDFM-import Unique( Unique )+import GHC.Types.Literal+import GHC.Types.Unique.DFM+import GHC.Types.Unique( Unique )  import qualified Data.Map    as Map import qualified Data.IntMap as IntMap@@ -198,7 +198,7 @@ conversion to a bag to be deterministic. For that purpose we use UniqDFM instead of UniqFM to implement the TrieMap. -See Note [Deterministic UniqFM] in UniqDFM for more details on how it's made+See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details on how it's made deterministic. -}
− compiler/utils/UniqDFM.hs 
@@ -1,420 +0,0 @@-{--(c) Bartosz Nitka, Facebook, 2015--UniqDFM: Specialised deterministic finite maps, for things with @Uniques@.--Basically, the things need to be in class @Uniquable@, and we use the-@getUnique@ method to grab their @Uniques@.--This is very similar to @UniqFM@, the major difference being that the order of-folding is not dependent on @Unique@ ordering, giving determinism.-Currently the ordering is determined by insertion order.--See Note [Unique Determinism] in Unique for explanation why @Unique@ ordering-is not deterministic.--}--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS_GHC -Wall #-}--module UniqDFM (-        -- * Unique-keyed deterministic mappings-        UniqDFM,       -- abstract type--        -- ** Manipulating those mappings-        emptyUDFM,-        unitUDFM,-        addToUDFM,-        addToUDFM_C,-        addListToUDFM,-        delFromUDFM,-        delListFromUDFM,-        adjustUDFM,-        alterUDFM,-        mapUDFM,-        plusUDFM,-        plusUDFM_C,-        lookupUDFM, lookupUDFM_Directly,-        elemUDFM,-        foldUDFM,-        eltsUDFM,-        filterUDFM, filterUDFM_Directly,-        isNullUDFM,-        sizeUDFM,-        intersectUDFM, udfmIntersectUFM,-        intersectsUDFM,-        disjointUDFM, disjointUdfmUfm,-        equalKeysUDFM,-        minusUDFM,-        listToUDFM,-        udfmMinusUFM,-        partitionUDFM,-        anyUDFM, allUDFM,-        pprUniqDFM, pprUDFM,--        udfmToList,-        udfmToUfm,-        nonDetFoldUDFM,-        alwaysUnsafeUfmToUdfm,-    ) where--import GhcPrelude--import Unique           ( Uniquable(..), Unique, getKey )-import Outputable--import qualified Data.IntMap as M-import Data.Data-import Data.Functor.Classes (Eq1 (..))-import Data.List (sortBy)-import Data.Function (on)-import qualified Data.Semigroup as Semi-import UniqFM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap)---- Note [Deterministic UniqFM]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~--- A @UniqDFM@ is just like @UniqFM@ with the following additional--- property: the function `udfmToList` returns the elements in some--- deterministic order not depending on the Unique key for those elements.------ If the client of the map performs operations on the map in deterministic--- order then `udfmToList` returns them in deterministic order.------ There is an implementation cost: each element is given a serial number--- as it is added, and `udfmToList` sorts it's result by this serial--- number. So you should only use `UniqDFM` if you need the deterministic--- property.------ `foldUDFM` also preserves determinism.------ Normal @UniqFM@ when you turn it into a list will use--- Data.IntMap.toList function that returns the elements in the order of--- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with--- with a list ordered by @Uniques@.--- The order of @Uniques@ is known to be not stable across rebuilds.--- See Note [Unique Determinism] in Unique.--------- There's more than one way to implement this. The implementation here tags--- every value with the insertion time that can later be used to sort the--- values when asked to convert to a list.------ An alternative would be to have------   data UniqDFM ele = UDFM (M.IntMap ele) [ele]------ where the list determines the order. This makes deletion tricky as we'd--- only accumulate elements in that list, but makes merging easier as you--- can just merge both structures independently.--- Deletion can probably be done in amortized fashion when the size of the--- list is twice the size of the set.---- | A type of values tagged with insertion time-data TaggedVal val =-  TaggedVal-    val-    {-# UNPACK #-} !Int -- ^ insertion time-  deriving (Data, Functor)--taggedFst :: TaggedVal val -> val-taggedFst (TaggedVal v _) = v--taggedSnd :: TaggedVal val -> Int-taggedSnd (TaggedVal _ i) = i--instance Eq val => Eq (TaggedVal val) where-  (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2---- | Type of unique deterministic finite maps-data UniqDFM ele =-  UDFM-    !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and-                                -- values are tagged with insertion time.-                                -- The invariant is that all the tags will-                                -- be distinct within a single map-    {-# UNPACK #-} !Int         -- Upper bound on the values' insertion-                                -- time. See Note [Overflow on plusUDFM]-  deriving (Data, Functor)---- | Deterministic, in O(n log n).-instance Foldable UniqDFM where-  foldr = foldUDFM---- | Deterministic, in O(n log n).-instance Traversable UniqDFM where-  traverse f = fmap listToUDFM_Directly-             . traverse (\(u,a) -> (u,) <$> f a)-             . udfmToList--emptyUDFM :: UniqDFM elt-emptyUDFM = UDFM M.empty 0--unitUDFM :: Uniquable key => key -> elt -> UniqDFM elt-unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1---- The new binding always goes to the right of existing ones-addToUDFM :: Uniquable key => UniqDFM elt -> key -> elt  -> UniqDFM elt-addToUDFM m k v = addToUDFM_Directly m (getUnique k) v---- The new binding always goes to the right of existing ones-addToUDFM_Directly :: UniqDFM elt -> Unique -> elt -> UniqDFM elt-addToUDFM_Directly (UDFM m i) u v-  = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)-  where-    tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i-      -- Keep the old tag, but insert the new value-      -- This means that udfmToList typically returns elements-      -- in the order of insertion, rather than the reverse--addToUDFM_Directly_C-  :: (elt -> elt -> elt)   -- old -> new -> result-  -> UniqDFM elt-  -> Unique -> elt-  -> UniqDFM elt-addToUDFM_Directly_C f (UDFM m i) u v-  = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)-    where-      tf (TaggedVal new_v _) (TaggedVal old_v old_i)-         = TaggedVal (f old_v new_v) old_i-          -- Flip the arguments, because M.insertWith uses  (new->old->result)-          --                         but f            needs (old->new->result)-          -- Like addToUDFM_Directly, keep the old tag--addToUDFM_C-  :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result-  -> UniqDFM elt -- old-  -> key -> elt -- new-  -> UniqDFM elt -- result-addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v--addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt-addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v)--addListToUDFM_Directly :: UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt-addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v)--addListToUDFM_Directly_C-  :: (elt -> elt -> elt) -> UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt-addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_Directly_C f m k v)--delFromUDFM :: Uniquable key => UniqDFM elt -> key -> UniqDFM elt-delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i--plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt-plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j)-  -- we will use the upper bound on the tag as a proxy for the set size,-  -- to insert the smaller one into the bigger one-  | i > j = insertUDFMIntoLeft_C f udfml udfmr-  | otherwise = insertUDFMIntoLeft_C f udfmr udfml---- Note [Overflow on plusUDFM]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~--- There are multiple ways of implementing plusUDFM.--- The main problem that needs to be solved is overlap on times of--- insertion between different keys in two maps.--- Consider:------ A = fromList [(a, (x, 1))]--- B = fromList [(b, (y, 1))]------ If you merge them naively you end up with:------ C = fromList [(a, (x, 1)), (b, (y, 1))]------ Which loses information about ordering and brings us back into--- non-deterministic world.------ The solution I considered before would increment the tags on one of the--- sets by the upper bound of the other set. The problem with this approach--- is that you'll run out of tags for some merge patterns.--- Say you start with A with upper bound 1, you merge A with A to get A' and--- the upper bound becomes 2. You merge A' with A' and the upper bound--- doubles again. After 64 merges you overflow.--- This solution would have the same time complexity as plusUFM, namely O(n+m).------ The solution I ended up with has time complexity of--- O(m log m + m * min (n+m, W)) where m is the smaller set.--- It simply inserts the elements of the smaller set into the larger--- set in the order that they were inserted into the smaller set. That's--- O(m log m) for extracting the elements from the smaller set in the--- insertion order and O(m * min(n+m, W)) to insert them into the bigger--- set.--plusUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt-plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j)-  -- we will use the upper bound on the tag as a proxy for the set size,-  -- to insert the smaller one into the bigger one-  | i > j = insertUDFMIntoLeft udfml udfmr-  | otherwise = insertUDFMIntoLeft udfmr udfml--insertUDFMIntoLeft :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt-insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr--insertUDFMIntoLeft_C-  :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt-insertUDFMIntoLeft_C f udfml udfmr =-  addListToUDFM_Directly_C f udfml $ udfmToList udfmr--lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt-lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m--lookupUDFM_Directly :: UniqDFM elt -> Unique -> Maybe elt-lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m--elemUDFM :: Uniquable key => key -> UniqDFM elt -> Bool-elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m---- | Performs a deterministic fold over the UniqDFM.--- It's O(n log n) while the corresponding function on `UniqFM` is O(n).-foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a-foldUDFM k z m = foldr k z (eltsUDFM m)---- | Performs a nondeterministic fold over the UniqDFM.--- It's O(n), same as the corresponding function on `UniqFM`.--- If you use this please provide a justification why it doesn't introduce--- nondeterminism.-nonDetFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a-nonDetFoldUDFM k z (UDFM m _i) = foldr k z $ map taggedFst $ M.elems m--eltsUDFM :: UniqDFM elt -> [elt]-eltsUDFM (UDFM m _i) =-  map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m--filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt-filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i--filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM elt -> UniqDFM elt-filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i-  where-  p' k (TaggedVal v _) = p (getUnique k) v---- | Converts `UniqDFM` to a list, with elements in deterministic order.--- It's O(n log n) while the corresponding function on `UniqFM` is O(n).-udfmToList :: UniqDFM elt -> [(Unique, elt)]-udfmToList (UDFM m _i) =-  [ (getUnique k, taggedFst v)-  | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]---- Determines whether two 'UniqDFM's contain the same keys.-equalKeysUDFM :: UniqDFM a -> UniqDFM b -> Bool-equalKeysUDFM (UDFM m1 _) (UDFM m2 _) = liftEq (\_ _ -> True) m1 m2--isNullUDFM :: UniqDFM elt -> Bool-isNullUDFM (UDFM m _) = M.null m--sizeUDFM :: UniqDFM elt -> Int-sizeUDFM (UDFM m _i) = M.size m--intersectUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt-intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i-  -- M.intersection is left biased, that means the result will only have-  -- a subset of elements from the left set, so `i` is a good upper bound.--udfmIntersectUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1-udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i-  -- M.intersection is left biased, that means the result will only have-  -- a subset of elements from the left set, so `i` is a good upper bound.--intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool-intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y)--disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool-disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y)--disjointUdfmUfm :: UniqDFM elt -> UniqFM elt2 -> Bool-disjointUdfmUfm (UDFM x _i) y = M.null (M.intersection x (ufmToIntMap y))--minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1-minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i-  -- M.difference returns a subset of a left set, so `i` is a good upper-  -- bound.--udfmMinusUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1-udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i-  -- M.difference returns a subset of a left set, so `i` is a good upper-  -- bound.---- | Partition UniqDFM into two UniqDFMs according to the predicate-partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt)-partitionUDFM p (UDFM m i) =-  case M.partition (p . taggedFst) m of-    (left, right) -> (UDFM left i, UDFM right i)---- | Delete a list of elements from a UniqDFM-delListFromUDFM  :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt-delListFromUDFM = foldl' delFromUDFM---- | This allows for lossy conversion from UniqDFM to UniqFM-udfmToUfm :: UniqDFM elt -> UniqFM elt-udfmToUfm (UDFM m _i) =-  listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m]--listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt-listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM--listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt-listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM---- | Apply a function to a particular element-adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt-adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i---- | The expression (alterUDFM f k map) alters value x at k, or absence--- thereof. alterUDFM can be used to insert, delete, or update a value in--- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are--- more efficient.-alterUDFM-  :: Uniquable key-  => (Maybe elt -> Maybe elt)  -- How to adjust-  -> UniqDFM elt               -- old-  -> key                       -- new-  -> UniqDFM elt               -- result-alterUDFM f (UDFM m i) k =-  UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1)-  where-  alterf Nothing = inject $ f Nothing-  alterf (Just (TaggedVal v _)) = inject $ f (Just v)-  inject Nothing = Nothing-  inject (Just v) = Just $ TaggedVal v i---- | Map a function over every value in a UniqDFM-mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2-mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i--anyUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool-anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m--allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool-allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m--instance Semi.Semigroup (UniqDFM a) where-  (<>) = plusUDFM--instance Monoid (UniqDFM a) where-  mempty = emptyUDFM-  mappend = (Semi.<>)---- This should not be used in committed code, provided for convenience to--- make ad-hoc conversions when developing-alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt-alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList---- Output-ery--instance Outputable a => Outputable (UniqDFM a) where-    ppr ufm = pprUniqDFM ppr ufm--pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc-pprUniqDFM ppr_elt ufm-  = brackets $ fsep $ punctuate comma $-    [ ppr uq <+> text ":->" <+> ppr_elt elt-    | (uq, elt) <- udfmToList ufm ]--pprUDFM :: UniqDFM a    -- ^ The things to be pretty printed-       -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements-       -> SDoc          -- ^ 'SDoc' where the things have been pretty-                        -- printed-pprUDFM ufm pp = pp (eltsUDFM ufm)
− compiler/utils/UniqDSet.hs 
@@ -1,141 +0,0 @@--- (c) Bartosz Nitka, Facebook, 2015---- |--- Specialised deterministic sets, for things with @Uniques@------ Based on 'UniqDFM's (as you would expect).--- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need it.------ Basically, the things need to be in class 'Uniquable'.--{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}--module UniqDSet (-        -- * Unique set type-        UniqDSet,    -- type synonym for UniqFM a-        getUniqDSet,-        pprUniqDSet,--        -- ** Manipulating these sets-        delOneFromUniqDSet, delListFromUniqDSet,-        emptyUniqDSet,-        unitUniqDSet,-        mkUniqDSet,-        addOneToUniqDSet, addListToUniqDSet,-        unionUniqDSets, unionManyUniqDSets,-        minusUniqDSet, uniqDSetMinusUniqSet,-        intersectUniqDSets, uniqDSetIntersectUniqSet,-        foldUniqDSet,-        elementOfUniqDSet,-        filterUniqDSet,-        sizeUniqDSet,-        isEmptyUniqDSet,-        lookupUniqDSet,-        uniqDSetToList,-        partitionUniqDSet,-        mapUniqDSet-    ) where--import GhcPrelude--import Outputable-import UniqDFM-import UniqSet-import Unique--import Data.Coerce-import Data.Data-import qualified Data.Semigroup as Semi---- See Note [UniqSet invariant] in UniqSet.hs for why we want a newtype here.--- Beyond preserving invariants, we may also want to 'override' typeclass--- instances.--newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a}-                   deriving (Data, Semi.Semigroup, Monoid)--emptyUniqDSet :: UniqDSet a-emptyUniqDSet = UniqDSet emptyUDFM--unitUniqDSet :: Uniquable a => a -> UniqDSet a-unitUniqDSet x = UniqDSet (unitUDFM x x)--mkUniqDSet :: Uniquable a => [a] -> UniqDSet a-mkUniqDSet = foldl' addOneToUniqDSet emptyUniqDSet---- The new element always goes to the right of existing ones.-addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a-addOneToUniqDSet (UniqDSet set) x = UniqDSet (addToUDFM set x x)--addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a-addListToUniqDSet = foldl' addOneToUniqDSet--delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a-delOneFromUniqDSet (UniqDSet s) = UniqDSet . delFromUDFM s--delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a-delListFromUniqDSet (UniqDSet s) = UniqDSet . delListFromUDFM s--unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a-unionUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (plusUDFM s t)--unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a-unionManyUniqDSets [] = emptyUniqDSet-unionManyUniqDSets sets = foldr1 unionUniqDSets sets--minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a-minusUniqDSet (UniqDSet s) (UniqDSet t) = UniqDSet (minusUDFM s t)--uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a-uniqDSetMinusUniqSet xs ys-  = UniqDSet (udfmMinusUFM (getUniqDSet xs) (getUniqSet ys))--intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a-intersectUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (intersectUDFM s t)--uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a-uniqDSetIntersectUniqSet xs ys-  = UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys))--foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b-foldUniqDSet c n (UniqDSet s) = foldUDFM c n s--elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool-elementOfUniqDSet k = elemUDFM k . getUniqDSet--filterUniqDSet :: (a -> Bool) -> UniqDSet a -> UniqDSet a-filterUniqDSet p (UniqDSet s) = UniqDSet (filterUDFM p s)--sizeUniqDSet :: UniqDSet a -> Int-sizeUniqDSet = sizeUDFM . getUniqDSet--isEmptyUniqDSet :: UniqDSet a -> Bool-isEmptyUniqDSet = isNullUDFM . getUniqDSet--lookupUniqDSet :: Uniquable a => UniqDSet a -> a -> Maybe a-lookupUniqDSet = lookupUDFM . getUniqDSet--uniqDSetToList :: UniqDSet a -> [a]-uniqDSetToList = eltsUDFM . getUniqDSet--partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a)-partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet---- See Note [UniqSet invariant] in UniqSet.hs-mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b-mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList---- Two 'UniqDSet's are considered equal if they contain the same--- uniques.-instance Eq (UniqDSet a) where-  UniqDSet a == UniqDSet b = equalKeysUDFM a b--getUniqDSet :: UniqDSet a -> UniqDFM a-getUniqDSet = getUniqDSet'--instance Outputable a => Outputable (UniqDSet a) where-  ppr = pprUniqDSet ppr--pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc-pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList
− compiler/utils/UniqFM.hs 
@@ -1,416 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The AQUA Project, Glasgow University, 1994-1998---UniqFM: Specialised finite maps, for things with @Uniques@.--Basically, the things need to be in class @Uniquable@, and we use the-@getUnique@ method to grab their @Uniques@.--(A similar thing to @UniqSet@, as opposed to @Set@.)--The interface is based on @FiniteMap@s, but the implementation uses-@Data.IntMap@, which is both maintained and faster than the past-implementation (see commit log).--The @UniqFM@ interface maps directly to Data.IntMap, only-``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased-and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order-of arguments of combining function.--}--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -Wall #-}--module UniqFM (-        -- * Unique-keyed mappings-        UniqFM,           -- abstract type-        NonDetUniqFM(..), -- wrapper for opting into nondeterminism--        -- ** Manipulating those mappings-        emptyUFM,-        unitUFM,-        unitDirectlyUFM,-        listToUFM,-        listToUFM_Directly,-        listToUFM_C,-        addToUFM,addToUFM_C,addToUFM_Acc,-        addListToUFM,addListToUFM_C,-        addToUFM_Directly,-        addListToUFM_Directly,-        adjustUFM, alterUFM,-        adjustUFM_Directly,-        delFromUFM,-        delFromUFM_Directly,-        delListFromUFM,-        delListFromUFM_Directly,-        plusUFM,-        plusUFM_C,-        plusUFM_CD,-        plusMaybeUFM_C,-        plusUFMList,-        minusUFM,-        intersectUFM,-        intersectUFM_C,-        disjointUFM,-        equalKeysUFM,-        nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly,-        anyUFM, allUFM, seqEltsUFM,-        mapUFM, mapUFM_Directly,-        elemUFM, elemUFM_Directly,-        filterUFM, filterUFM_Directly, partitionUFM,-        sizeUFM,-        isNullUFM,-        lookupUFM, lookupUFM_Directly,-        lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,-        nonDetEltsUFM, eltsUFM, nonDetKeysUFM,-        ufmToSet_Directly,-        nonDetUFMToList, ufmToIntMap,-        pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM-    ) where--import GhcPrelude--import Unique           ( Uniquable(..), Unique, getKey )-import Outputable--import qualified Data.IntMap as M-import qualified Data.IntSet as S-import Data.Data-import qualified Data.Semigroup as Semi-import Data.Functor.Classes (Eq1 (..))---newtype UniqFM ele = UFM (M.IntMap ele)-  deriving (Data, Eq, Functor)-  -- Nondeterministic Foldable and Traversable instances are accessible through-  -- use of the 'NonDetUniqFM' wrapper.-  -- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism.--emptyUFM :: UniqFM elt-emptyUFM = UFM M.empty--isNullUFM :: UniqFM elt -> Bool-isNullUFM (UFM m) = M.null m--unitUFM :: Uniquable key => key -> elt -> UniqFM elt-unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v)---- when you've got the Unique already-unitDirectlyUFM :: Unique -> elt -> UniqFM elt-unitDirectlyUFM u v = UFM (M.singleton (getKey u) v)--listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt-listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM--listToUFM_Directly :: [(Unique, elt)] -> UniqFM elt-listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM--listToUFM_C-  :: Uniquable key-  => (elt -> elt -> elt)-  -> [(key, elt)]-  -> UniqFM elt-listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM--addToUFM :: Uniquable key => UniqFM elt -> key -> elt  -> UniqFM elt-addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m)--addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt-addListToUFM = foldl' (\m (k, v) -> addToUFM m k v)--addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt-addListToUFM_Directly = foldl' (\m (k, v) -> addToUFM_Directly m k v)--addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt-addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m)--addToUFM_C-  :: Uniquable key-  => (elt -> elt -> elt)  -- old -> new -> result-  -> UniqFM elt           -- old-  -> key -> elt           -- new-  -> UniqFM elt           -- result--- Arguments of combining function of M.insertWith and addToUFM_C are flipped.-addToUFM_C f (UFM m) k v =-  UFM (M.insertWith (flip f) (getKey $ getUnique k) v m)--addToUFM_Acc-  :: Uniquable key-  => (elt -> elts -> elts)  -- Add to existing-  -> (elt -> elts)          -- New element-  -> UniqFM elts            -- old-  -> key -> elt             -- new-  -> UniqFM elts            -- result-addToUFM_Acc exi new (UFM m) k v =-  UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m)--alterUFM-  :: Uniquable key-  => (Maybe elt -> Maybe elt)  -- How to adjust-  -> UniqFM elt                -- old-  -> key                       -- new-  -> UniqFM elt                -- result-alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m)--addListToUFM_C-  :: Uniquable key-  => (elt -> elt -> elt)-  -> UniqFM elt -> [(key,elt)]-  -> UniqFM elt-addListToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v)--adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt-adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m)--adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt-adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m)--delFromUFM :: Uniquable key => UniqFM elt -> key    -> UniqFM elt-delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)--delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt-delListFromUFM = foldl' delFromUFM--delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt-delListFromUFM_Directly = foldl' delFromUFM_Directly--delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt-delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)---- Bindings in right argument shadow those in the left-plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt--- M.union is left-biased, plusUFM should be right-biased.-plusUFM (UFM x) (UFM y) = UFM (M.union y x)-     -- Note (M.union y x), with arguments flipped-     -- M.union is left-biased, plusUFM should be right-biased.--plusUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt-plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)---- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the--- combinding function and `d1` resp. `d2` as the default value if--- there is no entry in `m1` reps. `m2`. The domain is the union of--- the domains of `m1` and `m2`.------ Representative example:------ @--- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42---    == {A: f 1 42, B: f 2 3, C: f 23 4 }--- @-plusUFM_CD-  :: (elt -> elt -> elt)-  -> UniqFM elt  -- map X-  -> elt         -- default for X-  -> UniqFM elt  -- map Y-  -> elt         -- default for Y-  -> UniqFM elt-plusUFM_CD f (UFM xm) dx (UFM ym) dy-  = UFM $ M.mergeWithKey-      (\_ x y -> Just (x `f` y))-      (M.map (\x -> x `f` dy))-      (M.map (\y -> dx `f` y))-      xm ym--plusMaybeUFM_C :: (elt -> elt -> Maybe elt)-               -> UniqFM elt -> UniqFM elt -> UniqFM elt-plusMaybeUFM_C f (UFM xm) (UFM ym)-    = UFM $ M.mergeWithKey-        (\_ x y -> x `f` y)-        id-        id-        xm ym--plusUFMList :: [UniqFM elt] -> UniqFM elt-plusUFMList = foldl' plusUFM emptyUFM--minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1-minusUFM (UFM x) (UFM y) = UFM (M.difference x y)--intersectUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1-intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y)--intersectUFM_C-  :: (elt1 -> elt2 -> elt3)-  -> UniqFM elt1-  -> UniqFM elt2-  -> UniqFM elt3-intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)--disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool-disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y)--foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a-foldUFM k z (UFM m) = M.foldr k z m--mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2-mapUFM f (UFM m) = UFM (M.map f m)--mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2-mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)--filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt-filterUFM p (UFM m) = UFM (M.filter p m)--filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt-filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m)--partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt)-partitionUFM p (UFM m) =-  case M.partition p m of-    (left, right) -> (UFM left, UFM right)--sizeUFM :: UniqFM elt -> Int-sizeUFM (UFM m) = M.size m--elemUFM :: Uniquable key => key -> UniqFM elt -> Bool-elemUFM k (UFM m) = M.member (getKey $ getUnique k) m--elemUFM_Directly :: Unique -> UniqFM elt -> Bool-elemUFM_Directly u (UFM m) = M.member (getKey u) m--lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt-lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m---- when you've got the Unique already-lookupUFM_Directly :: UniqFM elt -> Unique -> Maybe elt-lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m--lookupWithDefaultUFM :: Uniquable key => UniqFM elt -> elt -> key -> elt-lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m--lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt-lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m--eltsUFM :: UniqFM elt -> [elt]-eltsUFM (UFM m) = M.elems m--ufmToSet_Directly :: UniqFM elt -> S.IntSet-ufmToSet_Directly (UFM m) = M.keysSet m--anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool-anyUFM p (UFM m) = M.foldr ((||) . p) False m--allUFM :: (elt -> Bool) -> UniqFM elt -> Bool-allUFM p (UFM m) = M.foldr ((&&) . p) True m--seqEltsUFM :: ([elt] -> ()) -> UniqFM elt -> ()-seqEltsUFM seqList = seqList . nonDetEltsUFM-  -- It's OK to use nonDetEltsUFM here because the type guarantees that-  -- the only interesting thing this function can do is to force the-  -- elements.---- See Note [Deterministic UniqFM] to learn about nondeterminism.--- If you use this please provide a justification why it doesn't introduce--- nondeterminism.-nonDetEltsUFM :: UniqFM elt -> [elt]-nonDetEltsUFM (UFM m) = M.elems m---- See Note [Deterministic UniqFM] to learn about nondeterminism.--- If you use this please provide a justification why it doesn't introduce--- nondeterminism.-nonDetKeysUFM :: UniqFM elt -> [Unique]-nonDetKeysUFM (UFM m) = map getUnique $ M.keys m---- See Note [Deterministic UniqFM] to learn about nondeterminism.--- If you use this please provide a justification why it doesn't introduce--- nondeterminism.-nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a-nonDetFoldUFM k z (UFM m) = M.foldr k z m---- See Note [Deterministic UniqFM] to learn about nondeterminism.--- If you use this please provide a justification why it doesn't introduce--- nondeterminism.-nonDetFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a-nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m---- See Note [Deterministic UniqFM] to learn about nondeterminism.--- If you use this please provide a justification why it doesn't introduce--- nondeterminism.-nonDetUFMToList :: UniqFM elt -> [(Unique, elt)]-nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m---- | A wrapper around 'UniqFM' with the sole purpose of informing call sites--- that the provided 'Foldable' and 'Traversable' instances are--- nondeterministic.--- If you use this please provide a justification why it doesn't introduce--- nondeterminism.--- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism.-newtype NonDetUniqFM ele = NonDetUniqFM { getNonDet :: UniqFM ele }-  deriving (Functor)---- | Inherently nondeterministic.--- If you use this please provide a justification why it doesn't introduce--- nondeterminism.--- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism.-instance Foldable NonDetUniqFM where-  foldr f z (NonDetUniqFM (UFM m)) = foldr f z m---- | Inherently nondeterministic.--- If you use this please provide a justification why it doesn't introduce--- nondeterminism.--- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism.-instance Traversable NonDetUniqFM where-  traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m--ufmToIntMap :: UniqFM elt -> M.IntMap elt-ufmToIntMap (UFM m) = m---- Determines whether two 'UniqFM's contain the same keys.-equalKeysUFM :: UniqFM a -> UniqFM b -> Bool-equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2---- Instances--instance Semi.Semigroup (UniqFM a) where-  (<>) = plusUFM--instance Monoid (UniqFM a) where-    mempty = emptyUFM-    mappend = (Semi.<>)---- Output-ery--instance Outputable a => Outputable (UniqFM a) where-    ppr ufm = pprUniqFM ppr ufm--pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc-pprUniqFM ppr_elt ufm-  = brackets $ fsep $ punctuate comma $-    [ ppr uq <+> text ":->" <+> ppr_elt elt-    | (uq, elt) <- nonDetUFMToList ufm ]-  -- It's OK to use nonDetUFMToList here because we only use it for-  -- pretty-printing.---- | Pretty-print a non-deterministic set.--- The order of variables is non-deterministic and for pretty-printing that--- shouldn't be a problem.--- Having this function helps contain the non-determinism created with--- nonDetEltsUFM.-pprUFM :: UniqFM a      -- ^ The things to be pretty printed-       -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements-       -> SDoc          -- ^ 'SDoc' where the things have been pretty-                        -- printed-pprUFM ufm pp = pp (nonDetEltsUFM ufm)---- | Pretty-print a non-deterministic set.--- The order of variables is non-deterministic and for pretty-printing that--- shouldn't be a problem.--- Having this function helps contain the non-determinism created with--- nonDetUFMToList.-pprUFMWithKeys-       :: UniqFM a                -- ^ The things to be pretty printed-       -> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements-       -> SDoc                    -- ^ 'SDoc' where the things have been pretty-                                  -- printed-pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm)---- | Determines the pluralisation suffix appropriate for the length of a set--- in the same way that plural from Outputable does for lists.-pluralUFM :: UniqFM a -> SDoc-pluralUFM ufm-  | sizeUFM ufm == 1 = empty-  | otherwise = char 's'
− compiler/utils/UniqSet.hs 
@@ -1,195 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The AQUA Project, Glasgow University, 1994-1998--\section[UniqSet]{Specialised sets, for things with @Uniques@}--Based on @UniqFMs@ (as you would expect).--Basically, the things need to be in class @Uniquable@.--}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}--module UniqSet (-        -- * Unique set type-        UniqSet,    -- type synonym for UniqFM a-        getUniqSet,-        pprUniqSet,--        -- ** Manipulating these sets-        emptyUniqSet,-        unitUniqSet,-        mkUniqSet,-        addOneToUniqSet, addListToUniqSet,-        delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet,-        delListFromUniqSet_Directly,-        unionUniqSets, unionManyUniqSets,-        minusUniqSet, uniqSetMinusUFM,-        intersectUniqSets,-        restrictUniqSetToUFM,-        uniqSetAny, uniqSetAll,-        elementOfUniqSet,-        elemUniqSet_Directly,-        filterUniqSet,-        filterUniqSet_Directly,-        sizeUniqSet,-        isEmptyUniqSet,-        lookupUniqSet,-        lookupUniqSet_Directly,-        partitionUniqSet,-        mapUniqSet,-        unsafeUFMToUniqSet,-        nonDetEltsUniqSet,-        nonDetKeysUniqSet,-        nonDetFoldUniqSet,-        nonDetFoldUniqSet_Directly-    ) where--import GhcPrelude--import UniqFM-import Unique-import Data.Coerce-import Outputable-import Data.Data-import qualified Data.Semigroup as Semi---- Note [UniqSet invariant]--- ~~~~~~~~~~~~~~~~~~~~~~~~~--- UniqSet has the following invariant:---   The keys in the map are the uniques of the values--- It means that to implement mapUniqSet you have to update--- both the keys and the values.--newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a}-                  deriving (Data, Semi.Semigroup, Monoid)--emptyUniqSet :: UniqSet a-emptyUniqSet = UniqSet emptyUFM--unitUniqSet :: Uniquable a => a -> UniqSet a-unitUniqSet x = UniqSet $ unitUFM x x--mkUniqSet :: Uniquable a => [a]  -> UniqSet a-mkUniqSet = foldl' addOneToUniqSet emptyUniqSet--addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a-addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x)--addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a-addListToUniqSet = foldl' addOneToUniqSet--delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a-delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a)--delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a-delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u)--delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a-delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l)--delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a-delListFromUniqSet_Directly (UniqSet s) l =-    UniqSet (delListFromUFM_Directly s l)--unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a-unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t)--unionManyUniqSets :: [UniqSet a] -> UniqSet a-unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet--minusUniqSet  :: UniqSet a -> UniqSet a -> UniqSet a-minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t)--intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a-intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t)--restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a-restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m)--uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a-uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t)--elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool-elementOfUniqSet a (UniqSet s) = elemUFM a s--elemUniqSet_Directly :: Unique -> UniqSet a -> Bool-elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s--filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a-filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s)--filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt-filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s)--partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a)-partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s)--uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool-uniqSetAny p (UniqSet s) = anyUFM p s--uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool-uniqSetAll p (UniqSet s) = allUFM p s--sizeUniqSet :: UniqSet a -> Int-sizeUniqSet (UniqSet s) = sizeUFM s--isEmptyUniqSet :: UniqSet a -> Bool-isEmptyUniqSet (UniqSet s) = isNullUFM s--lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b-lookupUniqSet (UniqSet s) k = lookupUFM s k--lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a-lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k---- See Note [Deterministic UniqFM] to learn about nondeterminism.--- If you use this please provide a justification why it doesn't introduce--- nondeterminism.-nonDetEltsUniqSet :: UniqSet elt -> [elt]-nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet'---- See Note [Deterministic UniqFM] to learn about nondeterminism.--- If you use this please provide a justification why it doesn't introduce--- nondeterminism.-nonDetKeysUniqSet :: UniqSet elt -> [Unique]-nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet'---- See Note [Deterministic UniqFM] to learn about nondeterminism.--- If you use this please provide a justification why it doesn't introduce--- nondeterminism.-nonDetFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a-nonDetFoldUniqSet c n (UniqSet s) = nonDetFoldUFM c n s---- See Note [Deterministic UniqFM] to learn about nondeterminism.--- If you use this please provide a justification why it doesn't introduce--- nondeterminism.-nonDetFoldUniqSet_Directly:: (Unique -> elt -> a -> a) -> a -> UniqSet elt -> a-nonDetFoldUniqSet_Directly f n (UniqSet s) = nonDetFoldUFM_Directly f n s---- See Note [UniqSet invariant]-mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b-mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet---- Two 'UniqSet's are considered equal if they contain the same--- uniques.-instance Eq (UniqSet a) where-  UniqSet a == UniqSet b = equalKeysUFM a b--getUniqSet :: UniqSet a -> UniqFM a-getUniqSet = getUniqSet'---- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@--- assuming, without checking, that it maps each 'Unique' to a value--- that has that 'Unique'. See Note [UniqSet invariant].-unsafeUFMToUniqSet :: UniqFM a -> UniqSet a-unsafeUFMToUniqSet = UniqSet--instance Outputable a => Outputable (UniqSet a) where-    ppr = pprUniqSet ppr--pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc--- It's OK to use nonDetUFMToList here because we only use it for--- pretty-printing.-pprUniqSet f = braces . pprWithCommas f . nonDetEltsUniqSet
compiler/utils/Util.hs view
@@ -13,7 +13,6 @@ module Util (         -- * Flags dependent on the compiler build         ghciSupported, debugIsOn,-        ghciTablesNextToCode,         isWindowsHost, isDarwinHost,          -- * Miscellaneous higher-order functions@@ -203,13 +202,6 @@ debugIsOn = False #endif -ghciTablesNextToCode :: Bool-#if defined(GHCI_TABLES_NEXT_TO_CODE)-ghciTablesNextToCode = True-#else-ghciTablesNextToCode = False-#endif- isWindowsHost :: Bool #if defined(mingw32_HOST_OS) isWindowsHost = True@@ -577,13 +569,13 @@  -- Debugging/specialising versions of \tr{elem} and \tr{notElem} -isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool- # if !defined(DEBUG)+isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool isIn    _msg x ys = x `elem` ys isn'tIn _msg x ys = x `notElem` ys  # else /* DEBUG */+isIn, isn'tIn :: (HasDebugCallStack, Eq a) => String -> a -> [a] -> Bool isIn msg x ys   = elem100 0 x ys   where
ghc-lib-parser.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-parser-version: 0.20200301+version: 0.20200401 license: BSD3 license-file: LICENSE category: Development@@ -121,6 +121,7 @@         UnboxedTuples         UndecidableInstances     c-sources:+        libraries/ghc-heap/cbits/HeapPrim.cmm         compiler/cbits/genSym.c         compiler/cbits/cutils.c     hs-source-dirs:@@ -128,16 +129,12 @@         ghc-lib/stage0/compiler/build         libraries/template-haskell         libraries/ghc-boot-th-        compiler/basicTypes-        compiler/profiling-        compiler/simplCore         compiler/typecheck         libraries/ghc-boot         libraries/ghc-heap         compiler/prelude         compiler/parser         compiler/iface-        compiler/types         compiler/utils         libraries/ghci         compiler/main@@ -147,47 +144,31 @@         Lexer         Parser     exposed-modules:-        Annotations         ApiAnnotation-        Avail         Bag-        BasicTypes         BinFingerprint         Binary         BooleanFormula         BufWrite-        Class         CliOption-        CoAxiom-        Coercion-        ConLike         Config         Constants         Constraint-        CoreMonad-        CostCentre-        CostCentreState-        Cpr         Ctype-        DataCon-        Demand         Digraph         Encoding         EnumSet         ErrUtils         Exception         FV-        FamInstEnv         FastFunctions         FastMutInt         FastString         FastStringEnv-        FieldLabel         FileCleanup         FileSettings         Fingerprint         FiniteMap-        ForeignCall         GHC.BaseDir         GHC.ByteCode.Types         GHC.Cmm@@ -204,21 +185,43 @@         GHC.Cmm.Type         GHC.Core         GHC.Core.Arity+        GHC.Core.Class+        GHC.Core.Coercion+        GHC.Core.Coercion.Axiom+        GHC.Core.Coercion.Opt+        GHC.Core.ConLike+        GHC.Core.DataCon         GHC.Core.FVs+        GHC.Core.FamInstEnv+        GHC.Core.InstEnv         GHC.Core.Make         GHC.Core.Map+        GHC.Core.Op.ConstantFold+        GHC.Core.Op.Monad+        GHC.Core.Op.OccurAnal         GHC.Core.Op.Tidy+        GHC.Core.PatSyn         GHC.Core.Ppr+        GHC.Core.Predicate         GHC.Core.Rules         GHC.Core.Seq         GHC.Core.SimpleOpt         GHC.Core.Stats         GHC.Core.Subst+        GHC.Core.TyCo.FVs+        GHC.Core.TyCo.Ppr+        GHC.Core.TyCo.Rep+        GHC.Core.TyCo.Subst+        GHC.Core.TyCo.Tidy+        GHC.Core.TyCon+        GHC.Core.Type         GHC.Core.Unfold+        GHC.Core.Unify         GHC.Core.Utils         GHC.CoreToIface         GHC.Driver.Backpack.Syntax         GHC.Driver.CmdLine+        GHC.Driver.Flags         GHC.Driver.Hooks         GHC.Driver.Monad         GHC.Driver.Packages@@ -227,6 +230,7 @@         GHC.Driver.Plugins         GHC.Driver.Session         GHC.Driver.Types+        GHC.Driver.Ways         GHC.Exts.Heap         GHC.Exts.Heap.ClosureTypes         GHC.Exts.Heap.Closures@@ -275,8 +279,39 @@         GHC.Runtime.Linker.Types         GHC.Serialized         GHC.Stg.Syntax+        GHC.Types.Annotations+        GHC.Types.Avail+        GHC.Types.Basic+        GHC.Types.CostCentre+        GHC.Types.CostCentre.State+        GHC.Types.Cpr+        GHC.Types.Demand+        GHC.Types.FieldLabel+        GHC.Types.ForeignCall+        GHC.Types.Id+        GHC.Types.Id.Info+        GHC.Types.Id.Make+        GHC.Types.Literal+        GHC.Types.Module+        GHC.Types.Name+        GHC.Types.Name.Cache+        GHC.Types.Name.Env+        GHC.Types.Name.Occurrence+        GHC.Types.Name.Reader+        GHC.Types.Name.Set         GHC.Types.RepType+        GHC.Types.SrcLoc+        GHC.Types.Unique+        GHC.Types.Unique.DFM+        GHC.Types.Unique.DSet+        GHC.Types.Unique.FM+        GHC.Types.Unique.Set+        GHC.Types.Unique.Supply+        GHC.Types.Var+        GHC.Types.Var.Env+        GHC.Types.Var.Set         GHC.UniqueSubdir+        GHC.Utils.Lexeme         GHC.Version         GHCi.BreakArray         GHCi.FFI@@ -288,9 +323,6 @@         HaddockUtils         HeaderInfo         IOEnv-        Id-        IdInfo-        InstEnv         Json         KnownUniques         Language.Haskell.TH@@ -301,40 +333,24 @@         Language.Haskell.TH.Ppr         Language.Haskell.TH.PprLib         Language.Haskell.TH.Syntax-        Lexeme         Lexer         ListSetOps-        Literal         Maybes-        MkId-        Module         MonadUtils-        Name-        NameCache-        NameEnv-        NameSet-        OccName-        OccurAnal-        OptCoercion         OrdList         Outputable         Pair         Panic         Parser-        PatSyn         PlainPanic         PlatformConstants         PprColour-        Predicate         PrelNames-        PrelRules         Pretty         PrimOp         RdrHsSyn-        RdrName         Settings         SizedSeq-        SrcLoc         Stream         StringBuffer         SysTools.BaseDir@@ -346,24 +362,7 @@         TcType         ToolSettings         TrieMap-        TyCoFVs-        TyCoPpr-        TyCoRep-        TyCoSubst-        TyCoTidy-        TyCon-        Type         TysPrim         TysWiredIn-        Unify-        UniqDFM-        UniqDSet-        UniqFM-        UniqSet-        UniqSupply-        Unique         UnitInfo         Util-        Var-        VarEnv-        VarSet
ghc-lib/stage0/compiler/build/Config.hs view
@@ -22,7 +22,7 @@ cProjectName          = "The Glorious Glasgow Haskell Compilation System"  cBooterVersion        :: String-cBooterVersion        = "8.6.5"+cBooterVersion        = "8.8.3"  cStage                :: String cStage                = show (1 :: Int)
ghc-lib/stage0/compiler/build/Lexer.hs view
@@ -58,7 +58,7 @@ import Outputable import StringBuffer import FastString-import UniqFM+import GHC.Types.Unique.FM import Util             ( readRational, readHexRational )  -- compiler/main@@ -66,11 +66,11 @@ import GHC.Driver.Session as DynFlags  -- compiler/basicTypes-import SrcLoc-import Module-import BasicTypes     ( InlineSpec(..), RuleMatchInfo(..),-                        IntegralLit(..), FractionalLit(..),-                        SourceText(..) )+import GHC.Types.SrcLoc+import GHC.Types.Module+import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..),+                         IntegralLit(..), FractionalLit(..),+                         SourceText(..) )  -- compiler/parser import Ctype@@ -84,11 +84,11 @@ #endif #if __GLASGOW_HASKELL__ >= 503 import Data.Array-import Data.Array.Base (unsafeAt) #else import Array #endif #if __GLASGOW_HASKELL__ >= 503+import Data.Array.Base (unsafeAt) import GHC.Exts #else import GlaExts
ghc-lib/stage0/compiler/build/Parser.hs view
@@ -43,8 +43,8 @@ import GHC.Hs  -- compiler/main-import GHC.Driver.Phases     ( HscSource(..) )-import GHC.Driver.Types         ( IsBootInterface, WarningTxt(..) )+import GHC.Driver.Phases  ( HscSource(..) )+import GHC.Driver.Types   ( IsBootInterface, WarningTxt(..) ) import GHC.Driver.Session import GHC.Driver.Backpack.Syntax import UnitInfo@@ -57,16 +57,16 @@ import Outputable  -- compiler/basicTypes-import RdrName-import OccName          ( varName, dataName, tcClsName, tvName, startsWithUnderscore )-import DataCon          ( DataCon, dataConName )-import SrcLoc-import Module-import BasicTypes+import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, startsWithUnderscore )+import GHC.Core.DataCon          ( DataCon, dataConName )+import GHC.Types.SrcLoc+import GHC.Types.Module+import GHC.Types.Basic  -- compiler/types-import Type             ( funTyCon )-import Class            ( FunDep )+import GHC.Core.Type    ( funTyCon )+import GHC.Core.Class   ( FunDep )  -- compiler/parser import RdrHsSyn@@ -78,7 +78,7 @@ import TcEvidence       ( emptyTcEvBinds )  -- compiler/prelude-import ForeignCall+import GHC.Types.ForeignCall import TysPrim          ( eqPrimTyCon ) import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon,                           unboxedUnitTyCon, unboxedUnitDataCon,
ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs view
@@ -111,7 +111,6 @@     rESERVED_STACK_WORDS,     aP_STACK_SPLIM,     wORD_SIZE,-    dOUBLE_SIZE,     cINT_SIZE,     cLONG_SIZE,     cLONG_LONG_SIZE,
ghc-lib/stage0/lib/GHCConstantsHaskellType.hs view
@@ -118,7 +118,6 @@       pc_RESERVED_STACK_WORDS :: Int,       pc_AP_STACK_SPLIM :: Int,       pc_WORD_SIZE :: Int,-      pc_DOUBLE_SIZE :: Int,       pc_CINT_SIZE :: Int,       pc_CLONG_SIZE :: Int,       pc_CLONG_LONG_SIZE :: Int,
ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs view
@@ -224,8 +224,6 @@ aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (platformConstants dflags) wORD_SIZE :: DynFlags -> Int wORD_SIZE dflags = pc_WORD_SIZE (platformConstants dflags)-dOUBLE_SIZE :: DynFlags -> Int-dOUBLE_SIZE dflags = pc_DOUBLE_SIZE (platformConstants dflags) cINT_SIZE :: DynFlags -> Int cINT_SIZE dflags = pc_CINT_SIZE (platformConstants dflags) cLONG_SIZE :: DynFlags -> Int
ghc-lib/stage0/lib/ghcversion.h view
@@ -6,7 +6,7 @@ #endif  #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200229+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200331  #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\    ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \
ghc-lib/stage0/lib/platformConstants view
@@ -118,7 +118,6 @@       pc_RESERVED_STACK_WORDS = 21,       pc_AP_STACK_SPLIM = 1024,       pc_WORD_SIZE = 8,-      pc_DOUBLE_SIZE = 8,       pc_CINT_SIZE = 4,       pc_CLONG_SIZE = 8,       pc_CLONG_LONG_SIZE = 8,
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view
@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?]  cProjectGitCommitId   :: String-cProjectGitCommitId   = "04d30137771a6cf8a18fda1ced25f78d0b2eb204"+cProjectGitCommitId   = "4b9c586472bf99425f7bbcf346472d7c54f05028"  cProjectVersion       :: String-cProjectVersion       = "8.11.0.20200229"+cProjectVersion       = "8.11.0.20200331"  cProjectVersionInt    :: String cProjectVersionInt    = "811"  cProjectPatchLevel    :: String-cProjectPatchLevel    = "020200229"+cProjectPatchLevel    = "020200331"  cProjectPatchLevel1   :: String cProjectPatchLevel1   = "0"  cProjectPatchLevel2   :: String-cProjectPatchLevel2   = "20200229"+cProjectPatchLevel2   = "20200331"
includes/MachDeps.h view
@@ -32,9 +32,7 @@  *  * To get target's values it is preferred to use runtime target  * configuration from 'targetPlatform :: DynFlags -> Platform'- * record. A few wrappers are already defined and used throughout GHC:- *    wORD_SIZE :: DynFlags -> Int- *    wORD_SIZE dflags = pc_WORD_SIZE (platformConstants dflags)+ * record.  *  * Hence we hide these macros from GHC_STAGE=1  */
libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs view
@@ -21,7 +21,8 @@ -- here as this would require adding transitive dependencies to the -- @template-haskell@ package, which must have a minimal dependency set. data Extension--- See Note [Updating flag description in the User's Guide] in DynFlags+-- See Note [Updating flag description in the User's Guide] in+-- GHC.Driver.Session    = Cpp    | OverlappingInstances    | UndecidableInstances
libraries/ghc-boot/GHC/Platform.hs view
@@ -21,6 +21,11 @@         platformUsesFrameworks,         platformWordSizeInBytes,         platformWordSizeInBits,+        platformMinInt,+        platformMaxInt,+        platformMaxWord,+        platformInIntRange,+        platformInWordRange,          PlatformMisc(..),         IntegerLibrary(..),@@ -33,6 +38,8 @@  import Prelude -- See Note [Why do we import Prelude here?] import GHC.Read+import Data.Word+import Data.Int  -- | Contains the bare-bones arch and os information. This isn't enough for -- code gen, but useful for tasks where we can fall back upon the host@@ -305,3 +312,29 @@     = IntegerGMP     | IntegerSimple     deriving (Read, Show, Eq)++-- | Minimum representable Int value for the given platform+platformMinInt :: Platform -> Integer+platformMinInt p = case platformWordSize p of+   PW4 -> toInteger (minBound :: Int32)+   PW8 -> toInteger (minBound :: Int64)++-- | Maximum representable Int value for the given platform+platformMaxInt :: Platform -> Integer+platformMaxInt p = case platformWordSize p of+   PW4 -> toInteger (maxBound :: Int32)+   PW8 -> toInteger (maxBound :: Int64)++-- | Maximum representable Word value for the given platform+platformMaxWord :: Platform -> Integer+platformMaxWord p = case platformWordSize p of+   PW4 -> toInteger (maxBound :: Word32)+   PW8 -> toInteger (maxBound :: Word64)++-- | Test if the given Integer is representable with a platform Int+platformInIntRange :: Platform -> Integer -> Bool+platformInIntRange platform x = x >= platformMinInt platform && x <= platformMaxInt platform++-- | Test if the given Integer is representable with a platform Word+platformInWordRange :: Platform -> Integer -> Bool+platformInWordRange platform x = x >= 0 && x <= platformMaxWord platform
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs view
@@ -50,13 +50,10 @@ ------------------------------------------------------------------------ -- Boxes -aToWord# :: Any -> Word#-aToWord# _ = 0##---reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#-reallyUnsafePtrEqualityUpToTag# _ _ = 0#+foreign import prim "aToWordzh" aToWord# :: Any -> Word# +foreign import prim "reallyUnsafePtrEqualityUpToTag"+    reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#  -- | An arbitrary Haskell value in a safe Box. The point is that even -- unevaluated thunks can safely be moved around inside the Box, and when@@ -350,7 +347,8 @@ allClosures _ = []  #if __GLASGOW_HASKELL__ >= 809--- | Get the size of a closure in words.+-- | Get the size of the top-level closure in words.+-- Includes header and payload. Does not follow pointers. -- -- @since 8.10.1 closureSize :: Box -> Int
libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc view
@@ -31,10 +31,10 @@ -- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/InfoTables.h> -- for more details on this data structure. data StgInfoTable = StgInfoTable {-   entry  :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode+   entry  :: Maybe EntryFunPtr, -- Just <=> not TABLES_NEXT_TO_CODE    ptrs   :: HalfWord,    nptrs  :: HalfWord,    tipe   :: ClosureType,    srtlen :: HalfWord,-   code   :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode+   code   :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE   } deriving (Show, Generic)
+ libraries/ghc-heap/cbits/HeapPrim.cmm view
@@ -0,0 +1,13 @@+#include "Cmm.h"++aToWordzh (P_ clos)+{+    return (clos);+}++reallyUnsafePtrEqualityUpToTag (W_ clos1, W_  clos2)+{+    clos1 = UNTAG(clos1);+    clos2 = UNTAG(clos2);+    return (clos1 == clos2);+}
libraries/ghci/GHCi/Message.hs view
@@ -104,7 +104,8 @@    -- | Create an info table for a constructor   MkConInfoTable-   :: Int     -- ptr words+   :: Bool    -- TABLES_NEXT_TO_CODE+   -> Int     -- ptr words    -> Int     -- non-ptr words    -> Int     -- constr tag    -> Int     -- pointer tag@@ -215,8 +216,13 @@   -- | Evaluate something. This is used to support :force in GHCi.   Seq     :: HValueRef-    -> Message (EvalResult ())+    -> Message (EvalStatus ()) +  -- | Resume forcing a free variable in a breakpoint (#2950)+  ResumeSeq+    :: RemoteRef (ResumeContext ())+    -> Message (EvalStatus ())+ deriving instance Show (Message a)  @@ -472,7 +478,7 @@       15 -> Msg <$> MallocStrings <$> get       16 -> Msg <$> (PrepFFI <$> get <*> get <*> get)       17 -> Msg <$> FreeFFI <$> get-      18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get)+      18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get <*> get)       19 -> Msg <$> (EvalStmt <$> get <*> get)       20 -> Msg <$> (ResumeStmt <$> get <*> get)       21 -> Msg <$> (AbandonStmt <$> get)@@ -492,6 +498,7 @@       35 -> Msg <$> (GetClosure <$> get)       36 -> Msg <$> (Seq <$> get)       37 -> Msg <$> return RtsRevertCAFs+      38 -> Msg <$> (ResumeSeq <$> get)       _  -> error $ "Unknown Message code " ++ (show b)  putMessage :: Message a -> Put@@ -514,7 +521,7 @@   MallocStrings bss           -> putWord8 15 >> put bss   PrepFFI conv args res       -> putWord8 16 >> put conv >> put args >> put res   FreeFFI p                   -> putWord8 17 >> put p-  MkConInfoTable p n t pt d   -> putWord8 18 >> put p >> put n >> put t >> put pt >> put d+  MkConInfoTable tc p n t pt d -> putWord8 18 >> put tc >> put p >> put n >> put t >> put pt >> put d   EvalStmt opts val           -> putWord8 19 >> put opts >> put val   ResumeStmt opts val         -> putWord8 20 >> put opts >> put val   AbandonStmt val             -> putWord8 21 >> put val@@ -534,6 +541,7 @@   GetClosure a                -> putWord8 35 >> put a   Seq a                       -> putWord8 36 >> put a   RtsRevertCAFs               -> putWord8 37+  ResumeSeq a                 -> putWord8 38 >> put a  -- ----------------------------------------------------------------------------- -- Reading/writing messages
libraries/template-haskell/Language/Haskell/TH/Syntax.hs view
@@ -52,15 +52,13 @@ import Prelude import Foreign.ForeignPtr -import qualified Control.Monad.Fail as Fail- ----------------------------------------------------- -- --              The Quasi class -- ----------------------------------------------------- -class (MonadIO m, Fail.MonadFail m) => Quasi m where+class (MonadIO m, MonadFail m) => Quasi m where   qNewName :: String -> m Name         -- ^ Fresh names @@ -187,12 +185,9 @@ instance Monad Q where   Q m >>= k  = Q (m >>= \x -> unQ (k x))   (>>) = (*>)-#if !MIN_VERSION_base(4,13,0)-  fail       = Fail.fail-#endif -instance Fail.MonadFail Q where-  fail s     = report True s >> Q (Fail.fail "Q monad failure")+instance MonadFail Q where+  fail s     = report True s >> Q (fail "Q monad failure")  instance Functor Q where   fmap f (Q x) = Q (fmap f x)