{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GHC.Core.Lint (
lintCoreBindings, lintUnfolding,
lintPassResult, lintInteractiveExpr, lintExpr,
lintAnnots, lintAxioms,
interactiveInScope,
endPass, endPassIO,
displayLintResults, dumpPassResult
) where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Env
import GHC.Driver.Config.Diagnostic
import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree )
import GHC.Unit.Module.ModGuts
import GHC.Runtime.Context
import GHC.Core
import GHC.Core.FVs
import GHC.Core.Utils
import GHC.Core.Stats ( coreBindsStats )
import GHC.Core.Opt.Monad
import GHC.Core.DataCon
import GHC.Core.Ppr
import GHC.Core.Coercion
import GHC.Core.Type as Type
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Subst
import GHC.Core.TyCo.FVs
import GHC.Core.TyCo.Ppr ( pprTyVar, pprTyVars )
import GHC.Core.TyCon as TyCon
import GHC.Core.Coercion.Axiom
import GHC.Core.Unify
import GHC.Core.InstEnv ( instanceDFunId, instEnvElts )
import GHC.Core.Coercion.Opt ( checkAxInstCo )
import GHC.Core.Opt.Arity ( typeArity )
import GHC.Types.Literal
import GHC.Types.Var as Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Unique.Set( nonDetEltsUniqSet )
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.SrcLoc
import GHC.Types.Tickish
import GHC.Types.RepType
import GHC.Types.Basic
import GHC.Types.Demand ( splitDmdSig, isDeadEndDiv )
import GHC.Types.TypeEnv
import GHC.Builtin.Names
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types ( multiplicityTy )
import GHC.Data.Bag
import GHC.Data.List.SetOps
import GHC.Utils.Monad
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Utils.Trace
import GHC.Utils.Error
import qualified GHC.Utils.Error as Err
import GHC.Utils.Logger
import Control.Monad
import Data.Foldable ( toList )
import Data.List.NonEmpty ( NonEmpty(..), groupWith )
import Data.List ( partition )
import Data.Maybe
import GHC.Data.Pair
import qualified GHC.LanguageExtensions as LangExt
endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
endPass CoreToDo
pass CoreProgram
binds [CoreRule]
rules
= do { HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
; PrintUnqualified
print_unqual <- CoreM PrintUnqualified
getPrintUnqualified
; IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ HscEnv
-> PrintUnqualified
-> CoreToDo
-> CoreProgram
-> [CoreRule]
-> IO ()
endPassIO HscEnv
hsc_env PrintUnqualified
print_unqual CoreToDo
pass CoreProgram
binds [CoreRule]
rules }
endPassIO :: HscEnv -> PrintUnqualified
-> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
endPassIO :: HscEnv
-> PrintUnqualified
-> CoreToDo
-> CoreProgram
-> [CoreRule]
-> IO ()
endPassIO HscEnv
hsc_env PrintUnqualified
print_unqual CoreToDo
pass CoreProgram
binds [CoreRule]
rules
= do { Logger
-> Bool
-> PrintUnqualified
-> Maybe DumpFlag
-> String
-> SDoc
-> CoreProgram
-> [CoreRule]
-> IO ()
dumpPassResult Logger
logger Bool
dump_core_sizes PrintUnqualified
print_unqual Maybe DumpFlag
mb_flag
(DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)) (CoreToDo -> SDoc
pprPassDetails CoreToDo
pass) CoreProgram
binds [CoreRule]
rules
; HscEnv -> CoreToDo -> CoreProgram -> IO ()
lintPassResult HscEnv
hsc_env CoreToDo
pass CoreProgram
binds }
where
dump_core_sizes :: Bool
dump_core_sizes = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressCoreSizes DynFlags
dflags)
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
mb_flag :: Maybe DumpFlag
mb_flag = case CoreToDo -> Maybe DumpFlag
coreDumpFlag CoreToDo
pass of
Just DumpFlag
flag | Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
flag -> DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
flag
| Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_verbose_core2core -> DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
flag
Maybe DumpFlag
_ -> Maybe DumpFlag
forall a. Maybe a
Nothing
dumpPassResult :: Logger
-> Bool
-> PrintUnqualified
-> Maybe DumpFlag
-> String
-> SDoc
-> CoreProgram -> [CoreRule]
-> IO ()
dumpPassResult :: Logger
-> Bool
-> PrintUnqualified
-> Maybe DumpFlag
-> String
-> SDoc
-> CoreProgram
-> [CoreRule]
-> IO ()
dumpPassResult Logger
logger Bool
dump_core_sizes PrintUnqualified
unqual Maybe DumpFlag
mb_flag String
hdr SDoc
extra_info CoreProgram
binds [CoreRule]
rules
= do { Maybe DumpFlag -> (DumpFlag -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe DumpFlag
mb_flag ((DumpFlag -> IO ()) -> IO ()) -> (DumpFlag -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \DumpFlag
flag -> do
Logger
-> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
logDumpFile Logger
logger (PrintUnqualified -> PprStyle
mkDumpStyle PrintUnqualified
unqual) DumpFlag
flag String
hdr DumpFormat
FormatCore SDoc
dump_doc
; Logger -> Int -> SDoc -> IO ()
Err.debugTraceMsg Logger
logger Int
2 SDoc
size_doc
}
where
size_doc :: SDoc
size_doc = [SDoc] -> SDoc
sep [String -> SDoc
text String
"Result size of" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
hdr, Int -> SDoc -> SDoc
nest Int
2 (SDoc
equals SDoc -> SDoc -> SDoc
<+> CoreStats -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreProgram -> CoreStats
coreBindsStats CoreProgram
binds))]
dump_doc :: SDoc
dump_doc = [SDoc] -> SDoc
vcat [ Int -> SDoc -> SDoc
nest Int
2 SDoc
extra_info
, SDoc
size_doc
, SDoc
blankLine
, if Bool
dump_core_sizes
then CoreProgram -> SDoc
pprCoreBindingsWithSize CoreProgram
binds
else CoreProgram -> SDoc
forall b. OutputableBndr b => [Bind b] -> SDoc
pprCoreBindings CoreProgram
binds
, Bool -> SDoc -> SDoc
ppUnless ([CoreRule] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
rules) SDoc
pp_rules ]
pp_rules :: SDoc
pp_rules = [SDoc] -> SDoc
vcat [ SDoc
blankLine
, String -> SDoc
text String
"------ Local rules for imported ids --------"
, [CoreRule] -> SDoc
pprRules [CoreRule]
rules ]
coreDumpFlag :: CoreToDo -> Maybe DumpFlag
coreDumpFlag :: CoreToDo -> Maybe DumpFlag
coreDumpFlag (CoreDoSimplify {}) = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_verbose_core2core
coreDumpFlag (CoreDoPluginPass {}) = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_verbose_core2core
coreDumpFlag CoreToDo
CoreDoFloatInwards = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_verbose_core2core
coreDumpFlag (CoreDoFloatOutwards {}) = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_verbose_core2core
coreDumpFlag CoreToDo
CoreLiberateCase = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_verbose_core2core
coreDumpFlag CoreToDo
CoreDoStaticArgs = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_verbose_core2core
coreDumpFlag CoreToDo
CoreDoCallArity = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_call_arity
coreDumpFlag CoreToDo
CoreDoExitify = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_exitify
coreDumpFlag CoreToDo
CoreDoDemand = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_stranal
coreDumpFlag CoreToDo
CoreDoCpr = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_cpranal
coreDumpFlag CoreToDo
CoreDoWorkerWrapper = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_worker_wrapper
coreDumpFlag CoreToDo
CoreDoSpecialising = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_spec
coreDumpFlag CoreToDo
CoreDoSpecConstr = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_spec
coreDumpFlag CoreToDo
CoreCSE = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_cse
coreDumpFlag CoreToDo
CoreDesugar = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_ds_preopt
coreDumpFlag CoreToDo
CoreDesugarOpt = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_ds
coreDumpFlag CoreToDo
CoreTidy = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_simpl
coreDumpFlag CoreToDo
CorePrep = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_prep
coreDumpFlag CoreToDo
CoreOccurAnal = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_occur_anal
coreDumpFlag CoreToDo
CoreAddCallerCcs = Maybe DumpFlag
forall a. Maybe a
Nothing
coreDumpFlag CoreToDo
CoreAddLateCcs = Maybe DumpFlag
forall a. Maybe a
Nothing
coreDumpFlag CoreToDo
CoreDoPrintCore = Maybe DumpFlag
forall a. Maybe a
Nothing
coreDumpFlag (CoreDoRuleCheck {}) = Maybe DumpFlag
forall a. Maybe a
Nothing
coreDumpFlag CoreToDo
CoreDoNothing = Maybe DumpFlag
forall a. Maybe a
Nothing
coreDumpFlag (CoreDoPasses {}) = Maybe DumpFlag
forall a. Maybe a
Nothing
lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
lintPassResult HscEnv
hsc_env CoreToDo
pass CoreProgram
binds
| Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoCoreLinting DynFlags
dflags)
= () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= do { let warns_and_errs :: WarnsAndErrs
warns_and_errs = DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
lintCoreBindings DynFlags
dflags CoreToDo
pass (InteractiveContext -> [Var]
interactiveInScope (InteractiveContext -> [Var]) -> InteractiveContext -> [Var]
forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) CoreProgram
binds
; Logger -> String -> IO ()
Err.showPass Logger
logger (String
"Core Linted result of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> CoreToDo -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags CoreToDo
pass)
; Logger -> Bool -> SDoc -> SDoc -> WarnsAndErrs -> IO ()
displayLintResults Logger
logger (CoreToDo -> Bool
showLintWarnings CoreToDo
pass) (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)
(CoreProgram -> SDoc
forall b. OutputableBndr b => [Bind b] -> SDoc
pprCoreBindings CoreProgram
binds) WarnsAndErrs
warns_and_errs }
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
displayLintResults :: Logger
-> Bool
-> SDoc
-> SDoc
-> WarnsAndErrs
-> IO ()
displayLintResults :: Logger -> Bool -> SDoc -> SDoc -> WarnsAndErrs -> IO ()
displayLintResults Logger
logger Bool
display_warnings SDoc
pp_what SDoc
pp_pgm (Bag SDoc
warns, Bag SDoc
errs)
| Bool -> Bool
not (Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
errs)
= do { Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
Err.MCDump SrcSpan
noSrcSpan
(SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle
([SDoc] -> SDoc
vcat [ String -> SDoc -> SDoc
lint_banner String
"errors" SDoc
pp_what, Bag SDoc -> SDoc
Err.pprMessageBag Bag SDoc
errs
, String -> SDoc
text String
"*** Offending Program ***"
, SDoc
pp_pgm
, String -> SDoc
text String
"*** End of Offense ***" ])
; Logger -> Int -> IO ()
Err.ghcExit Logger
logger Int
1 }
| Bool -> Bool
not (Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
warns)
, LogFlags -> Bool
log_enable_debug (Logger -> LogFlags
logFlags Logger
logger)
, Bool
display_warnings
= Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
Err.MCInfo SrcSpan
noSrcSpan
(SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle
(String -> SDoc -> SDoc
lint_banner String
"warnings" SDoc
pp_what SDoc -> SDoc -> SDoc
$$ Bag SDoc -> SDoc
Err.pprMessageBag ((SDoc -> SDoc) -> Bag SDoc -> Bag SDoc
forall a b. (a -> b) -> Bag a -> Bag b
mapBag (SDoc -> SDoc -> SDoc
$$ SDoc
blankLine) Bag SDoc
warns))
| Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lint_banner :: String -> SDoc -> SDoc
lint_banner :: String -> SDoc -> SDoc
lint_banner String
string SDoc
pass = String -> SDoc
text String
"*** Core Lint" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
string
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
": in result of" SDoc -> SDoc -> SDoc
<+> SDoc
pass
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"***"
showLintWarnings :: CoreToDo -> Bool
showLintWarnings :: CoreToDo -> Bool
showLintWarnings (CoreDoSimplify Int
_ (SimplMode { sm_phase :: SimplMode -> CompilerPhase
sm_phase = CompilerPhase
InitialPhase })) = Bool
False
showLintWarnings CoreToDo
_ = Bool
True
lintInteractiveExpr :: SDoc
-> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr :: SDoc -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr SDoc
what HscEnv
hsc_env CoreExpr
expr
| Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoCoreLinting DynFlags
dflags)
= () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Just Bag SDoc
err <- DynFlags -> [Var] -> CoreExpr -> Maybe (Bag SDoc)
lintExpr DynFlags
dflags (InteractiveContext -> [Var]
interactiveInScope (InteractiveContext -> [Var]) -> InteractiveContext -> [Var]
forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) CoreExpr
expr
= Logger -> Bool -> SDoc -> SDoc -> WarnsAndErrs -> IO ()
displayLintResults Logger
logger Bool
False SDoc
what (CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
expr) (Bag SDoc
forall a. Bag a
emptyBag, Bag SDoc
err)
| Bool
otherwise
= () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
interactiveInScope :: InteractiveContext -> [Var]
interactiveInScope :: InteractiveContext -> [Var]
interactiveInScope InteractiveContext
ictxt
= [Var]
tyvars [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
ids
where
(InstEnv
cls_insts, [FamInst]
_fam_insts) = InteractiveContext -> (InstEnv, [FamInst])
ic_instances InteractiveContext
ictxt
te1 :: TypeEnv
te1 = [TyThing] -> TypeEnv
mkTypeEnvWithImplicits (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
ictxt)
te :: TypeEnv
te = TypeEnv -> [Var] -> TypeEnv
extendTypeEnvWithIds TypeEnv
te1 ((ClsInst -> Var) -> [ClsInst] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> Var
instanceDFunId ([ClsInst] -> [Var]) -> [ClsInst] -> [Var]
forall a b. (a -> b) -> a -> b
$ InstEnv -> [ClsInst]
instEnvElts InstEnv
cls_insts)
ids :: [Var]
ids = TypeEnv -> [Var]
typeEnvIds TypeEnv
te
tyvars :: [Var]
tyvars = [Type] -> [Var]
tyCoVarsOfTypesList ([Type] -> [Var]) -> [Type] -> [Var]
forall a b. (a -> b) -> a -> b
$ (Var -> Type) -> [Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
idType [Var]
ids
lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
lintCoreBindings DynFlags
dflags CoreToDo
pass [Var]
local_in_scope CoreProgram
binds
= DynFlags
-> LintFlags -> [Var] -> LintM ((), [UsageEnv]) -> WarnsAndErrs
forall a. DynFlags -> LintFlags -> [Var] -> LintM a -> WarnsAndErrs
initL DynFlags
dflags LintFlags
flags [Var]
local_in_scope (LintM ((), [UsageEnv]) -> WarnsAndErrs)
-> LintM ((), [UsageEnv]) -> WarnsAndErrs
forall a b. (a -> b) -> a -> b
$
LintLocInfo -> LintM ((), [UsageEnv]) -> LintM ((), [UsageEnv])
forall a. LintLocInfo -> LintM a -> LintM a
addLoc LintLocInfo
TopLevelBindings (LintM ((), [UsageEnv]) -> LintM ((), [UsageEnv]))
-> LintM ((), [UsageEnv]) -> LintM ((), [UsageEnv])
forall a b. (a -> b) -> a -> b
$
do { Bool -> SDoc -> LintM ()
checkL ([NonEmpty Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NonEmpty Var]
dups) ([NonEmpty Var] -> SDoc
dupVars [NonEmpty Var]
dups)
; Bool -> SDoc -> LintM ()
checkL ([NonEmpty Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NonEmpty Name]
ext_dups) ([NonEmpty Name] -> SDoc
dupExtVars [NonEmpty Name]
ext_dups)
; TopLevelFlag
-> [(Var, CoreExpr)]
-> ([Var] -> LintM ())
-> LintM ((), [UsageEnv])
forall a.
TopLevelFlag
-> [(Var, CoreExpr)] -> ([Var] -> LintM a) -> LintM (a, [UsageEnv])
lintRecBindings TopLevelFlag
TopLevel [(Var, CoreExpr)]
all_pairs (([Var] -> LintM ()) -> LintM ((), [UsageEnv]))
-> ([Var] -> LintM ()) -> LintM ((), [UsageEnv])
forall a b. (a -> b) -> a -> b
$ \[Var]
_ ->
() -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
where
all_pairs :: [(Var, CoreExpr)]
all_pairs = CoreProgram -> [(Var, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds CoreProgram
binds
binders :: [Var]
binders = ((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
all_pairs
flags :: LintFlags
flags = (DynFlags -> LintFlags
defaultLintFlags DynFlags
dflags)
{ lf_check_global_ids :: Bool
lf_check_global_ids = Bool
check_globals
, lf_check_inline_loop_breakers :: Bool
lf_check_inline_loop_breakers = Bool
check_lbs
, lf_check_static_ptrs :: StaticPtrCheck
lf_check_static_ptrs = StaticPtrCheck
check_static_ptrs
, lf_check_linearity :: Bool
lf_check_linearity = Bool
check_linearity
, lf_check_fixed_rep :: Bool
lf_check_fixed_rep = Bool
check_fixed_rep }
check_fixed_rep :: Bool
check_fixed_rep = case CoreToDo
pass of
CoreToDo
CoreDesugar -> Bool
False
CoreToDo
_ -> Bool
True
check_globals :: Bool
check_globals = case CoreToDo
pass of
CoreToDo
CoreTidy -> Bool
False
CoreToDo
CorePrep -> Bool
False
CoreToDo
_ -> Bool
True
check_lbs :: Bool
check_lbs = case CoreToDo
pass of
CoreToDo
CoreDesugar -> Bool
False
CoreToDo
CoreDesugarOpt -> Bool
False
CoreToDo
_ -> Bool
True
check_static_ptrs :: StaticPtrCheck
check_static_ptrs | Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.StaticPointers DynFlags
dflags) = StaticPtrCheck
AllowAnywhere
| Bool
otherwise = case CoreToDo
pass of
CoreDoFloatOutwards FloatOutSwitches
_ -> StaticPtrCheck
AllowAtTopLevel
CoreToDo
CoreTidy -> StaticPtrCheck
RejectEverywhere
CoreToDo
CorePrep -> StaticPtrCheck
AllowAtTopLevel
CoreToDo
_ -> StaticPtrCheck
AllowAnywhere
check_linearity :: Bool
check_linearity = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoLinearCoreLinting DynFlags
dflags Bool -> Bool -> Bool
|| (
case CoreToDo
pass of
CoreToDo
CoreDesugar -> Bool
True
CoreToDo
_ -> Bool
False)
([Var]
_, [NonEmpty Var]
dups) = (Var -> Var -> Ordering) -> [Var] -> ([Var], [NonEmpty Var])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups Var -> Var -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [Var]
binders
ext_dups :: [NonEmpty Name]
ext_dups = ([Name], [NonEmpty Name]) -> [NonEmpty Name]
forall a b. (a, b) -> b
snd ((Name -> Name -> Ordering) -> [Name] -> ([Name], [NonEmpty Name])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups Name -> Name -> Ordering
ord_ext ((Var -> Name) -> [Var] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Name
Var.varName [Var]
binders))
ord_ext :: Name -> Name -> Ordering
ord_ext Name
n1 Name
n2 | Just Module
m1 <- Name -> Maybe Module
nameModule_maybe Name
n1
, Just Module
m2 <- Name -> Maybe Module
nameModule_maybe Name
n2
= (Module, OccName) -> (Module, OccName) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Module
m1, Name -> OccName
nameOccName Name
n1) (Module
m2, Name -> OccName
nameOccName Name
n2)
| Bool
otherwise = Ordering
LT
lintUnfolding :: Bool
-> DynFlags
-> SrcLoc
-> VarSet
-> CoreExpr
-> Maybe (Bag SDoc)
lintUnfolding :: Bool
-> DynFlags -> SrcLoc -> VarSet -> CoreExpr -> Maybe (Bag SDoc)
lintUnfolding Bool
is_compulsory DynFlags
dflags SrcLoc
locn VarSet
var_set CoreExpr
expr
| Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
errs = Maybe (Bag SDoc)
forall a. Maybe a
Nothing
| Bool
otherwise = Bag SDoc -> Maybe (Bag SDoc)
forall a. a -> Maybe a
Just Bag SDoc
errs
where
vars :: [Var]
vars = VarSet -> [Var]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet VarSet
var_set
(Bag SDoc
_warns, Bag SDoc
errs) = DynFlags
-> LintFlags -> [Var] -> LintM (Type, UsageEnv) -> WarnsAndErrs
forall a. DynFlags -> LintFlags -> [Var] -> LintM a -> WarnsAndErrs
initL DynFlags
dflags (DynFlags -> LintFlags
defaultLintFlags DynFlags
dflags) [Var]
vars (LintM (Type, UsageEnv) -> WarnsAndErrs)
-> LintM (Type, UsageEnv) -> WarnsAndErrs
forall a b. (a -> b) -> a -> b
$
if Bool
is_compulsory
then LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintM a -> LintM a
noFixedRuntimeRepChecks LintM (Type, UsageEnv)
linter
else LintM (Type, UsageEnv)
linter
linter :: LintM (Type, UsageEnv)
linter = LintLocInfo -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (SrcLoc -> LintLocInfo
ImportedUnfolding SrcLoc
locn) (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$
CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
expr
lintExpr :: DynFlags
-> [Var]
-> CoreExpr
-> Maybe (Bag SDoc)
lintExpr :: DynFlags -> [Var] -> CoreExpr -> Maybe (Bag SDoc)
lintExpr DynFlags
dflags [Var]
vars CoreExpr
expr
| Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
errs = Maybe (Bag SDoc)
forall a. Maybe a
Nothing
| Bool
otherwise = Bag SDoc -> Maybe (Bag SDoc)
forall a. a -> Maybe a
Just Bag SDoc
errs
where
(Bag SDoc
_warns, Bag SDoc
errs) = DynFlags
-> LintFlags -> [Var] -> LintM (Type, UsageEnv) -> WarnsAndErrs
forall a. DynFlags -> LintFlags -> [Var] -> LintM a -> WarnsAndErrs
initL DynFlags
dflags (DynFlags -> LintFlags
defaultLintFlags DynFlags
dflags) [Var]
vars LintM (Type, UsageEnv)
linter
linter :: LintM (Type, UsageEnv)
linter = LintLocInfo -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintLocInfo -> LintM a -> LintM a
addLoc LintLocInfo
TopLevelBindings (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$
CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
expr
lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)]
-> ([LintedId] -> LintM a) -> LintM (a, [UsageEnv])
lintRecBindings :: TopLevelFlag
-> [(Var, CoreExpr)] -> ([Var] -> LintM a) -> LintM (a, [UsageEnv])
lintRecBindings TopLevelFlag
top_lvl [(Var, CoreExpr)]
pairs [Var] -> LintM a
thing_inside
= TopLevelFlag
-> [Var]
-> ([Var] -> LintM (a, [UsageEnv]))
-> LintM (a, [UsageEnv])
forall a. TopLevelFlag -> [Var] -> ([Var] -> LintM a) -> LintM a
lintIdBndrs TopLevelFlag
top_lvl [Var]
bndrs (([Var] -> LintM (a, [UsageEnv])) -> LintM (a, [UsageEnv]))
-> ([Var] -> LintM (a, [UsageEnv])) -> LintM (a, [UsageEnv])
forall a b. (a -> b) -> a -> b
$ \ [Var]
bndrs' ->
do { [UsageEnv]
ues <- (Var -> CoreExpr -> LintM UsageEnv)
-> [Var] -> [CoreExpr] -> LintM [UsageEnv]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Var -> CoreExpr -> LintM UsageEnv
lint_pair [Var]
bndrs' [CoreExpr]
rhss
; a
a <- [Var] -> LintM a
thing_inside [Var]
bndrs'
; (a, [UsageEnv]) -> LintM (a, [UsageEnv])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, [UsageEnv]
ues) }
where
([Var]
bndrs, [CoreExpr]
rhss) = [(Var, CoreExpr)] -> ([Var], [CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, CoreExpr)]
pairs
lint_pair :: Var -> CoreExpr -> LintM UsageEnv
lint_pair Var
bndr' CoreExpr
rhs
= LintLocInfo -> LintM UsageEnv -> LintM UsageEnv
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
RhsOf Var
bndr') (LintM UsageEnv -> LintM UsageEnv)
-> LintM UsageEnv -> LintM UsageEnv
forall a b. (a -> b) -> a -> b
$
do { (Type
rhs_ty, UsageEnv
ue) <- Var -> CoreExpr -> LintM (Type, UsageEnv)
lintRhs Var
bndr' CoreExpr
rhs
; TopLevelFlag -> RecFlag -> Var -> CoreExpr -> Type -> LintM ()
lintLetBind TopLevelFlag
top_lvl RecFlag
Recursive Var
bndr' CoreExpr
rhs Type
rhs_ty
; UsageEnv -> LintM UsageEnv
forall (m :: * -> *) a. Monad m => a -> m a
return UsageEnv
ue }
lintLetBody :: [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv)
lintLetBody :: [Var] -> CoreExpr -> LintM (Type, UsageEnv)
lintLetBody [Var]
bndrs CoreExpr
body
= do { (Type
body_ty, UsageEnv
body_ue) <- LintLocInfo -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintLocInfo -> LintM a -> LintM a
addLoc ([Var] -> LintLocInfo
BodyOfLetRec [Var]
bndrs) (CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
body)
; (Var -> LintM ()) -> [Var] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Type -> Var -> LintM ()
lintJoinBndrType Type
body_ty) [Var]
bndrs
; (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
body_ty, UsageEnv
body_ue) }
lintLetBind :: TopLevelFlag -> RecFlag -> LintedId
-> CoreExpr -> LintedType -> LintM ()
lintLetBind :: TopLevelFlag -> RecFlag -> Var -> CoreExpr -> Type -> LintM ()
lintLetBind TopLevelFlag
top_lvl RecFlag
rec_flag Var
binder CoreExpr
rhs Type
rhs_ty
= do { let binder_ty :: Type
binder_ty = Var -> Type
idType Var
binder
; Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
binder_ty Type
rhs_ty (Var -> SDoc -> Type -> SDoc
mkRhsMsg Var
binder (String -> SDoc
text String
"RHS") Type
rhs_ty)
; Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not (Var -> Bool
isCoVar Var
binder) Bool -> Bool -> Bool
|| CoreExpr -> Bool
forall b. Expr b -> Bool
isCoArg CoreExpr
rhs)
(Var -> CoreExpr -> SDoc
mkLetErr Var
binder CoreExpr
rhs)
; Bool -> SDoc -> LintM ()
checkL ( Var -> Bool
isJoinId Var
binder
Bool -> Bool -> Bool
|| Type -> Bool
mightBeLiftedType Type
binder_ty
Bool -> Bool -> Bool
|| (RecFlag -> Bool
isNonRec RecFlag
rec_flag Bool -> Bool -> Bool
&& CoreExpr -> Bool
exprOkForSpeculation CoreExpr
rhs)
Bool -> Bool -> Bool
|| Var -> Bool
isDataConWorkId Var
binder Bool -> Bool -> Bool
|| Var -> Bool
isDataConWrapId Var
binder
Bool -> Bool -> Bool
|| CoreExpr -> Bool
exprIsTickedString CoreExpr
rhs)
(Var -> SDoc -> SDoc
badBndrTyMsg Var
binder (String -> SDoc
text String
"unlifted"))
; Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl Bool -> Bool -> Bool
&& Type
binder_ty Type -> Type -> Bool
`eqType` Type
addrPrimTy)
Bool -> Bool -> Bool
|| CoreExpr -> Bool
exprIsTickedString CoreExpr
rhs)
(Var -> SDoc
mkTopNonLitStrMsg Var
binder)
; LintFlags
flags <- LintM LintFlags
getLintFlags
; case Var -> Maybe Int
isJoinId_maybe Var
binder of
Maybe Int
Nothing -> () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Int
arity -> Bool -> SDoc -> LintM ()
checkL (Int -> Type -> Bool
isValidJoinPointType Int
arity Type
binder_ty)
(Var -> Type -> SDoc
mkInvalidJoinPointMsg Var
binder Type
binder_ty)
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LintFlags -> Bool
lf_check_inline_loop_breakers LintFlags
flags
Bool -> Bool -> Bool
&& Unfolding -> Bool
isStableUnfolding (Var -> Unfolding
realIdUnfolding Var
binder)
Bool -> Bool -> Bool
&& OccInfo -> Bool
isStrongLoopBreaker (Var -> OccInfo
idOccInfo Var
binder)
Bool -> Bool -> Bool
&& InlinePragma -> Bool
isInlinePragma (Var -> InlinePragma
idInlinePragma Var
binder))
(SDoc -> LintM ()
addWarnL (String -> SDoc
text String
"INLINE binder is (non-rule) loop breaker:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
binder))
; Bool -> SDoc -> LintM ()
checkL (Type -> [OneShotInfo]
typeArity (Var -> Type
idType Var
binder) [OneShotInfo] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` Var -> Int
idArity Var
binder)
(String -> SDoc
text String
"idArity" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Int
idArity Var
binder) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"exceeds typeArity" SDoc -> SDoc -> SDoc
<+>
Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([OneShotInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Type -> [OneShotInfo]
typeArity (Var -> Type
idType Var
binder))) SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+>
Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
binder)
; case DmdSig -> ([Demand], Divergence)
splitDmdSig (Var -> DmdSig
idDmdSig Var
binder) of
([Demand]
demands, Divergence
result_info) | Divergence -> Bool
isDeadEndDiv Divergence
result_info ->
Bool -> SDoc -> LintM ()
checkL ([Demand]
demands [Demand] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` Var -> Int
idArity Var
binder)
(String -> SDoc
text String
"idArity" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Int
idArity Var
binder) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"exceeds arity imposed by the strictness signature" SDoc -> SDoc -> SDoc
<+>
DmdSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> DmdSig
idDmdSig Var
binder) SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+>
Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
binder)
([Demand], Divergence)
_ -> () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
RuleOf Var
binder) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$ (CoreRule -> LintM ()) -> [CoreRule] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Var -> Type -> CoreRule -> LintM ()
lintCoreRule Var
binder Type
binder_ty) (Var -> [CoreRule]
idCoreRules Var
binder)
; LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
UnfoldingOf Var
binder) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
Var -> Type -> Unfolding -> LintM ()
lintIdUnfolding Var
binder Type
binder_ty (Var -> Unfolding
idUnfolding Var
binder)
; () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
lintRhs :: Id -> CoreExpr -> LintM (LintedType, UsageEnv)
lintRhs :: Var -> CoreExpr -> LintM (Type, UsageEnv)
lintRhs Var
bndr CoreExpr
rhs
| Just Int
arity <- Var -> Maybe Int
isJoinId_maybe Var
bndr
= Int -> Maybe Var -> CoreExpr -> LintM (Type, UsageEnv)
lintJoinLams Int
arity (Var -> Maybe Var
forall a. a -> Maybe a
Just Var
bndr) CoreExpr
rhs
| AlwaysTailCalled Int
arity <- OccInfo -> TailCallInfo
tailCallInfo (Var -> OccInfo
idOccInfo Var
bndr)
= Int -> Maybe Var -> CoreExpr -> LintM (Type, UsageEnv)
lintJoinLams Int
arity Maybe Var
forall a. Maybe a
Nothing CoreExpr
rhs
lintRhs Var
_bndr CoreExpr
rhs = (LintFlags -> StaticPtrCheck)
-> LintM LintFlags -> LintM StaticPtrCheck
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LintFlags -> StaticPtrCheck
lf_check_static_ptrs LintM LintFlags
getLintFlags LintM StaticPtrCheck
-> (StaticPtrCheck -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StaticPtrCheck -> LintM (Type, UsageEnv)
go
where
go :: StaticPtrCheck -> LintM (OutType, UsageEnv)
go :: StaticPtrCheck -> LintM (Type, UsageEnv)
go StaticPtrCheck
AllowAtTopLevel
| ([Var]
binders0, CoreExpr
rhs') <- CoreExpr -> ([Var], CoreExpr)
collectTyBinders CoreExpr
rhs
, Just (CoreExpr
fun, Type
t, CoreExpr
info, CoreExpr
e) <- CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
collectMakeStaticArgs CoreExpr
rhs'
= LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintM a -> LintM a
markAllJoinsBad (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$
(Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> [Var] -> LintM (Type, UsageEnv)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
lintLambda
(do (Type, UsageEnv)
fun_ty_ue <- CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
fun
(Type, UsageEnv) -> [CoreExpr] -> LintM (Type, UsageEnv)
lintCoreArgs (Type, UsageEnv)
fun_ty_ue [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
t, CoreExpr
info, CoreExpr
e]
)
[Var]
binders0
go StaticPtrCheck
_ = LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintM a -> LintM a
markAllJoinsBad (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
rhs
lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (LintedType, UsageEnv)
lintJoinLams :: Int -> Maybe Var -> CoreExpr -> LintM (Type, UsageEnv)
lintJoinLams Int
join_arity Maybe Var
enforce CoreExpr
rhs
= Int -> CoreExpr -> LintM (Type, UsageEnv)
go Int
join_arity CoreExpr
rhs
where
go :: Int -> CoreExpr -> LintM (Type, UsageEnv)
go Int
0 CoreExpr
expr = CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
expr
go Int
n (Lam Var
var CoreExpr
body) = Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
lintLambda Var
var (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ Int -> CoreExpr -> LintM (Type, UsageEnv)
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) CoreExpr
body
go Int
n CoreExpr
expr | Just Var
bndr <- Maybe Var
enforce
= SDoc -> LintM (Type, UsageEnv)
forall a. SDoc -> LintM a
failWithL (SDoc -> LintM (Type, UsageEnv)) -> SDoc -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ Var -> Int -> Int -> CoreExpr -> SDoc
mkBadJoinArityMsg Var
bndr Int
join_arity Int
n CoreExpr
rhs
| Bool
otherwise
= LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintM a -> LintM a
markAllJoinsBad (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
expr
lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
lintIdUnfolding :: Var -> Type -> Unfolding -> LintM ()
lintIdUnfolding Var
bndr Type
bndr_ty Unfolding
uf
| Unfolding -> Bool
isStableUnfolding Unfolding
uf
, Just CoreExpr
rhs <- Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate Unfolding
uf
= do { Type
ty <- (Type, UsageEnv) -> Type
forall a b. (a, b) -> a
fst ((Type, UsageEnv) -> Type) -> LintM (Type, UsageEnv) -> LintM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (if Unfolding -> Bool
isCompulsoryUnfolding Unfolding
uf
then LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintM a -> LintM a
noFixedRuntimeRepChecks (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ Var -> CoreExpr -> LintM (Type, UsageEnv)
lintRhs Var
bndr CoreExpr
rhs
else Var -> CoreExpr -> LintM (Type, UsageEnv)
lintRhs Var
bndr CoreExpr
rhs)
; Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
bndr_ty Type
ty (Var -> SDoc -> Type -> SDoc
mkRhsMsg Var
bndr (String -> SDoc
text String
"unfolding") Type
ty) }
lintIdUnfolding Var
_ Type
_ Unfolding
_
= () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
type LintedType = Type
type LintedKind = Kind
type LintedCoercion = Coercion
type LintedTyCoVar = TyCoVar
type LintedId = Id
lintCastExpr :: CoreExpr -> LintedType -> Coercion -> LintM LintedType
lintCastExpr :: CoreExpr -> Type -> Coercion -> LintM Type
lintCastExpr CoreExpr
expr Type
expr_ty Coercion
co
= do { Coercion
co' <- Coercion -> LintM Coercion
lintCoercion Coercion
co
; let (Pair Type
from_ty Type
to_ty, Role
role) = Coercion -> (Pair Type, Role)
coercionKindRole Coercion
co'
; Type -> SDoc -> LintM ()
checkValueType Type
to_ty (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"target of cast" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co')
; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
co' Role
Representational Role
role
; Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
from_ty Type
expr_ty (CoreExpr -> Coercion -> Type -> Type -> SDoc
mkCastErr CoreExpr
expr Coercion
co' Type
from_ty Type
expr_ty)
; Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
to_ty }
lintCoreExpr :: CoreExpr -> LintM (LintedType, UsageEnv)
lintCoreExpr :: CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr (Var Var
var)
= do
var_pair :: (Type, UsageEnv)
var_pair@(Type
var_ty, UsageEnv
_) <- Var -> Int -> LintM (Type, UsageEnv)
lintIdOcc Var
var Int
0
CoreExpr -> [CoreExpr] -> Type -> LintM ()
checkCanEtaExpand (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
var) [] Type
var_ty
(Type, UsageEnv) -> LintM (Type, UsageEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type, UsageEnv)
var_pair
lintCoreExpr (Lit Literal
lit)
= (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> Type
literalType Literal
lit, UsageEnv
zeroUE)
lintCoreExpr (Cast CoreExpr
expr Coercion
co)
= do (Type
expr_ty, UsageEnv
ue) <- LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintM a -> LintM a
markAllJoinsBad (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
expr
Type
to_ty <- CoreExpr -> Type -> Coercion -> LintM Type
lintCastExpr CoreExpr
expr Type
expr_ty Coercion
co
(Type, UsageEnv) -> LintM (Type, UsageEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
to_ty, UsageEnv
ue)
lintCoreExpr (Tick CoreTickish
tickish CoreExpr
expr)
= do case CoreTickish
tickish of
Breakpoint XBreakpoint 'TickishPassCore
_ Int
_ [XTickishId 'TickishPassCore]
ids -> [Var] -> (Var -> LintM (Var, Type)) -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Var]
[XTickishId 'TickishPassCore]
ids ((Var -> LintM (Var, Type)) -> LintM ())
-> (Var -> LintM (Var, Type)) -> LintM ()
forall a b. (a -> b) -> a -> b
$ \Var
id -> do
Var -> LintM ()
checkDeadIdOcc Var
id
Var -> LintM (Var, Type)
lookupIdInScope Var
id
CoreTickish
_ -> () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Bool -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. Bool -> LintM a -> LintM a
markAllJoinsBadIf Bool
block_joins (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
expr
where
block_joins :: Bool
block_joins = Bool -> Bool
not (CoreTickish
tickish CoreTickish -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope)
lintCoreExpr (Let (NonRec Var
tv (Type Type
ty)) CoreExpr
body)
| Var -> Bool
isTyVar Var
tv
=
do { Type
ty' <- Type -> LintM Type
lintType Type
ty
; Var -> (Var -> LintM (Type, UsageEnv)) -> LintM (Type, UsageEnv)
forall a. Var -> (Var -> LintM a) -> LintM a
lintTyBndr Var
tv ((Var -> LintM (Type, UsageEnv)) -> LintM (Type, UsageEnv))
-> (Var -> LintM (Type, UsageEnv)) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ \ Var
tv' ->
do { LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
RhsOf Var
tv) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$ Var -> Type -> LintM ()
lintTyKind Var
tv' Type
ty'
; Var -> Type -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. Var -> Type -> LintM a -> LintM a
extendTvSubstL Var
tv Type
ty' (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$
LintLocInfo -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintLocInfo -> LintM a -> LintM a
addLoc ([Var] -> LintLocInfo
BodyOfLetRec [Var
tv]) (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$
CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
body } }
lintCoreExpr (Let (NonRec Var
bndr CoreExpr
rhs) CoreExpr
body)
| Var -> Bool
isId Var
bndr
= do {
(Type
rhs_ty, UsageEnv
let_ue) <- Var -> CoreExpr -> LintM (Type, UsageEnv)
lintRhs Var
bndr CoreExpr
rhs
; BindingSite
-> Var -> (Var -> LintM (Type, UsageEnv)) -> LintM (Type, UsageEnv)
forall a. BindingSite -> Var -> (Var -> LintM a) -> LintM a
lintBinder BindingSite
LetBind Var
bndr ((Var -> LintM (Type, UsageEnv)) -> LintM (Type, UsageEnv))
-> (Var -> LintM (Type, UsageEnv)) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ \Var
bndr' ->
do { TopLevelFlag -> RecFlag -> Var -> CoreExpr -> Type -> LintM ()
lintLetBind TopLevelFlag
NotTopLevel RecFlag
NonRecursive Var
bndr' CoreExpr
rhs Type
rhs_ty
; Var -> UsageEnv -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. Var -> UsageEnv -> LintM a -> LintM a
addAliasUE Var
bndr UsageEnv
let_ue ([Var] -> CoreExpr -> LintM (Type, UsageEnv)
lintLetBody [Var
bndr'] CoreExpr
body) } }
| Bool
otherwise
= SDoc -> LintM (Type, UsageEnv)
forall a. SDoc -> LintM a
failWithL (Var -> CoreExpr -> SDoc
mkLetErr Var
bndr CoreExpr
rhs)
lintCoreExpr e :: CoreExpr
e@(Let (Rec [(Var, CoreExpr)]
pairs) CoreExpr
body)
= do {
Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not ([(Var, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var, CoreExpr)]
pairs)) (CoreExpr -> SDoc
emptyRec CoreExpr
e)
; let ([Var]
_, [NonEmpty Var]
dups) = (Var -> Var -> Ordering) -> [Var] -> ([Var], [NonEmpty Var])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups Var -> Var -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [Var]
bndrs
; Bool -> SDoc -> LintM ()
checkL ([NonEmpty Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NonEmpty Var]
dups) ([NonEmpty Var] -> SDoc
dupVars [NonEmpty Var]
dups)
; Bool -> SDoc -> LintM ()
checkL ((Var -> Bool) -> [Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Var -> Bool
isJoinId [Var]
bndrs Bool -> Bool -> Bool
|| (Var -> Bool) -> [Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (Var -> Bool) -> Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Bool
isJoinId) [Var]
bndrs) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
[Var] -> SDoc
mkInconsistentRecMsg [Var]
bndrs
; ((Type
body_type, UsageEnv
body_ue), [UsageEnv]
ues) <-
TopLevelFlag
-> [(Var, CoreExpr)]
-> ([Var] -> LintM (Type, UsageEnv))
-> LintM ((Type, UsageEnv), [UsageEnv])
forall a.
TopLevelFlag
-> [(Var, CoreExpr)] -> ([Var] -> LintM a) -> LintM (a, [UsageEnv])
lintRecBindings TopLevelFlag
NotTopLevel [(Var, CoreExpr)]
pairs (([Var] -> LintM (Type, UsageEnv))
-> LintM ((Type, UsageEnv), [UsageEnv]))
-> ([Var] -> LintM (Type, UsageEnv))
-> LintM ((Type, UsageEnv), [UsageEnv])
forall a b. (a -> b) -> a -> b
$ \ [Var]
bndrs' ->
[Var] -> CoreExpr -> LintM (Type, UsageEnv)
lintLetBody [Var]
bndrs' CoreExpr
body
; (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
body_type, UsageEnv
body_ue UsageEnv -> UsageEnv -> UsageEnv
`addUE` Type -> UsageEnv -> UsageEnv
scaleUE Type
Many ((UsageEnv -> UsageEnv -> UsageEnv) -> [UsageEnv] -> UsageEnv
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 UsageEnv -> UsageEnv -> UsageEnv
addUE [UsageEnv]
ues)) }
where
bndrs :: [Var]
bndrs = ((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
pairs
lintCoreExpr e :: CoreExpr
e@(App CoreExpr
_ CoreExpr
_)
| Var Var
fun <- CoreExpr
fun
, Var
fun Var -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
runRWKey
, CoreExpr
ty_arg1 : CoreExpr
ty_arg2 : CoreExpr
arg3 : [CoreExpr]
rest <- [CoreExpr]
args
= do { (Type, UsageEnv)
fun_pair1 <- (Type, UsageEnv) -> CoreExpr -> LintM (Type, UsageEnv)
lintCoreArg (Var -> Type
idType Var
fun, UsageEnv
zeroUE) CoreExpr
ty_arg1
; (Type
fun_ty2, UsageEnv
ue2) <- (Type, UsageEnv) -> CoreExpr -> LintM (Type, UsageEnv)
lintCoreArg (Type, UsageEnv)
fun_pair1 CoreExpr
ty_arg2
; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv)
lintRunRWCont :: CoreExpr -> LintM (Type, UsageEnv)
lintRunRWCont expr :: CoreExpr
expr@(Lam Var
_ CoreExpr
_) =
Int -> Maybe Var -> CoreExpr -> LintM (Type, UsageEnv)
lintJoinLams Int
1 (Var -> Maybe Var
forall a. a -> Maybe a
Just Var
fun) CoreExpr
expr
lintRunRWCont CoreExpr
other = LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintM a -> LintM a
markAllJoinsBad (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
other
; (Type
arg3_ty, UsageEnv
ue3) <- CoreExpr -> LintM (Type, UsageEnv)
lintRunRWCont CoreExpr
arg3
; (Type, UsageEnv)
app_ty <- CoreExpr
-> Type -> Type -> UsageEnv -> UsageEnv -> LintM (Type, UsageEnv)
lintValApp CoreExpr
arg3 Type
fun_ty2 Type
arg3_ty UsageEnv
ue2 UsageEnv
ue3
; (Type, UsageEnv) -> [CoreExpr] -> LintM (Type, UsageEnv)
lintCoreArgs (Type, UsageEnv)
app_ty [CoreExpr]
rest }
| Bool
otherwise
= do { (Type, UsageEnv)
fun_pair <- CoreExpr -> Int -> LintM (Type, UsageEnv)
lintCoreFun CoreExpr
fun ([CoreExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
args)
; app_pair :: (Type, UsageEnv)
app_pair@(Type
app_ty, UsageEnv
_) <- (Type, UsageEnv) -> [CoreExpr] -> LintM (Type, UsageEnv)
lintCoreArgs (Type, UsageEnv)
fun_pair [CoreExpr]
args
; CoreExpr -> [CoreExpr] -> Type -> LintM ()
checkCanEtaExpand CoreExpr
fun [CoreExpr]
args Type
app_ty
; (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type, UsageEnv)
app_pair}
where
(CoreExpr
fun, [CoreExpr]
args, [CoreTickish]
_source_ticks) = (CoreTickish -> Bool)
-> CoreExpr -> (CoreExpr, [CoreExpr], [CoreTickish])
forall b.
(CoreTickish -> Bool)
-> Expr b -> (Expr b, [Expr b], [CoreTickish])
collectArgsTicks CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreExpr
e
lintCoreExpr (Lam Var
var CoreExpr
expr)
= LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintM a -> LintM a
markAllJoinsBad (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$
Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
lintLambda Var
var (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
expr
lintCoreExpr (Case CoreExpr
scrut Var
var Type
alt_ty [Alt Var]
alts)
= CoreExpr -> Var -> Type -> [Alt Var] -> LintM (Type, UsageEnv)
lintCaseExpr CoreExpr
scrut Var
var Type
alt_ty [Alt Var]
alts
lintCoreExpr (Type Type
ty)
= SDoc -> LintM (Type, UsageEnv)
forall a. SDoc -> LintM a
failWithL (String -> SDoc
text String
"Type found as expression" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
lintCoreExpr (Coercion Coercion
co)
= do { Coercion
co' <- LintLocInfo -> LintM Coercion -> LintM Coercion
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Coercion -> LintLocInfo
InCo Coercion
co) (LintM Coercion -> LintM Coercion)
-> LintM Coercion -> LintM Coercion
forall a b. (a -> b) -> a -> b
$
Coercion -> LintM Coercion
lintCoercion Coercion
co
; (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Type
coercionType Coercion
co', UsageEnv
zeroUE) }
lintIdOcc :: Var -> Int
-> LintM (LintedType, UsageEnv)
lintIdOcc :: Var -> Int -> LintM (Type, UsageEnv)
lintIdOcc Var
var Int
nargs
= LintLocInfo -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
OccOf Var
var) (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$
do { Bool -> SDoc -> LintM ()
checkL (Var -> Bool
isNonCoVarId Var
var)
(String -> SDoc
text String
"Non term variable" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
var)
; (Var
bndr, Type
linted_bndr_ty) <- Var -> LintM (Var, Type)
lookupIdInScope Var
var
; let occ_ty :: Type
occ_ty = Var -> Type
idType Var
var
bndr_ty :: Type
bndr_ty = Var -> Type
idType Var
bndr
; Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
occ_ty Type
bndr_ty (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
Var -> Var -> Type -> Type -> SDoc
mkBndrOccTypeMismatchMsg Var
bndr Var
var Type
bndr_ty Type
occ_ty
; LintFlags
lf <- LintM LintFlags
getLintFlags
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nargs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
&& LintFlags -> StaticPtrCheck
lf_check_static_ptrs LintFlags
lf StaticPtrCheck -> StaticPtrCheck -> Bool
forall a. Eq a => a -> a -> Bool
/= StaticPtrCheck
AllowAnywhere) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> LintM ()
checkL (Var -> Name
idName Var
var Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
makeStaticName) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Found makeStatic nested in an expression"
; Var -> LintM ()
checkDeadIdOcc Var
var
; Var -> Int -> LintM ()
checkJoinOcc Var
var Int
nargs
; UsageEnv
usage <- Var -> LintM UsageEnv
varCallSiteUsage Var
var
; (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
linted_bndr_ty, UsageEnv
usage) }
lintCoreFun :: CoreExpr
-> Int
-> LintM (LintedType, UsageEnv)
lintCoreFun :: CoreExpr -> Int -> LintM (Type, UsageEnv)
lintCoreFun (Var Var
var) Int
nargs
= Var -> Int -> LintM (Type, UsageEnv)
lintIdOcc Var
var Int
nargs
lintCoreFun (Lam Var
var CoreExpr
body) Int
nargs
| Int
nargs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
= Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
lintLambda Var
var (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Int -> LintM (Type, UsageEnv)
lintCoreFun CoreExpr
body (Int
nargs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
lintCoreFun CoreExpr
expr Int
nargs
= Bool -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. Bool -> LintM a -> LintM a
markAllJoinsBadIf (Int
nargs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$
CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
expr
lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
lintLambda Var
var LintM (Type, UsageEnv)
lintBody =
LintLocInfo -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
LambdaBodyOf Var
var) (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$
BindingSite
-> Var -> (Var -> LintM (Type, UsageEnv)) -> LintM (Type, UsageEnv)
forall a. BindingSite -> Var -> (Var -> LintM a) -> LintM a
lintBinder BindingSite
LambdaBind Var
var ((Var -> LintM (Type, UsageEnv)) -> LintM (Type, UsageEnv))
-> (Var -> LintM (Type, UsageEnv)) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ \ Var
var' ->
do { (Type
body_ty, UsageEnv
ue) <- LintM (Type, UsageEnv)
lintBody
; UsageEnv
ue' <- UsageEnv -> Var -> LintM UsageEnv
checkLinearity UsageEnv
ue Var
var'
; (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Type -> Type
mkLamType Var
var' Type
body_ty, UsageEnv
ue') }
checkDeadIdOcc :: Id -> LintM ()
checkDeadIdOcc :: Var -> LintM ()
checkDeadIdOcc Var
id
| OccInfo -> Bool
isDeadOcc (Var -> OccInfo
idOccInfo Var
id)
= do { Bool
in_case <- LintM Bool
inCasePat
; Bool -> SDoc -> LintM ()
checkL Bool
in_case
(String -> SDoc
text String
"Occurrence of a dead Id" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
id) }
| Bool
otherwise
= () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lintJoinBndrType :: LintedType
-> LintedId
-> LintM ()
lintJoinBndrType :: Type -> Var -> LintM ()
lintJoinBndrType Type
body_ty Var
bndr
| Just Int
arity <- Var -> Maybe Int
isJoinId_maybe Var
bndr
, let bndr_ty :: Type
bndr_ty = Var -> Type
idType Var
bndr
, ([TyCoBinder]
bndrs, Type
res) <- Type -> ([TyCoBinder], Type)
splitPiTys Type
bndr_ty
= Bool -> SDoc -> LintM ()
checkL ([TyCoBinder] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyCoBinder]
bndrs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
arity
Bool -> Bool -> Bool
&& Type
body_ty Type -> Type -> Bool
`eqType` [TyCoBinder] -> Type -> Type
mkPiTys (Int -> [TyCoBinder] -> [TyCoBinder]
forall a. Int -> [a] -> [a]
drop Int
arity [TyCoBinder]
bndrs) Type
res) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Join point returns different type than body")
Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Join bndr:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
bndr SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
idType Var
bndr)
, String -> SDoc
text String
"Join arity:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
arity
, String -> SDoc
text String
"Body type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body_ty ])
| Bool
otherwise
= () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkJoinOcc :: Id -> JoinArity -> LintM ()
checkJoinOcc :: Var -> Int -> LintM ()
checkJoinOcc Var
var Int
n_args
| Just Int
join_arity_occ <- Var -> Maybe Int
isJoinId_maybe Var
var
= do { Maybe Int
mb_join_arity_bndr <- Var -> LintM (Maybe Int)
lookupJoinId Var
var
; case Maybe Int
mb_join_arity_bndr of {
Maybe Int
Nothing ->
do { VarSet
join_set <- LintM VarSet
getValidJoins
; SDoc -> LintM ()
addErrL (String -> SDoc
text String
"join set " SDoc -> SDoc -> SDoc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarSet
join_set SDoc -> SDoc -> SDoc
$$
Var -> SDoc
invalidJoinOcc Var
var) } ;
Just Int
join_arity_bndr ->
do { Bool -> SDoc -> LintM ()
checkL (Int
join_arity_bndr Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
join_arity_occ) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
Var -> Int -> Int -> SDoc
mkJoinBndrOccMismatchMsg Var
var Int
join_arity_bndr Int
join_arity_occ
; Bool -> SDoc -> LintM ()
checkL (Int
n_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
join_arity_occ) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
Var -> Int -> Int -> SDoc
mkBadJumpMsg Var
var Int
join_arity_occ Int
n_args } } }
| Bool
otherwise
= () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkCanEtaExpand :: CoreExpr
-> [CoreArg]
-> LintedType
-> LintM ()
checkCanEtaExpand :: CoreExpr -> [CoreExpr] -> Type -> LintM ()
checkCanEtaExpand (Var Var
fun_id) [CoreExpr]
args Type
app_ty
| Var -> Bool
hasNoBinding Var
fun_id
= Bool -> SDoc -> LintM ()
checkL ([Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
bad_arg_tys) SDoc
err_msg
where
arity :: Arity
arity :: Int
arity = Var -> Int
idArity Var
fun_id
nb_val_args :: Int
nb_val_args :: Int
nb_val_args = (CoreExpr -> Bool) -> [CoreExpr] -> Int
forall a. (a -> Bool) -> [a] -> Int
count CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg [CoreExpr]
args
check_args :: [Type] -> [Type]
check_args :: [Type] -> [Type]
check_args = Int -> [Type] -> [Type]
go (Int
nb_val_args Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
where
go :: Int
-> [Type]
-> [Type]
go :: Int -> [Type] -> [Type]
go Int
i [Type]
_
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
arity
= []
go Int
_ []
= String -> SDoc -> [Type]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"checkCanEtaExpand: arity larger than number of value arguments apparent in type"
(SDoc -> [Type]) -> SDoc -> [Type]
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"fun_id =" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
fun_id
, String -> SDoc
text String
"arity =" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
arity
, String -> SDoc
text String
"app_ty =" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
app_ty
, String -> SDoc
text String
"args = " SDoc -> SDoc -> SDoc
<+> [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args
, String -> SDoc
text String
"nb_val_args =" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
nb_val_args ]
go Int
i (Type
ty : [Type]
bndrs)
| Type -> Bool
typeHasFixedRuntimeRep Type
ty
= Int -> [Type] -> [Type]
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Type]
bndrs
| Bool
otherwise
= Type
ty Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Int -> [Type] -> [Type]
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Type]
bndrs
bad_arg_tys :: [Type]
bad_arg_tys :: [Type]
bad_arg_tys = [Type] -> [Type]
check_args ([Type] -> [Type])
-> ([(Type, AnonArgFlag)] -> [Type])
-> [(Type, AnonArgFlag)]
-> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Type, AnonArgFlag) -> Type) -> [(Type, AnonArgFlag)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type, AnonArgFlag) -> Type
forall a b. (a, b) -> a
fst ([(Type, AnonArgFlag)] -> [Type])
-> [(Type, AnonArgFlag)] -> [Type]
forall a b. (a -> b) -> a -> b
$ Type -> [(Type, AnonArgFlag)]
getRuntimeArgTys Type
app_ty
err_msg :: SDoc
err_msg :: SDoc
err_msg
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Cannot eta expand" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
fun_id)
, String -> SDoc
text String
"The following type" SDoc -> SDoc -> SDoc
<> [Type] -> SDoc
forall a. [a] -> SDoc
plural [Type]
bad_arg_tys
SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. [a] -> SDoc
doOrDoes [Type]
bad_arg_tys SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"not have a fixed runtime representation:"
, Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Type -> SDoc) -> [Type] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Type -> SDoc
ppr_ty_ki [Type]
bad_arg_tys ]
ppr_ty_ki :: Type -> SDoc
ppr_ty_ki :: Type -> SDoc
ppr_ty_ki Type
ty = SDoc
bullet SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty)
checkCanEtaExpand CoreExpr
_ [CoreExpr]
_ Type
_
= () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkLinearity :: UsageEnv -> Var -> LintM UsageEnv
checkLinearity :: UsageEnv -> Var -> LintM UsageEnv
checkLinearity UsageEnv
body_ue Var
lam_var =
case Var -> Maybe Type
varMultMaybe Var
lam_var of
Just Type
mult -> do Usage -> Type -> SDoc -> LintM ()
ensureSubUsage Usage
lhs Type
mult (Type -> SDoc
err_msg Type
mult)
UsageEnv -> LintM UsageEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (UsageEnv -> LintM UsageEnv) -> UsageEnv -> LintM UsageEnv
forall a b. (a -> b) -> a -> b
$ UsageEnv -> Var -> UsageEnv
forall n. NamedThing n => UsageEnv -> n -> UsageEnv
deleteUE UsageEnv
body_ue Var
lam_var
Maybe Type
Nothing -> UsageEnv -> LintM UsageEnv
forall (m :: * -> *) a. Monad m => a -> m a
return UsageEnv
body_ue
where
lhs :: Usage
lhs = UsageEnv -> Var -> Usage
forall n. NamedThing n => UsageEnv -> n -> Usage
lookupUE UsageEnv
body_ue Var
lam_var
err_msg :: Type -> SDoc
err_msg Type
mult = String -> SDoc
text String
"Linearity failure in lambda:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
lam_var
SDoc -> SDoc -> SDoc
$$ Usage -> SDoc
forall a. Outputable a => a -> SDoc
ppr Usage
lhs SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"⊈" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
mult
lintCoreArgs :: (LintedType, UsageEnv) -> [CoreArg] -> LintM (LintedType, UsageEnv)
lintCoreArgs :: (Type, UsageEnv) -> [CoreExpr] -> LintM (Type, UsageEnv)
lintCoreArgs (Type
fun_ty, UsageEnv
fun_ue) [CoreExpr]
args = ((Type, UsageEnv) -> CoreExpr -> LintM (Type, UsageEnv))
-> (Type, UsageEnv) -> [CoreExpr] -> LintM (Type, UsageEnv)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Type, UsageEnv) -> CoreExpr -> LintM (Type, UsageEnv)
lintCoreArg (Type
fun_ty, UsageEnv
fun_ue) [CoreExpr]
args
lintCoreArg :: (LintedType, UsageEnv) -> CoreArg -> LintM (LintedType, UsageEnv)
lintCoreArg :: (Type, UsageEnv) -> CoreExpr -> LintM (Type, UsageEnv)
lintCoreArg (Type
fun_ty, UsageEnv
ue) (Type Type
arg_ty)
= do { Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not (Type -> Bool
isCoercionTy Type
arg_ty))
(String -> SDoc
text String
"Unnecessary coercion-to-type injection:"
SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty)
; Type
arg_ty' <- Type -> LintM Type
lintType Type
arg_ty
; Type
res <- Type -> Type -> LintM Type
lintTyApp Type
fun_ty Type
arg_ty'
; (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
res, UsageEnv
ue) }
lintCoreArg (Type
fun_ty, UsageEnv
fun_ue) CoreExpr
arg
= do { (Type
arg_ty, UsageEnv
arg_ue) <- LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintM a -> LintM a
markAllJoinsBad (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
arg
; LintFlags
flags <- LintM LintFlags
getLintFlags
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LintFlags -> Bool
lf_check_fixed_rep LintFlags
flags) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
do { Bool -> SDoc -> LintM ()
checkL (Type -> Bool
typeHasFixedRuntimeRep Type
arg_ty)
(String -> SDoc
text String
"Argument does not have a fixed runtime representation"
SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
arg SDoc -> SDoc -> SDoc
<+> SDoc
dcolon
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
arg_ty))) }
; CoreExpr
-> Type -> Type -> UsageEnv -> UsageEnv -> LintM (Type, UsageEnv)
lintValApp CoreExpr
arg Type
fun_ty Type
arg_ty UsageEnv
fun_ue UsageEnv
arg_ue }
lintAltBinders :: UsageEnv
-> Var
-> LintedType
-> LintedType
-> [(Mult, OutVar)]
-> LintM UsageEnv
lintAltBinders :: UsageEnv -> Var -> Type -> Type -> [(Type, Var)] -> LintM UsageEnv
lintAltBinders UsageEnv
rhs_ue Var
_case_bndr Type
scrut_ty Type
con_ty []
= do { Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
con_ty Type
scrut_ty (Type -> Type -> SDoc
mkBadPatMsg Type
con_ty Type
scrut_ty)
; UsageEnv -> LintM UsageEnv
forall (m :: * -> *) a. Monad m => a -> m a
return UsageEnv
rhs_ue }
lintAltBinders UsageEnv
rhs_ue Var
case_bndr Type
scrut_ty Type
con_ty ((Type
var_w, Var
bndr):[(Type, Var)]
bndrs)
| Var -> Bool
isTyVar Var
bndr
= do { Type
con_ty' <- Type -> Type -> LintM Type
lintTyApp Type
con_ty (Var -> Type
mkTyVarTy Var
bndr)
; UsageEnv -> Var -> Type -> Type -> [(Type, Var)] -> LintM UsageEnv
lintAltBinders UsageEnv
rhs_ue Var
case_bndr Type
scrut_ty Type
con_ty' [(Type, Var)]
bndrs }
| Bool
otherwise
= do { (Type
con_ty', UsageEnv
_) <- CoreExpr
-> Type -> Type -> UsageEnv -> UsageEnv -> LintM (Type, UsageEnv)
lintValApp (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
bndr) Type
con_ty (Var -> Type
idType Var
bndr) UsageEnv
zeroUE UsageEnv
zeroUE
; UsageEnv
rhs_ue' <- UsageEnv -> Var -> Type -> Var -> LintM UsageEnv
checkCaseLinearity UsageEnv
rhs_ue Var
case_bndr Type
var_w Var
bndr
; UsageEnv -> Var -> Type -> Type -> [(Type, Var)] -> LintM UsageEnv
lintAltBinders UsageEnv
rhs_ue' Var
case_bndr Type
scrut_ty Type
con_ty' [(Type, Var)]
bndrs }
checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv
checkCaseLinearity :: UsageEnv -> Var -> Type -> Var -> LintM UsageEnv
checkCaseLinearity UsageEnv
ue Var
case_bndr Type
var_w Var
bndr = do
Usage -> Type -> SDoc -> LintM ()
ensureSubUsage Usage
lhs Type
rhs SDoc
err_msg
SDoc -> Type -> Type -> LintM ()
lintLinearBinder (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
bndr) (Type
case_bndr_w Type -> Type -> Type
`mkMultMul` Type
var_w) (Var -> Type
varMult Var
bndr)
UsageEnv -> LintM UsageEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (UsageEnv -> LintM UsageEnv) -> UsageEnv -> LintM UsageEnv
forall a b. (a -> b) -> a -> b
$ UsageEnv -> Var -> UsageEnv
forall n. NamedThing n => UsageEnv -> n -> UsageEnv
deleteUE UsageEnv
ue Var
bndr
where
lhs :: Usage
lhs = Usage
bndr_usage Usage -> Usage -> Usage
`addUsage` (Type
var_w Type -> Usage -> Usage
`scaleUsage` Usage
case_bndr_usage)
rhs :: Type
rhs = Type
case_bndr_w Type -> Type -> Type
`mkMultMul` Type
var_w
err_msg :: SDoc
err_msg = (String -> SDoc
text String
"Linearity failure in variable:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
bndr
SDoc -> SDoc -> SDoc
$$ Usage -> SDoc
forall a. Outputable a => a -> SDoc
ppr Usage
lhs SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"⊈" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Computed by:"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"LHS:" SDoc -> SDoc -> SDoc
<+> SDoc
lhs_formula
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"RHS:" SDoc -> SDoc -> SDoc
<+> SDoc
rhs_formula)
lhs_formula :: SDoc
lhs_formula = Usage -> SDoc
forall a. Outputable a => a -> SDoc
ppr Usage
bndr_usage SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"+"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (Usage -> SDoc
forall a. Outputable a => a -> SDoc
ppr Usage
case_bndr_usage SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"*" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
var_w)
rhs_formula :: SDoc
rhs_formula = Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
case_bndr_w SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"*" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
var_w
case_bndr_w :: Type
case_bndr_w = Var -> Type
varMult Var
case_bndr
case_bndr_usage :: Usage
case_bndr_usage = UsageEnv -> Var -> Usage
forall n. NamedThing n => UsageEnv -> n -> Usage
lookupUE UsageEnv
ue Var
case_bndr
bndr_usage :: Usage
bndr_usage = UsageEnv -> Var -> Usage
forall n. NamedThing n => UsageEnv -> n -> Usage
lookupUE UsageEnv
ue Var
bndr
lintTyApp :: LintedType -> LintedType -> LintM LintedType
lintTyApp :: Type -> Type -> LintM Type
lintTyApp Type
fun_ty Type
arg_ty
| Just (Var
tv,Type
body_ty) <- Type -> Maybe (Var, Type)
splitForAllTyCoVar_maybe Type
fun_ty
= do { Var -> Type -> LintM ()
lintTyKind Var
tv Type
arg_ty
; InScopeSet
in_scope <- LintM InScopeSet
getInScope
; Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (InScopeSet -> [Var] -> [Type] -> Type -> Type
substTyWithInScope InScopeSet
in_scope [Var
tv] [Type
arg_ty] Type
body_ty) }
| Bool
otherwise
= SDoc -> LintM Type
forall a. SDoc -> LintM a
failWithL (Type -> Type -> SDoc
mkTyAppMsg Type
fun_ty Type
arg_ty)
lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv -> LintM (LintedType, UsageEnv)
lintValApp :: CoreExpr
-> Type -> Type -> UsageEnv -> UsageEnv -> LintM (Type, UsageEnv)
lintValApp CoreExpr
arg Type
fun_ty Type
arg_ty UsageEnv
fun_ue UsageEnv
arg_ue
| Just (Type
w, Type
arg_ty', Type
res_ty') <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
fun_ty
= do { Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
arg_ty' Type
arg_ty (Type -> Type -> CoreExpr -> SDoc
mkAppMsg Type
arg_ty' Type
arg_ty CoreExpr
arg)
; let app_ue :: UsageEnv
app_ue = UsageEnv -> UsageEnv -> UsageEnv
addUE UsageEnv
fun_ue (Type -> UsageEnv -> UsageEnv
scaleUE Type
w UsageEnv
arg_ue)
; (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
res_ty', UsageEnv
app_ue) }
| Bool
otherwise
= SDoc -> LintM (Type, UsageEnv)
forall a. SDoc -> LintM a
failWithL SDoc
err2
where
err2 :: SDoc
err2 = Type -> Type -> CoreExpr -> SDoc
mkNonFunAppMsg Type
fun_ty Type
arg_ty CoreExpr
arg
lintTyKind :: OutTyVar -> LintedType -> LintM ()
lintTyKind :: Var -> Type -> LintM ()
lintTyKind Var
tyvar Type
arg_ty
= Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type
arg_kind Type -> Type -> Bool
`eqType` Type
tyvar_kind) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> LintM ()
addErrL (Var -> Type -> SDoc
mkKindErrMsg Var
tyvar Type
arg_ty SDoc -> SDoc -> SDoc
$$ (String -> SDoc
text String
"Linted Arg kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_kind))
where
tyvar_kind :: Type
tyvar_kind = Var -> Type
tyVarKind Var
tyvar
arg_kind :: Type
arg_kind = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
arg_ty
lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM (LintedType, UsageEnv)
lintCaseExpr :: CoreExpr -> Var -> Type -> [Alt Var] -> LintM (Type, UsageEnv)
lintCaseExpr CoreExpr
scrut Var
var Type
alt_ty [Alt Var]
alts =
do { let e :: CoreExpr
e = CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut Var
var Type
alt_ty [Alt Var]
alts
; (Type
scrut_ty, UsageEnv
scrut_ue) <- LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintM a -> LintM a
markAllJoinsBad (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
scrut
; let scrut_mult :: Type
scrut_mult = Var -> Type
varMult Var
var
; Type
alt_ty <- LintLocInfo -> LintM Type -> LintM Type
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (CoreExpr -> LintLocInfo
CaseTy CoreExpr
scrut) (LintM Type -> LintM Type) -> LintM Type -> LintM Type
forall a b. (a -> b) -> a -> b
$
Type -> LintM Type
lintValueType Type
alt_ty
; Type
var_ty <- LintLocInfo -> LintM Type -> LintM Type
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
IdTy Var
var) (LintM Type -> LintM Type) -> LintM Type -> LintM Type
forall a b. (a -> b) -> a -> b
$
Type -> LintM Type
lintValueType (Var -> Type
idType Var
var)
; let isLitPat :: Alt b -> Bool
isLitPat (Alt (LitAlt Literal
_) [b]
_ Expr b
_) = Bool
True
isLitPat Alt b
_ = Bool
False
; Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Bool
isFloatingPrimTy Type
scrut_ty Bool -> Bool -> Bool
&& (Alt Var -> Bool) -> [Alt Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Alt Var -> Bool
forall b. Alt b -> Bool
isLitPat [Alt Var]
alts)
(String -> SDoc
text String
"Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)."
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"scrut" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
scrut)
; case Type -> Maybe TyCon
tyConAppTyCon_maybe (Var -> Type
idType Var
var) of
Just TyCon
tycon
| Bool
debugIsOn
, TyCon -> Bool
isAlgTyCon TyCon
tycon
, Bool -> Bool
not (TyCon -> Bool
isAbstractTyCon TyCon
tycon)
, [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TyCon -> [DataCon]
tyConDataCons TyCon
tycon)
, Bool -> Bool
not (CoreExpr -> Bool
exprIsDeadEnd CoreExpr
scrut)
-> String -> SDoc -> LintM () -> LintM ()
forall a. String -> SDoc -> a -> a
pprTrace String
"Lint warning: case binder's type has no constructors" (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
var SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
idType Var
var))
(LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$ () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe TyCon
_otherwise -> () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; TCvSubst
subst <- LintM TCvSubst
getTCvSubst
; Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
var_ty Type
scrut_ty (Var -> Type -> Type -> TCvSubst -> SDoc
mkScrutMsg Var
var Type
var_ty Type
scrut_ty TCvSubst
subst)
; BindingSite
-> Var -> (Var -> LintM (Type, UsageEnv)) -> LintM (Type, UsageEnv)
forall a. BindingSite -> Var -> (Var -> LintM a) -> LintM a
lintBinder BindingSite
CaseBind Var
var ((Var -> LintM (Type, UsageEnv)) -> LintM (Type, UsageEnv))
-> (Var -> LintM (Type, UsageEnv)) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ \Var
_ ->
do {
; [UsageEnv]
alt_ues <- (Alt Var -> LintM UsageEnv) -> [Alt Var] -> LintM [UsageEnv]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Var -> Type -> Type -> Type -> Alt Var -> LintM UsageEnv
lintCoreAlt Var
var Type
scrut_ty Type
scrut_mult Type
alt_ty) [Alt Var]
alts
; let case_ue :: UsageEnv
case_ue = (Type -> UsageEnv -> UsageEnv
scaleUE Type
scrut_mult UsageEnv
scrut_ue) UsageEnv -> UsageEnv -> UsageEnv
`addUE` [UsageEnv] -> UsageEnv
supUEs [UsageEnv]
alt_ues
; CoreExpr -> Type -> [Alt Var] -> LintM ()
checkCaseAlts CoreExpr
e Type
scrut_ty [Alt Var]
alts
; (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
alt_ty, UsageEnv
case_ue) } }
checkCaseAlts :: CoreExpr -> LintedType -> [CoreAlt] -> LintM ()
checkCaseAlts :: CoreExpr -> Type -> [Alt Var] -> LintM ()
checkCaseAlts CoreExpr
e Type
ty [Alt Var]
alts =
do { Bool -> SDoc -> LintM ()
checkL ((Alt Var -> Bool) -> [Alt Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Alt Var -> Bool
forall b. Alt b -> Bool
non_deflt [Alt Var]
con_alts) (CoreExpr -> SDoc
mkNonDefltMsg CoreExpr
e)
; Bool -> SDoc -> LintM ()
checkL ([Alt Var] -> Bool
forall a. [Alt a] -> Bool
increasing_tag [Alt Var]
con_alts) (CoreExpr -> SDoc
mkNonIncreasingAltsMsg CoreExpr
e)
; Bool -> SDoc -> LintM ()
checkL (Maybe CoreExpr -> Bool
forall a. Maybe a -> Bool
isJust Maybe CoreExpr
maybe_deflt Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
is_infinite_ty Bool -> Bool -> Bool
|| [Alt Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Var]
alts)
(CoreExpr -> SDoc
nonExhaustiveAltsMsg CoreExpr
e) }
where
([Alt Var]
con_alts, Maybe CoreExpr
maybe_deflt) = [Alt Var] -> ([Alt Var], Maybe CoreExpr)
forall b. [Alt b] -> ([Alt b], Maybe (Expr b))
findDefault [Alt Var]
alts
increasing_tag :: [Alt a] -> Bool
increasing_tag (Alt a
alt1 : rest :: [Alt a]
rest@( Alt a
alt2 : [Alt a]
_)) = Alt a
alt1 Alt a -> Alt a -> Bool
forall a. Alt a -> Alt a -> Bool
`ltAlt` Alt a
alt2 Bool -> Bool -> Bool
&& [Alt a] -> Bool
increasing_tag [Alt a]
rest
increasing_tag [Alt a]
_ = Bool
True
non_deflt :: Alt b -> Bool
non_deflt (Alt AltCon
DEFAULT [b]
_ Expr b
_) = Bool
False
non_deflt Alt b
_ = Bool
True
is_infinite_ty :: Bool
is_infinite_ty = case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty of
Maybe TyCon
Nothing -> Bool
False
Just TyCon
tycon -> TyCon -> Bool
isPrimTyCon TyCon
tycon
lintAltExpr :: CoreExpr -> LintedType -> LintM UsageEnv
lintAltExpr :: CoreExpr -> Type -> LintM UsageEnv
lintAltExpr CoreExpr
expr Type
ann_ty
= do { (Type
actual_ty, UsageEnv
ue) <- CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
expr
; Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
actual_ty Type
ann_ty (CoreExpr -> Type -> Type -> SDoc
mkCaseAltMsg CoreExpr
expr Type
actual_ty Type
ann_ty)
; UsageEnv -> LintM UsageEnv
forall (m :: * -> *) a. Monad m => a -> m a
return UsageEnv
ue }
lintCoreAlt :: Var
-> LintedType
-> Mult
-> LintedType
-> CoreAlt
-> LintM UsageEnv
lintCoreAlt :: Var -> Type -> Type -> Type -> Alt Var -> LintM UsageEnv
lintCoreAlt Var
_ Type
_ Type
_ Type
alt_ty (Alt AltCon
DEFAULT [Var]
args CoreExpr
rhs) =
do { Bool -> SDoc -> LintM ()
lintL ([Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
args) ([Var] -> SDoc
mkDefaultArgsMsg [Var]
args)
; CoreExpr -> Type -> LintM UsageEnv
lintAltExpr CoreExpr
rhs Type
alt_ty }
lintCoreAlt Var
_case_bndr Type
scrut_ty Type
_ Type
alt_ty (Alt (LitAlt Literal
lit) [Var]
args CoreExpr
rhs)
| Literal -> Bool
litIsLifted Literal
lit
= SDoc -> LintM UsageEnv
forall a. SDoc -> LintM a
failWithL SDoc
integerScrutinisedMsg
| Bool
otherwise
= do { Bool -> SDoc -> LintM ()
lintL ([Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
args) ([Var] -> SDoc
mkDefaultArgsMsg [Var]
args)
; Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
lit_ty Type
scrut_ty (Type -> Type -> SDoc
mkBadPatMsg Type
lit_ty Type
scrut_ty)
; CoreExpr -> Type -> LintM UsageEnv
lintAltExpr CoreExpr
rhs Type
alt_ty }
where
lit_ty :: Type
lit_ty = Literal -> Type
literalType Literal
lit
lintCoreAlt Var
case_bndr Type
scrut_ty Type
_scrut_mult Type
alt_ty alt :: Alt Var
alt@(Alt (DataAlt DataCon
con) [Var]
args CoreExpr
rhs)
| TyCon -> Bool
isNewTyCon (DataCon -> TyCon
dataConTyCon DataCon
con)
= UsageEnv
zeroUE UsageEnv -> LintM () -> LintM UsageEnv
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SDoc -> LintM ()
addErrL (Type -> Alt Var -> SDoc
mkNewTyDataConAltMsg Type
scrut_ty Alt Var
alt)
| Just (TyCon
tycon, [Type]
tycon_arg_tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
scrut_ty
= LintLocInfo -> LintM UsageEnv -> LintM UsageEnv
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Alt Var -> LintLocInfo
CaseAlt Alt Var
alt) (LintM UsageEnv -> LintM UsageEnv)
-> LintM UsageEnv -> LintM UsageEnv
forall a b. (a -> b) -> a -> b
$ do
{
Bool -> SDoc -> LintM ()
lintL (TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> TyCon
dataConTyCon DataCon
con) (TyCon -> DataCon -> SDoc
mkBadConMsg TyCon
tycon DataCon
con)
; let { con_payload_ty :: Type
con_payload_ty = HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys (DataCon -> Type
dataConRepType DataCon
con) [Type]
tycon_arg_tys
; binderMult :: TyCoBinder -> Type
binderMult (Named TyCoVarBinder
_) = Type
Many
; binderMult (Anon AnonArgFlag
_ Scaled Type
st) = Scaled Type -> Type
forall a. Scaled a -> Type
scaledMult Scaled Type
st
; multiplicities :: [Type]
multiplicities = (TyCoBinder -> Type) -> [TyCoBinder] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyCoBinder -> Type
binderMult ([TyCoBinder] -> [Type]) -> [TyCoBinder] -> [Type]
forall a b. (a -> b) -> a -> b
$ ([TyCoBinder], Type) -> [TyCoBinder]
forall a b. (a, b) -> a
fst (([TyCoBinder], Type) -> [TyCoBinder])
-> ([TyCoBinder], Type) -> [TyCoBinder]
forall a b. (a -> b) -> a -> b
$ Type -> ([TyCoBinder], Type)
splitPiTys Type
con_payload_ty }
; BindingSite -> [Var] -> ([Var] -> LintM UsageEnv) -> LintM UsageEnv
forall a. BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
lintBinders BindingSite
CasePatBind [Var]
args (([Var] -> LintM UsageEnv) -> LintM UsageEnv)
-> ([Var] -> LintM UsageEnv) -> LintM UsageEnv
forall a b. (a -> b) -> a -> b
$ \ [Var]
args' -> do
{
UsageEnv
rhs_ue <- CoreExpr -> Type -> LintM UsageEnv
lintAltExpr CoreExpr
rhs Type
alt_ty
; UsageEnv
rhs_ue' <- LintLocInfo -> LintM UsageEnv -> LintM UsageEnv
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Alt Var -> LintLocInfo
CasePat Alt Var
alt) (UsageEnv -> Var -> Type -> Type -> [(Type, Var)] -> LintM UsageEnv
lintAltBinders UsageEnv
rhs_ue Var
case_bndr Type
scrut_ty Type
con_payload_ty (String -> [Type] -> [Var] -> [(Type, Var)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"lintCoreAlt" [Type]
multiplicities [Var]
args'))
; UsageEnv -> LintM UsageEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (UsageEnv -> LintM UsageEnv) -> UsageEnv -> LintM UsageEnv
forall a b. (a -> b) -> a -> b
$ UsageEnv -> Var -> UsageEnv
forall n. NamedThing n => UsageEnv -> n -> UsageEnv
deleteUE UsageEnv
rhs_ue' Var
case_bndr
}
}
| Bool
otherwise
= UsageEnv
zeroUE UsageEnv -> LintM () -> LintM UsageEnv
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SDoc -> LintM ()
addErrL (Type -> Alt Var -> SDoc
mkBadAltMsg Type
scrut_ty Alt Var
alt)
lintLinearBinder :: SDoc -> Mult -> Mult -> LintM ()
lintLinearBinder :: SDoc -> Type -> Type -> LintM ()
lintLinearBinder SDoc
doc Type
actual_usage Type
described_usage
= Type -> Type -> SDoc -> LintM ()
ensureSubMult Type
actual_usage Type
described_usage SDoc
err_msg
where
err_msg :: SDoc
err_msg = (String -> SDoc
text String
"Multiplicity of variable does not agree with its context"
SDoc -> SDoc -> SDoc
$$ SDoc
doc
SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
actual_usage
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Annotation:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
described_usage)
lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
lintBinders BindingSite
_ [] [Var] -> LintM a
linterF = [Var] -> LintM a
linterF []
lintBinders BindingSite
site (Var
var:[Var]
vars) [Var] -> LintM a
linterF = BindingSite -> Var -> (Var -> LintM a) -> LintM a
forall a. BindingSite -> Var -> (Var -> LintM a) -> LintM a
lintBinder BindingSite
site Var
var ((Var -> LintM a) -> LintM a) -> (Var -> LintM a) -> LintM a
forall a b. (a -> b) -> a -> b
$ \Var
var' ->
BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
forall a. BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
lintBinders BindingSite
site [Var]
vars (([Var] -> LintM a) -> LintM a) -> ([Var] -> LintM a) -> LintM a
forall a b. (a -> b) -> a -> b
$ \ [Var]
vars' ->
[Var] -> LintM a
linterF (Var
var'Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
vars')
lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a
lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a
lintBinder BindingSite
site Var
var Var -> LintM a
linterF
| Var -> Bool
isTyCoVar Var
var = Var -> (Var -> LintM a) -> LintM a
forall a. Var -> (Var -> LintM a) -> LintM a
lintTyCoBndr Var
var Var -> LintM a
linterF
| Bool
otherwise = TopLevelFlag -> BindingSite -> Var -> (Var -> LintM a) -> LintM a
forall a.
TopLevelFlag -> BindingSite -> Var -> (Var -> LintM a) -> LintM a
lintIdBndr TopLevelFlag
NotTopLevel BindingSite
site Var
var Var -> LintM a
linterF
lintTyBndr :: TyVar -> (LintedTyCoVar -> LintM a) -> LintM a
lintTyBndr :: Var -> (Var -> LintM a) -> LintM a
lintTyBndr = Var -> (Var -> LintM a) -> LintM a
forall a. Var -> (Var -> LintM a) -> LintM a
lintTyCoBndr
lintTyCoBndr :: TyCoVar -> (LintedTyCoVar -> LintM a) -> LintM a
lintTyCoBndr :: Var -> (Var -> LintM a) -> LintM a
lintTyCoBndr Var
tcv Var -> LintM a
thing_inside
= do { TCvSubst
subst <- LintM TCvSubst
getTCvSubst
; Type
kind' <- Type -> LintM Type
lintType (Var -> Type
varType Var
tcv)
; let tcv' :: Var
tcv' = InScopeSet -> Var -> Var
uniqAway (TCvSubst -> InScopeSet
getTCvInScope TCvSubst
subst) (Var -> Var) -> Var -> Var
forall a b. (a -> b) -> a -> b
$
Var -> Type -> Var
setVarType Var
tcv Type
kind'
subst' :: TCvSubst
subst' = TCvSubst -> Var -> Var -> TCvSubst
extendTCvSubstWithClone TCvSubst
subst Var
tcv Var
tcv'
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Var -> Bool
isCoVar Var
tcv) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> LintM ()
lintL (Type -> Bool
isCoVarType Type
kind')
(String -> SDoc
text String
"CoVar with non-coercion type:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
pprTyVar Var
tcv)
; TCvSubst -> LintM a -> LintM a
forall a. TCvSubst -> LintM a -> LintM a
updateTCvSubst TCvSubst
subst' (Var -> LintM a
thing_inside Var
tcv') }
lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> ([LintedId] -> LintM a) -> LintM a
lintIdBndrs :: TopLevelFlag -> [Var] -> ([Var] -> LintM a) -> LintM a
lintIdBndrs TopLevelFlag
top_lvl [Var]
ids [Var] -> LintM a
thing_inside
= [Var] -> ([Var] -> LintM a) -> LintM a
go [Var]
ids [Var] -> LintM a
thing_inside
where
go :: [Id] -> ([Id] -> LintM a) -> LintM a
go :: [Var] -> ([Var] -> LintM a) -> LintM a
go [] [Var] -> LintM a
thing_inside = [Var] -> LintM a
thing_inside []
go (Var
id:[Var]
ids) [Var] -> LintM a
thing_inside = TopLevelFlag -> BindingSite -> Var -> (Var -> LintM a) -> LintM a
forall a.
TopLevelFlag -> BindingSite -> Var -> (Var -> LintM a) -> LintM a
lintIdBndr TopLevelFlag
top_lvl BindingSite
LetBind Var
id ((Var -> LintM a) -> LintM a) -> (Var -> LintM a) -> LintM a
forall a b. (a -> b) -> a -> b
$ \Var
id' ->
[Var] -> ([Var] -> LintM a) -> LintM a
go [Var]
ids (([Var] -> LintM a) -> LintM a) -> ([Var] -> LintM a) -> LintM a
forall a b. (a -> b) -> a -> b
$ \[Var]
ids' ->
[Var] -> LintM a
thing_inside (Var
id' Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
ids')
lintIdBndr :: TopLevelFlag -> BindingSite
-> InVar -> (OutVar -> LintM a) -> LintM a
lintIdBndr :: TopLevelFlag -> BindingSite -> Var -> (Var -> LintM a) -> LintM a
lintIdBndr TopLevelFlag
top_lvl BindingSite
bind_site Var
id Var -> LintM a
thing_inside
= Bool -> SDoc -> LintM a -> LintM a
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Var -> Bool
isId Var
id) (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
id) (LintM a -> LintM a) -> LintM a -> LintM a
forall a b. (a -> b) -> a -> b
$
do { LintFlags
flags <- LintM LintFlags
getLintFlags
; Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not (LintFlags -> Bool
lf_check_global_ids LintFlags
flags) Bool -> Bool -> Bool
|| Var -> Bool
isLocalId Var
id)
(String -> SDoc
text String
"Non-local Id binder" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
id)
; Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not (Var -> Bool
isExportedId Var
id) Bool -> Bool -> Bool
|| Bool
is_top_lvl)
(Var -> SDoc
mkNonTopExportedMsg Var
id)
; Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not (Name -> Bool
isExternalName (Var -> Name
Var.varName Var
id)) Bool -> Bool -> Bool
|| Bool
is_top_lvl)
(Var -> SDoc
mkNonTopExternalNameMsg Var
id)
; Bool -> SDoc -> LintM ()
lintL (Var -> Bool
isJoinId Var
id Bool -> Bool -> Bool
|| Bool -> Bool
not (LintFlags -> Bool
lf_check_fixed_rep LintFlags
flags)
Bool -> Bool -> Bool
|| Type -> Bool
typeHasFixedRuntimeRep Type
id_ty) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Binder does not have a fixed runtime representation:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
parens (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
id_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
id_ty))
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Var -> Bool
isJoinId Var
id) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not Bool
is_top_lvl Bool -> Bool -> Bool
&& Bool
is_let_bind) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
Var -> SDoc
mkBadJoinBindMsg Var
id
; Bool -> SDoc -> LintM ()
lintL (Bool -> Bool
not (Type -> Bool
isCoVarType Type
id_ty))
(String -> SDoc
text String
"Non-CoVar has coercion type" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
id_ty)
; Type
linted_ty <- LintLocInfo -> LintM Type -> LintM Type
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Var -> LintLocInfo
IdTy Var
id) (Type -> LintM Type
lintValueType Type
id_ty)
; Var -> Type -> LintM a -> LintM a
forall a. Var -> Type -> LintM a -> LintM a
addInScopeId Var
id Type
linted_ty (LintM a -> LintM a) -> LintM a -> LintM a
forall a b. (a -> b) -> a -> b
$
Var -> LintM a
thing_inside (Var -> Type -> Var
setIdType Var
id Type
linted_ty) }
where
id_ty :: Type
id_ty = Var -> Type
idType Var
id
is_top_lvl :: Bool
is_top_lvl = TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
is_let_bind :: Bool
is_let_bind = case BindingSite
bind_site of
BindingSite
LetBind -> Bool
True
BindingSite
_ -> Bool
False
lintValueType :: Type -> LintM LintedType
lintValueType :: Type -> LintM Type
lintValueType Type
ty
= LintLocInfo -> LintM Type -> LintM Type
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Type -> LintLocInfo
InType Type
ty) (LintM Type -> LintM Type) -> LintM Type -> LintM Type
forall a b. (a -> b) -> a -> b
$
do { Type
ty' <- Type -> LintM Type
lintType Type
ty
; let sk :: Type
sk = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty'
; Bool -> SDoc -> LintM ()
lintL (Type -> Bool
classifiesTypeWithValues Type
sk) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Ill-kinded type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
Int
2 (String -> SDoc
text String
"has kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sk)
; Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty' }
checkTyCon :: TyCon -> LintM ()
checkTyCon :: TyCon -> LintM ()
checkTyCon TyCon
tc
= Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not (TyCon -> Bool
isTcTyCon TyCon
tc)) (String -> SDoc
text String
"Found TcTyCon:" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
lintType :: Type -> LintM LintedType
lintType :: Type -> LintM Type
lintType (TyVarTy Var
tv)
| Bool -> Bool
not (Var -> Bool
isTyVar Var
tv)
= SDoc -> LintM Type
forall a. SDoc -> LintM a
failWithL (Var -> SDoc
mkBadTyVarMsg Var
tv)
| Bool
otherwise
= do { TCvSubst
subst <- LintM TCvSubst
getTCvSubst
; case TCvSubst -> Var -> Maybe Type
lookupTyVar TCvSubst
subst Var
tv of
Just Type
linted_ty -> Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
linted_ty
Maybe Type
Nothing | Var
tv Var -> TCvSubst -> Bool
`isInScope` TCvSubst
subst
-> Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Type
TyVarTy Var
tv)
| Bool
otherwise
-> SDoc -> LintM Type
forall a. SDoc -> LintM a
failWithL (SDoc -> LintM Type) -> SDoc -> LintM Type
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"The type variable" SDoc -> SDoc -> SDoc
<+> BindingSite -> Var -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Var
tv)
Int
2 (String -> SDoc
text String
"is out of scope")
}
lintType ty :: Type
ty@(AppTy Type
t1 Type
t2)
| TyConApp {} <- Type
t1
= SDoc -> LintM Type
forall a. SDoc -> LintM a
failWithL (SDoc -> LintM Type) -> SDoc -> LintM Type
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"TyConApp to the left of AppTy:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty
| Bool
otherwise
= do { Type
t1' <- Type -> LintM Type
lintType Type
t1
; Type
t2' <- Type -> LintM Type
lintType Type
t2
; Type -> Type -> [Type] -> LintM ()
lint_ty_app Type
ty (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
t1') [Type
t2']
; Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Type
AppTy Type
t1' Type
t2') }
lintType ty :: Type
ty@(TyConApp TyCon
tc [Type]
tys)
| TyCon -> Bool
isTypeSynonymTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isTypeFamilyTyCon TyCon
tc
= do { Bool
report_unsat <- LintFlags -> Bool
lf_report_unsat_syns (LintFlags -> Bool) -> LintM LintFlags -> LintM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LintM LintFlags
getLintFlags
; Bool -> Type -> TyCon -> [Type] -> LintM Type
lintTySynFamApp Bool
report_unsat Type
ty TyCon
tc [Type]
tys }
| TyCon -> Bool
isFunTyCon TyCon
tc
, [Type]
tys [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
5
= SDoc -> LintM Type
forall a. SDoc -> LintM a
failWithL (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Saturated application of (->)") Int
2 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty))
| Bool
otherwise
= do { TyCon -> LintM ()
checkTyCon TyCon
tc
; [Type]
tys' <- (Type -> LintM Type) -> [Type] -> LintM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> LintM Type
lintType [Type]
tys
; Type -> Type -> [Type] -> LintM ()
lint_ty_app Type
ty (TyCon -> Type
tyConKind TyCon
tc) [Type]
tys'
; Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> [Type] -> Type
TyConApp TyCon
tc [Type]
tys') }
lintType ty :: Type
ty@(FunTy AnonArgFlag
af Type
tw Type
t1 Type
t2)
= do { Type
t1' <- Type -> LintM Type
lintType Type
t1
; Type
t2' <- Type -> LintM Type
lintType Type
t2
; Type
tw' <- Type -> LintM Type
lintType Type
tw
; SDoc -> Type -> Type -> Type -> LintM ()
lintArrow (String -> SDoc
text String
"type or kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)) Type
t1' Type
t2' Type
tw'
; Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (AnonArgFlag -> Type -> Type -> Type -> Type
FunTy AnonArgFlag
af Type
tw' Type
t1' Type
t2') }
lintType ty :: Type
ty@(ForAllTy (Bndr Var
tcv ArgFlag
vis) Type
body_ty)
| Bool -> Bool
not (Var -> Bool
isTyCoVar Var
tcv)
= SDoc -> LintM Type
forall a. SDoc -> LintM a
failWithL (String -> SDoc
text String
"Non-Tyvar or Non-Covar bound in type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
| Bool
otherwise
= Var -> (Var -> LintM Type) -> LintM Type
forall a. Var -> (Var -> LintM a) -> LintM a
lintTyCoBndr Var
tcv ((Var -> LintM Type) -> LintM Type)
-> (Var -> LintM Type) -> LintM Type
forall a b. (a -> b) -> a -> b
$ \Var
tcv' ->
do { Type
body_ty' <- Type -> LintM Type
lintType Type
body_ty
; Var -> Type -> LintM ()
lintForAllBody Var
tcv' Type
body_ty'
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Var -> Bool
isCoVar Var
tcv) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> LintM ()
lintL (Var
tcv Var -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
body_ty) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Covar does not occur in the body:" SDoc -> SDoc -> SDoc
<+> (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
tcv SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body_ty)
; Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCoVarBinder -> Type -> Type
ForAllTy (Var -> ArgFlag -> TyCoVarBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Var
tcv' ArgFlag
vis) Type
body_ty') }
lintType ty :: Type
ty@(LitTy TyLit
l)
= do { TyLit -> LintM ()
lintTyLit TyLit
l; Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty }
lintType (CastTy Type
ty Coercion
co)
= do { Type
ty' <- Type -> LintM Type
lintType Type
ty
; Coercion
co' <- Coercion -> LintM Coercion
lintStarCoercion Coercion
co
; let tyk :: Type
tyk = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty'
cok :: Type
cok = Coercion -> Type
coercionLKind Coercion
co'
; Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
tyk Type
cok (Type -> Coercion -> Type -> Type -> SDoc
mkCastTyErr Type
ty Coercion
co Type
tyk Type
cok)
; Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Coercion -> Type
CastTy Type
ty' Coercion
co') }
lintType (CoercionTy Coercion
co)
= do { Coercion
co' <- Coercion -> LintM Coercion
lintCoercion Coercion
co
; Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Type
CoercionTy Coercion
co') }
lintForAllBody :: LintedTyCoVar -> LintedType -> LintM ()
lintForAllBody :: Var -> Type -> LintM ()
lintForAllBody Var
tcv Type
body_ty
= do { Type -> SDoc -> LintM ()
checkValueType Type
body_ty (String -> SDoc
text String
"the body of forall:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body_ty)
; let body_kind :: Type
body_kind = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
body_ty
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Var -> Bool
isTyVar Var
tcv) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
case [Var] -> Type -> Maybe Type
occCheckExpand [Var
tcv] Type
body_kind of
Just {} -> () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Type
Nothing -> SDoc -> LintM ()
forall a. SDoc -> LintM a
failWithL (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Variable escape in forall:")
Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"tyvar:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
tcv
, String -> SDoc
text String
"type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body_ty
, String -> SDoc
text String
"kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body_kind ])
}
lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM LintedType
lintTySynFamApp :: Bool -> Type -> TyCon -> [Type] -> LintM Type
lintTySynFamApp Bool
report_unsat Type
ty TyCon
tc [Type]
tys
| Bool
report_unsat
, [Type]
tys [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthLessThan` TyCon -> Int
tyConArity TyCon
tc
= SDoc -> LintM Type
forall a. SDoc -> LintM a
failWithL (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Un-saturated type application") Int
2 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty))
| Just ([(Var, Type)]
tenv, Type
rhs, [Type]
tys') <- TyCon -> [Type] -> Maybe ([(Var, Type)], Type, [Type])
forall tyco. TyCon -> [tyco] -> Maybe ([(Var, tyco)], Type, [tyco])
expandSynTyCon_maybe TyCon
tc [Type]
tys
, let expanded_ty :: Type
expanded_ty = Type -> [Type] -> Type
mkAppTys (HasDebugCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy ([(Var, Type)] -> TCvSubst
mkTvSubstPrs [(Var, Type)]
tenv) Type
rhs) [Type]
tys'
= do {
[Type]
tys' <- Bool -> LintM [Type] -> LintM [Type]
forall a. Bool -> LintM a -> LintM a
setReportUnsat Bool
False ((Type -> LintM Type) -> [Type] -> LintM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> LintM Type
lintType [Type]
tys)
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
report_unsat (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
do { Type
_ <- Type -> LintM Type
lintType Type
expanded_ty
; () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
; Type -> Type -> [Type] -> LintM ()
lint_ty_app Type
ty (TyCon -> Type
tyConKind TyCon
tc) [Type]
tys'
; Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> [Type] -> Type
TyConApp TyCon
tc [Type]
tys') }
| Bool
otherwise
= do { [Type]
tys' <- (Type -> LintM Type) -> [Type] -> LintM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> LintM Type
lintType [Type]
tys
; Type -> Type -> [Type] -> LintM ()
lint_ty_app Type
ty (TyCon -> Type
tyConKind TyCon
tc) [Type]
tys'
; Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> [Type] -> Type
TyConApp TyCon
tc [Type]
tys') }
checkValueType :: LintedType -> SDoc -> LintM ()
checkValueType :: Type -> SDoc -> LintM ()
checkValueType Type
ty SDoc
doc
= Bool -> SDoc -> LintM ()
lintL (Type -> Bool
classifiesTypeWithValues Type
kind)
(String -> SDoc
text String
"Non-Type-like kind when Type-like expected:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
kind SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"when checking" SDoc -> SDoc -> SDoc
<+> SDoc
doc)
where
kind :: Type
kind = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty
lintArrow :: SDoc -> LintedType -> LintedType -> LintedType -> LintM ()
lintArrow :: SDoc -> Type -> Type -> Type -> LintM ()
lintArrow SDoc
what Type
t1 Type
t2 Type
tw
= do { Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type -> Bool
classifiesTypeWithValues Type
k1) (SDoc -> LintM ()
addErrL (SDoc -> Type -> SDoc
msg (String -> SDoc
text String
"argument") Type
k1))
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type -> Bool
classifiesTypeWithValues Type
k2) (SDoc -> LintM ()
addErrL (SDoc -> Type -> SDoc
msg (String -> SDoc
text String
"result") Type
k2))
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type -> Bool
isMultiplicityTy Type
kw) (SDoc -> LintM ()
addErrL (SDoc -> Type -> SDoc
msg (String -> SDoc
text String
"multiplicity") Type
kw)) }
where
k1 :: Type
k1 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
t1
k2 :: Type
k2 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
t2
kw :: Type
kw = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
tw
msg :: SDoc -> Type -> SDoc
msg SDoc
ar Type
k
= [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Ill-kinded" SDoc -> SDoc -> SDoc
<+> SDoc
ar)
Int
2 (String -> SDoc
text String
"in" SDoc -> SDoc -> SDoc
<+> SDoc
what)
, SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
k ]
lint_ty_app :: Type -> LintedKind -> [LintedType] -> LintM ()
lint_ty_app :: Type -> Type -> [Type] -> LintM ()
lint_ty_app Type
ty Type
k [Type]
tys
= SDoc -> Type -> [Type] -> LintM ()
lint_app (String -> SDoc
text String
"type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)) Type
k [Type]
tys
lint_co_app :: Coercion -> LintedKind -> [LintedType] -> LintM ()
lint_co_app :: Coercion -> Type -> [Type] -> LintM ()
lint_co_app Coercion
ty Type
k [Type]
tys
= SDoc -> Type -> [Type] -> LintM ()
lint_app (String -> SDoc
text String
"coercion" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
ty)) Type
k [Type]
tys
lintTyLit :: TyLit -> LintM ()
lintTyLit :: TyLit -> LintM ()
lintTyLit (NumTyLit Integer
n)
| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = SDoc -> LintM ()
forall a. SDoc -> LintM a
failWithL SDoc
msg
where msg :: SDoc
msg = String -> SDoc
text String
"Negative type literal:" SDoc -> SDoc -> SDoc
<+> Integer -> SDoc
integer Integer
n
lintTyLit (StrTyLit FastString
_) = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lintTyLit (CharTyLit Char
_) = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lint_app :: SDoc -> LintedKind -> [LintedType] -> LintM ()
lint_app :: SDoc -> Type -> [Type] -> LintM ()
lint_app SDoc
doc Type
kfn [Type]
arg_tys
= do { InScopeSet
in_scope <- LintM InScopeSet
getInScope
; Type
_ <- (Type -> Type -> LintM Type) -> Type -> [Type] -> LintM Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (InScopeSet -> Type -> Type -> LintM Type
go_app InScopeSet
in_scope) Type
kfn [Type]
arg_tys
; () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
where
fail_msg :: SDoc -> SDoc
fail_msg SDoc
extra = [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Kind application error in") Int
2 SDoc
doc
, Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"Function kind =" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
kfn)
, Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"Arg types =" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
arg_tys)
, SDoc
extra ]
go_app :: InScopeSet -> Type -> Type -> LintM Type
go_app InScopeSet
in_scope Type
kfn Type
ta
| Just Type
kfn' <- Type -> Maybe Type
coreView Type
kfn
= InScopeSet -> Type -> Type -> LintM Type
go_app InScopeSet
in_scope Type
kfn' Type
ta
go_app InScopeSet
_ fun_kind :: Type
fun_kind@(FunTy AnonArgFlag
_ Type
_ Type
kfa Type
kfb) Type
ta
= do { let ka :: Type
ka = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ta
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type
ka Type -> Type -> Bool
`eqType` Type
kfa) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> LintM ()
addErrL (SDoc -> SDoc
fail_msg (String -> SDoc
text String
"Fun:" SDoc -> SDoc -> SDoc
<+> (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun_kind SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ta SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ka)))
; Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
kfb }
go_app InScopeSet
in_scope (ForAllTy (Bndr Var
kv ArgFlag
_vis) Type
kfn) Type
ta
= do { let kv_kind :: Type
kv_kind = Var -> Type
varType Var
kv
ka :: Type
ka = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ta
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type
ka Type -> Type -> Bool
`eqType` Type
kv_kind) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> LintM ()
addErrL (SDoc -> SDoc
fail_msg (String -> SDoc
text String
"Forall:" SDoc -> SDoc -> SDoc
<+> (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
kv SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
kv_kind SDoc -> SDoc -> SDoc
$$
Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ta SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ka)))
; Type -> LintM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LintM Type) -> Type -> LintM Type
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy (TCvSubst -> Var -> Type -> TCvSubst
extendTCvSubst (InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope) Var
kv Type
ta) Type
kfn }
go_app InScopeSet
_ Type
kfn Type
ta
= SDoc -> LintM Type
forall a. SDoc -> LintM a
failWithL (SDoc -> SDoc
fail_msg (String -> SDoc
text String
"Not a fun:" SDoc -> SDoc -> SDoc
<+> (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
kfn SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ta)))
lintCoreRule :: OutVar -> LintedType -> CoreRule -> LintM ()
lintCoreRule :: Var -> Type -> CoreRule -> LintM ()
lintCoreRule Var
_ Type
_ (BuiltinRule {})
= () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lintCoreRule Var
fun Type
fun_ty rule :: CoreRule
rule@(Rule { ru_name :: CoreRule -> FastString
ru_name = FastString
name, ru_bndrs :: CoreRule -> [Var]
ru_bndrs = [Var]
bndrs
, ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
args, ru_rhs :: CoreRule -> CoreExpr
ru_rhs = CoreExpr
rhs })
= BindingSite -> [Var] -> ([Var] -> LintM ()) -> LintM ()
forall a. BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
lintBinders BindingSite
LambdaBind [Var]
bndrs (([Var] -> LintM ()) -> LintM ())
-> ([Var] -> LintM ()) -> LintM ()
forall a b. (a -> b) -> a -> b
$ \ [Var]
_ ->
do { (Type
lhs_ty, UsageEnv
_) <- (Type, UsageEnv) -> [CoreExpr] -> LintM (Type, UsageEnv)
lintCoreArgs (Type
fun_ty, UsageEnv
zeroUE) [CoreExpr]
args
; (Type
rhs_ty, UsageEnv
_) <- case Var -> Maybe Int
isJoinId_maybe Var
fun of
Just Int
join_arity
-> do { Bool -> SDoc -> LintM ()
checkL ([CoreExpr]
args [CoreExpr] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
join_arity) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
Var -> Int -> CoreRule -> SDoc
mkBadJoinPointRuleMsg Var
fun Int
join_arity CoreRule
rule
; CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
rhs }
Maybe Int
_ -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a. LintM a -> LintM a
markAllJoinsBad (LintM (Type, UsageEnv) -> LintM (Type, UsageEnv))
-> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> LintM (Type, UsageEnv)
lintCoreExpr CoreExpr
rhs
; Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
lhs_ty Type
rhs_ty (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
(SDoc
rule_doc SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"lhs type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
lhs_ty
, String -> SDoc
text String
"rhs type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty
, String -> SDoc
text String
"fun_ty:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun_ty ])
; let bad_bndrs :: [Var]
bad_bndrs = (Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter Var -> Bool
is_bad_bndr [Var]
bndrs
; Bool -> SDoc -> LintM ()
checkL ([Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
bad_bndrs)
(SDoc
rule_doc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"unbound" SDoc -> SDoc -> SDoc
<+> [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
bad_bndrs)
}
where
rule_doc :: SDoc
rule_doc = String -> SDoc
text String
"Rule" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
doubleQuotes (FastString -> SDoc
ftext FastString
name) SDoc -> SDoc -> SDoc
<> SDoc
colon
lhs_fvs :: VarSet
lhs_fvs = [CoreExpr] -> VarSet
exprsFreeVars [CoreExpr]
args
rhs_fvs :: VarSet
rhs_fvs = CoreExpr -> VarSet
exprFreeVars CoreExpr
rhs
is_bad_bndr :: Var -> Bool
is_bad_bndr :: Var -> Bool
is_bad_bndr Var
bndr = Bool -> Bool
not (Var
bndr Var -> VarSet -> Bool
`elemVarSet` VarSet
lhs_fvs)
Bool -> Bool -> Bool
&& Var
bndr Var -> VarSet -> Bool
`elemVarSet` VarSet
rhs_fvs
Bool -> Bool -> Bool
&& Maybe Coercion -> Bool
forall a. Maybe a -> Bool
isNothing (Var -> Maybe Coercion
isReflCoVar_maybe Var
bndr)
lintStarCoercion :: InCoercion -> LintM LintedCoercion
lintStarCoercion :: Coercion -> LintM Coercion
lintStarCoercion Coercion
g
= do { Coercion
g' <- Coercion -> LintM Coercion
lintCoercion Coercion
g
; let Pair Type
t1 Type
t2 = Coercion -> Pair Type
coercionKind Coercion
g'
; Type -> SDoc -> LintM ()
checkValueType Type
t1 (String -> SDoc
text String
"the kind of the left type in" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
g)
; Type -> SDoc -> LintM ()
checkValueType Type
t2 (String -> SDoc
text String
"the kind of the right type in" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
g)
; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
g Role
Nominal (Coercion -> Role
coercionRole Coercion
g)
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return Coercion
g' }
lintCoercion :: InCoercion -> LintM LintedCoercion
lintCoercion :: Coercion -> LintM Coercion
lintCoercion (CoVarCo Var
cv)
| Bool -> Bool
not (Var -> Bool
isCoVar Var
cv)
= SDoc -> LintM Coercion
forall a. SDoc -> LintM a
failWithL (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Bad CoVarCo:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
cv)
Int
2 (String -> SDoc
text String
"With offending type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
cv)))
| Bool
otherwise
= do { TCvSubst
subst <- LintM TCvSubst
getTCvSubst
; case TCvSubst -> Var -> Maybe Coercion
lookupCoVar TCvSubst
subst Var
cv of
Just Coercion
linted_co -> Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return Coercion
linted_co ;
Maybe Coercion
Nothing
| Var
cv Var -> TCvSubst -> Bool
`isInScope` TCvSubst
subst
-> Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Coercion
CoVarCo Var
cv)
| Bool
otherwise
->
SDoc -> LintM Coercion
forall a. SDoc -> LintM a
failWithL (SDoc -> LintM Coercion) -> SDoc -> LintM Coercion
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"The coercion variable" SDoc -> SDoc -> SDoc
<+> BindingSite -> Var -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Var
cv)
Int
2 (String -> SDoc
text String
"is out of scope")
}
lintCoercion (Refl Type
ty)
= do { Type
ty' <- Type -> LintM Type
lintType Type
ty
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Coercion
Refl Type
ty') }
lintCoercion (GRefl Role
r Type
ty MCoercion
MRefl)
= do { Type
ty' <- Type -> LintM Type
lintType Type
ty
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Role -> Type -> MCoercion -> Coercion
GRefl Role
r Type
ty' MCoercion
MRefl) }
lintCoercion (GRefl Role
r Type
ty (MCo Coercion
co))
= do { Type
ty' <- Type -> LintM Type
lintType Type
ty
; Coercion
co' <- Coercion -> LintM Coercion
lintCoercion Coercion
co
; let tk :: Type
tk = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty'
tl :: Type
tl = Coercion -> Type
coercionLKind Coercion
co'
; Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
tk Type
tl (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"GRefl coercion kind mis-match:" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)
Int
2 ([SDoc] -> SDoc
vcat [Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty', Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
tk, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
tl])
; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
co' Role
Nominal (Coercion -> Role
coercionRole Coercion
co')
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Role -> Type -> MCoercion -> Coercion
GRefl Role
r Type
ty' (Coercion -> MCoercion
MCo Coercion
co')) }
lintCoercion co :: Coercion
co@(TyConAppCo Role
r TyCon
tc [Coercion]
cos)
| TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funTyConKey
, [Coercion
_w, Coercion
_rep1,Coercion
_rep2,Coercion
_co1,Coercion
_co2] <- [Coercion]
cos
= SDoc -> LintM Coercion
forall a. SDoc -> LintM a
failWithL (String -> SDoc
text String
"Saturated TyConAppCo (->):" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)
| Just {} <- TyCon -> Maybe ([Var], Type)
synTyConDefn_maybe TyCon
tc
= SDoc -> LintM Coercion
forall a. SDoc -> LintM a
failWithL (String -> SDoc
text String
"Synonym in TyConAppCo:" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)
| Bool
otherwise
= do { TyCon -> LintM ()
checkTyCon TyCon
tc
; [Coercion]
cos' <- (Coercion -> LintM Coercion) -> [Coercion] -> LintM [Coercion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Coercion -> LintM Coercion
lintCoercion [Coercion]
cos
; let ([Pair Type]
co_kinds, [Role]
co_roles) = [(Pair Type, Role)] -> ([Pair Type], [Role])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Coercion -> (Pair Type, Role))
-> [Coercion] -> [(Pair Type, Role)]
forall a b. (a -> b) -> [a] -> [b]
map Coercion -> (Pair Type, Role)
coercionKindRole [Coercion]
cos')
; Coercion -> Type -> [Type] -> LintM ()
lint_co_app Coercion
co (TyCon -> Type
tyConKind TyCon
tc) ((Pair Type -> Type) -> [Pair Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Pair Type -> Type
forall a. Pair a -> a
pFst [Pair Type]
co_kinds)
; Coercion -> Type -> [Type] -> LintM ()
lint_co_app Coercion
co (TyCon -> Type
tyConKind TyCon
tc) ((Pair Type -> Type) -> [Pair Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Pair Type -> Type
forall a. Pair a -> a
pSnd [Pair Type]
co_kinds)
; (Role -> Role -> LintM ()) -> [Role] -> [Role] -> LintM ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
co) (Role -> TyCon -> [Role]
tyConRolesX Role
r TyCon
tc) [Role]
co_roles
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Role -> TyCon -> [Coercion] -> Coercion
TyConAppCo Role
r TyCon
tc [Coercion]
cos') }
lintCoercion co :: Coercion
co@(AppCo Coercion
co1 Coercion
co2)
| TyConAppCo {} <- Coercion
co1
= SDoc -> LintM Coercion
forall a. SDoc -> LintM a
failWithL (String -> SDoc
text String
"TyConAppCo to the left of AppCo:" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)
| Just (TyConApp {}, Role
_) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co1
= SDoc -> LintM Coercion
forall a. SDoc -> LintM a
failWithL (String -> SDoc
text String
"Refl (TyConApp ...) to the left of AppCo:" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)
| Bool
otherwise
= do { Coercion
co1' <- Coercion -> LintM Coercion
lintCoercion Coercion
co1
; Coercion
co2' <- Coercion -> LintM Coercion
lintCoercion Coercion
co2
; let (Pair Type
lk1 Type
rk1, Role
r1) = Coercion -> (Pair Type, Role)
coercionKindRole Coercion
co1'
(Pair Type
lk2 Type
rk2, Role
r2) = Coercion -> (Pair Type, Role)
coercionKindRole Coercion
co2'
; Coercion -> Type -> [Type] -> LintM ()
lint_co_app Coercion
co (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
lk1) [Type
lk2]
; Coercion -> Type -> [Type] -> LintM ()
lint_co_app Coercion
co (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
rk1) [Type
rk2]
; if Role
r1 Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Phantom
then Bool -> SDoc -> LintM ()
lintL (Role
r2 Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Phantom Bool -> Bool -> Bool
|| Role
r2 Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Nominal)
(String -> SDoc
text String
"Second argument in AppCo cannot be R:" SDoc -> SDoc -> SDoc
$$
Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)
else Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
co Role
Nominal Role
r2
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Coercion -> Coercion
AppCo Coercion
co1' Coercion
co2') }
lintCoercion co :: Coercion
co@(ForAllCo Var
tcv Coercion
kind_co Coercion
body_co)
| Bool -> Bool
not (Var -> Bool
isTyCoVar Var
tcv)
= SDoc -> LintM Coercion
forall a. SDoc -> LintM a
failWithL (String -> SDoc
text String
"Non tyco binder in ForAllCo:" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)
| Bool
otherwise
= do { Coercion
kind_co' <- Coercion -> LintM Coercion
lintStarCoercion Coercion
kind_co
; Var -> (Var -> LintM Coercion) -> LintM Coercion
forall a. Var -> (Var -> LintM a) -> LintM a
lintTyCoBndr Var
tcv ((Var -> LintM Coercion) -> LintM Coercion)
-> (Var -> LintM Coercion) -> LintM Coercion
forall a b. (a -> b) -> a -> b
$ \Var
tcv' ->
do { Coercion
body_co' <- Coercion -> LintM Coercion
lintCoercion Coercion
body_co
; Type -> Type -> SDoc -> LintM ()
ensureEqTys (Var -> Type
varType Var
tcv') (Coercion -> Type
coercionLKind Coercion
kind_co') (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Kind mis-match in ForallCo" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co
; let Pair Type
lty Type
rty = Coercion -> Pair Type
coercionKind Coercion
body_co'
; Var -> Type -> LintM ()
lintForAllBody Var
tcv' Type
lty
; Var -> Type -> LintM ()
lintForAllBody Var
tcv' Type
rty
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Var -> Bool
isCoVar Var
tcv) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> LintM ()
lintL (Var -> Coercion -> Bool
almostDevoidCoVarOfCo Var
tcv Coercion
body_co) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Covar can only appear in Refl and GRefl: " SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Coercion -> Coercion -> Coercion
ForAllCo Var
tcv' Coercion
kind_co' Coercion
body_co') } }
lintCoercion co :: Coercion
co@(FunCo Role
r Coercion
cow Coercion
co1 Coercion
co2)
= do { Coercion
co1' <- Coercion -> LintM Coercion
lintCoercion Coercion
co1
; Coercion
co2' <- Coercion -> LintM Coercion
lintCoercion Coercion
co2
; Coercion
cow' <- Coercion -> LintM Coercion
lintCoercion Coercion
cow
; let Pair Type
lt1 Type
rt1 = Coercion -> Pair Type
coercionKind Coercion
co1
Pair Type
lt2 Type
rt2 = Coercion -> Pair Type
coercionKind Coercion
co2
Pair Type
ltw Type
rtw = Coercion -> Pair Type
coercionKind Coercion
cow
; SDoc -> Type -> Type -> Type -> LintM ()
lintArrow (String -> SDoc
text String
"coercion" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)) Type
lt1 Type
lt2 Type
ltw
; SDoc -> Type -> Type -> Type -> LintM ()
lintArrow (String -> SDoc
text String
"coercion" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)) Type
rt1 Type
rt2 Type
rtw
; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
co1 Role
r (Coercion -> Role
coercionRole Coercion
co1)
; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
co2 Role
r (Coercion -> Role
coercionRole Coercion
co2)
; Type -> Type -> SDoc -> LintM ()
ensureEqTys (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ltw) Type
multiplicityTy (String -> SDoc
text String
"coercion" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
quotes (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co))
; Type -> Type -> SDoc -> LintM ()
ensureEqTys (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
rtw) Type
multiplicityTy (String -> SDoc
text String
"coercion" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
quotes (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co))
; let expected_mult_role :: Role
expected_mult_role = case Role
r of
Role
Phantom -> Role
Phantom
Role
_ -> Role
Nominal
; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
cow Role
expected_mult_role (Coercion -> Role
coercionRole Coercion
cow)
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Role -> Coercion -> Coercion -> Coercion -> Coercion
FunCo Role
r Coercion
cow' Coercion
co1' Coercion
co2') }
lintCoercion co :: Coercion
co@(UnivCo UnivCoProvenance
prov Role
r Type
ty1 Type
ty2)
= do { Type
ty1' <- Type -> LintM Type
lintType Type
ty1
; Type
ty2' <- Type -> LintM Type
lintType Type
ty2
; let k1 :: Type
k1 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty1'
k2 :: Type
k2 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty2'
; UnivCoProvenance
prov' <- Type -> Type -> UnivCoProvenance -> LintM UnivCoProvenance
lint_prov Type
k1 Type
k2 UnivCoProvenance
prov
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Role
r Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
/= Role
Phantom Bool -> Bool -> Bool
&& Type -> Bool
classifiesTypeWithValues Type
k1
Bool -> Bool -> Bool
&& Type -> Bool
classifiesTypeWithValues Type
k2)
(Type -> Type -> LintM ()
checkTypes Type
ty1 Type
ty2)
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (UnivCoProvenance -> Role -> Type -> Type -> Coercion
UnivCo UnivCoProvenance
prov' Role
r Type
ty1' Type
ty2') }
where
report :: String -> SDoc
report String
s = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"Unsafe coercion: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"From:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty1
, String -> SDoc
text String
" To:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2])
isUnBoxed :: PrimRep -> Bool
isUnBoxed :: PrimRep -> Bool
isUnBoxed = Bool -> Bool
not (Bool -> Bool) -> (PrimRep -> Bool) -> PrimRep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimRep -> Bool
isGcPtrRep
checkTypes :: Type -> Type -> LintM ()
checkTypes Type
t1 Type
t2
| UnivCoProvenance -> Bool
allow_ill_kinded_univ_co UnivCoProvenance
prov
= () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= do { Bool -> SDoc -> LintM ()
checkWarnL Bool
fixed_rep_1
(String -> SDoc
report String
"left-hand type does not have a fixed runtime representation")
; Bool -> SDoc -> LintM ()
checkWarnL Bool
fixed_rep_2
(String -> SDoc
report String
"right-hand type does not have a fixed runtime representation")
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
fixed_rep_1 Bool -> Bool -> Bool
&& Bool
fixed_rep_2) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
do { Bool -> SDoc -> LintM ()
checkWarnL ([PrimRep]
reps1 [PrimRep] -> [PrimRep] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [PrimRep]
reps2)
(String -> SDoc
report String
"between values with different # of reps")
; (PrimRep -> PrimRep -> LintM ())
-> [PrimRep] -> [PrimRep] -> LintM ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ PrimRep -> PrimRep -> LintM ()
validateCoercion [PrimRep]
reps1 [PrimRep]
reps2 }}
where
fixed_rep_1 :: Bool
fixed_rep_1 = Type -> Bool
typeHasFixedRuntimeRep Type
t1
fixed_rep_2 :: Bool
fixed_rep_2 = Type -> Bool
typeHasFixedRuntimeRep Type
t2
reps1 :: [PrimRep]
reps1 = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
t1
reps2 :: [PrimRep]
reps2 = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
t2
allow_ill_kinded_univ_co :: UnivCoProvenance -> Bool
allow_ill_kinded_univ_co (CorePrepProv Bool
homo_kind) = Bool -> Bool
not Bool
homo_kind
allow_ill_kinded_univ_co UnivCoProvenance
_ = Bool
False
validateCoercion :: PrimRep -> PrimRep -> LintM ()
validateCoercion :: PrimRep -> PrimRep -> LintM ()
validateCoercion PrimRep
rep1 PrimRep
rep2
= do { Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> LintM DynFlags -> LintM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LintM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Bool -> SDoc -> LintM ()
checkWarnL (PrimRep -> Bool
isUnBoxed PrimRep
rep1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== PrimRep -> Bool
isUnBoxed PrimRep
rep2)
(String -> SDoc
report String
"between unboxed and boxed value")
; Bool -> SDoc -> LintM ()
checkWarnL (Platform -> PrimRep -> Int
TyCon.primRepSizeB Platform
platform PrimRep
rep1
Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> PrimRep -> Int
TyCon.primRepSizeB Platform
platform PrimRep
rep2)
(String -> SDoc
report String
"between unboxed values of different size")
; let fl :: Maybe Bool
fl = (Bool -> Bool -> Bool) -> Maybe Bool -> Maybe Bool -> Maybe Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(==) (PrimRep -> Maybe Bool
TyCon.primRepIsFloat PrimRep
rep1)
(PrimRep -> Maybe Bool
TyCon.primRepIsFloat PrimRep
rep2)
; case Maybe Bool
fl of
Maybe Bool
Nothing -> SDoc -> LintM ()
addWarnL (String -> SDoc
report String
"between vector types")
Just Bool
False -> SDoc -> LintM ()
addWarnL (String -> SDoc
report String
"between float and integral values")
Maybe Bool
_ -> () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
lint_prov :: Type -> Type -> UnivCoProvenance -> LintM UnivCoProvenance
lint_prov Type
k1 Type
k2 (PhantomProv Coercion
kco)
= do { Coercion
kco' <- Coercion -> LintM Coercion
lintStarCoercion Coercion
kco
; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
co Role
Phantom Role
r
; Coercion -> Type -> Type -> LintM ()
check_kinds Coercion
kco' Type
k1 Type
k2
; UnivCoProvenance -> LintM UnivCoProvenance
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> UnivCoProvenance
PhantomProv Coercion
kco') }
lint_prov Type
k1 Type
k2 (ProofIrrelProv Coercion
kco)
= do { Bool -> SDoc -> LintM ()
lintL (Type -> Bool
isCoercionTy Type
ty1) (Type -> Coercion -> SDoc
mkBadProofIrrelMsg Type
ty1 Coercion
co)
; Bool -> SDoc -> LintM ()
lintL (Type -> Bool
isCoercionTy Type
ty2) (Type -> Coercion -> SDoc
mkBadProofIrrelMsg Type
ty2 Coercion
co)
; Coercion
kco' <- Coercion -> LintM Coercion
lintStarCoercion Coercion
kco
; Coercion -> Type -> Type -> LintM ()
check_kinds Coercion
kco Type
k1 Type
k2
; UnivCoProvenance -> LintM UnivCoProvenance
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> UnivCoProvenance
ProofIrrelProv Coercion
kco') }
lint_prov Type
_ Type
_ prov :: UnivCoProvenance
prov@(PluginProv String
_) = UnivCoProvenance -> LintM UnivCoProvenance
forall (m :: * -> *) a. Monad m => a -> m a
return UnivCoProvenance
prov
lint_prov Type
_ Type
_ prov :: UnivCoProvenance
prov@(CorePrepProv Bool
_) = UnivCoProvenance -> LintM UnivCoProvenance
forall (m :: * -> *) a. Monad m => a -> m a
return UnivCoProvenance
prov
check_kinds :: Coercion -> Type -> Type -> LintM ()
check_kinds Coercion
kco Type
k1 Type
k2
= do { let Pair Type
k1' Type
k2' = Coercion -> Pair Type
coercionKind Coercion
kco
; Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
k1 Type
k1' (LeftOrRight -> Coercion -> SDoc
mkBadUnivCoMsg LeftOrRight
CLeft Coercion
co)
; Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
k2 Type
k2' (LeftOrRight -> Coercion -> SDoc
mkBadUnivCoMsg LeftOrRight
CRight Coercion
co) }
lintCoercion (SymCo Coercion
co)
= do { Coercion
co' <- Coercion -> LintM Coercion
lintCoercion Coercion
co
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Coercion
SymCo Coercion
co') }
lintCoercion co :: Coercion
co@(TransCo Coercion
co1 Coercion
co2)
= do { Coercion
co1' <- Coercion -> LintM Coercion
lintCoercion Coercion
co1
; Coercion
co2' <- Coercion -> LintM Coercion
lintCoercion Coercion
co2
; let ty1b :: Type
ty1b = Coercion -> Type
coercionRKind Coercion
co1'
ty2a :: Type
ty2a = Coercion -> Type
coercionLKind Coercion
co2'
; Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
ty1b Type
ty2a
(SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Trans coercion mis-match:" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)
Int
2 ([SDoc] -> SDoc
vcat [Pair Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Pair Type
coercionKind Coercion
co1'), Pair Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Pair Type
coercionKind Coercion
co2')]))
; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
co (Coercion -> Role
coercionRole Coercion
co1) (Coercion -> Role
coercionRole Coercion
co2)
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Coercion -> Coercion
TransCo Coercion
co1' Coercion
co2') }
lintCoercion the_co :: Coercion
the_co@(NthCo Role
r0 Int
n Coercion
co)
= do { Coercion
co' <- Coercion -> LintM Coercion
lintCoercion Coercion
co
; let (Pair Type
s Type
t, Role
r) = Coercion -> (Pair Type, Role)
coercionKindRole Coercion
co'
; case (Type -> Maybe (Var, Type)
splitForAllTyCoVar_maybe Type
s, Type -> Maybe (Var, Type)
splitForAllTyCoVar_maybe Type
t) of
{ (Just (Var, Type)
_, Just (Var, Type)
_)
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
, (Type -> Bool
isForAllTy_ty Type
s Bool -> Bool -> Bool
&& Type -> Bool
isForAllTy_ty Type
t)
Bool -> Bool -> Bool
|| (Type -> Bool
isForAllTy_co Type
s Bool -> Bool -> Bool
&& Type -> Bool
isForAllTy_co Type
t)
-> do { Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
the_co Role
Nominal Role
r0
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Role -> Int -> Coercion -> Coercion
NthCo Role
r0 Int
n Coercion
co') }
; (Maybe (Var, Type), Maybe (Var, Type))
_ -> case (HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
s, HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t) of
{ (Just (TyCon
tc_s, [Type]
tys_s), Just (TyCon
tc_t, [Type]
tys_t))
| TyCon
tc_s TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc_t
, TyCon -> Role -> Bool
isInjectiveTyCon TyCon
tc_s Role
r
, [Type]
tys_s [Type] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Type]
tys_t
, [Type]
tys_s [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
n
-> do { Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
the_co Role
tr Role
r0
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Role -> Int -> Coercion -> Coercion
NthCo Role
r0 Int
n Coercion
co') }
where
tr :: Role
tr = Role -> TyCon -> Int -> Role
nthRole Role
r TyCon
tc_s Int
n
; (Maybe (TyCon, [Type]), Maybe (TyCon, [Type]))
_ -> SDoc -> LintM Coercion
forall a. SDoc -> LintM a
failWithL (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Bad getNth:")
Int
2 (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
the_co SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
s SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
t)) }}}
lintCoercion the_co :: Coercion
the_co@(LRCo LeftOrRight
lr Coercion
co)
= do { Coercion
co' <- Coercion -> LintM Coercion
lintCoercion Coercion
co
; let Pair Type
s Type
t = Coercion -> Pair Type
coercionKind Coercion
co'
r :: Role
r = Coercion -> Role
coercionRole Coercion
co'
; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
co Role
Nominal Role
r
; case (Type -> Maybe (Type, Type)
splitAppTy_maybe Type
s, Type -> Maybe (Type, Type)
splitAppTy_maybe Type
t) of
(Just (Type, Type)
_, Just (Type, Type)
_) -> Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (LeftOrRight -> Coercion -> Coercion
LRCo LeftOrRight
lr Coercion
co')
(Maybe (Type, Type), Maybe (Type, Type))
_ -> SDoc -> LintM Coercion
forall a. SDoc -> LintM a
failWithL (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Bad LRCo:")
Int
2 (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
the_co SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
s SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
t)) }
lintCoercion (InstCo Coercion
co Coercion
arg)
= do { Coercion
co' <- Coercion -> LintM Coercion
lintCoercion Coercion
co
; Coercion
arg' <- Coercion -> LintM Coercion
lintCoercion Coercion
arg
; let Pair Type
t1 Type
t2 = Coercion -> Pair Type
coercionKind Coercion
co'
Pair Type
s1 Type
s2 = Coercion -> Pair Type
coercionKind Coercion
arg'
; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
arg Role
Nominal (Coercion -> Role
coercionRole Coercion
arg')
; case (Type -> Maybe (Var, Type)
splitForAllTyVar_maybe Type
t1, Type -> Maybe (Var, Type)
splitForAllTyVar_maybe Type
t2) of
{ (Just (Var
tv1,Type
_), Just (Var
tv2,Type
_))
| HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
s1 Type -> Type -> Bool
`eqType` Var -> Type
tyVarKind Var
tv1
, HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
s2 Type -> Type -> Bool
`eqType` Var -> Type
tyVarKind Var
tv2
-> Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Coercion -> Coercion
InstCo Coercion
co' Coercion
arg')
| Bool
otherwise
-> SDoc -> LintM Coercion
forall a. SDoc -> LintM a
failWithL (String -> SDoc
text String
"Kind mis-match in inst coercion1" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)
; (Maybe (Var, Type), Maybe (Var, Type))
_ -> case (Type -> Maybe (Var, Type)
splitForAllCoVar_maybe Type
t1, Type -> Maybe (Var, Type)
splitForAllCoVar_maybe Type
t2) of
{ (Just (Var
cv1, Type
_), Just (Var
cv2, Type
_))
| HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
s1 Type -> Type -> Bool
`eqType` Var -> Type
varType Var
cv1
, HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
s2 Type -> Type -> Bool
`eqType` Var -> Type
varType Var
cv2
, CoercionTy Coercion
_ <- Type
s1
, CoercionTy Coercion
_ <- Type
s2
-> Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Coercion -> Coercion
InstCo Coercion
co' Coercion
arg')
| Bool
otherwise
-> SDoc -> LintM Coercion
forall a. SDoc -> LintM a
failWithL (String -> SDoc
text String
"Kind mis-match in inst coercion2" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)
; (Maybe (Var, Type), Maybe (Var, Type))
_ -> SDoc -> LintM Coercion
forall a. SDoc -> LintM a
failWithL (String -> SDoc
text String
"Bad argument of inst") }}}
lintCoercion co :: Coercion
co@(AxiomInstCo CoAxiom Branched
con Int
ind [Coercion]
cos)
= do { Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
ind Bool -> Bool -> Bool
&& Int
ind Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Branches Branched -> Int
forall (br :: BranchFlag). Branches br -> Int
numBranches (CoAxiom Branched -> Branches Branched
forall (br :: BranchFlag). CoAxiom br -> Branches br
coAxiomBranches CoAxiom Branched
con))
(SDoc -> LintM ()
bad_ax (String -> SDoc
text String
"index out of range"))
; let CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
cab_tvs = [Var]
ktvs
, cab_cvs :: CoAxBranch -> [Var]
cab_cvs = [Var]
cvs
, cab_roles :: CoAxBranch -> [Role]
cab_roles = [Role]
roles } = CoAxiom Branched -> Int -> CoAxBranch
forall (br :: BranchFlag). CoAxiom br -> Int -> CoAxBranch
coAxiomNthBranch CoAxiom Branched
con Int
ind
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Coercion]
cos [Coercion] -> [Var] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` ([Var]
ktvs [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
cvs)) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> LintM ()
bad_ax (String -> SDoc
text String
"lengths")
; [Coercion]
cos' <- (Coercion -> LintM Coercion) -> [Coercion] -> LintM [Coercion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Coercion -> LintM Coercion
lintCoercion [Coercion]
cos
; TCvSubst
subst <- LintM TCvSubst
getTCvSubst
; let empty_subst :: TCvSubst
empty_subst = TCvSubst -> TCvSubst
zapTCvSubst TCvSubst
subst
; (TCvSubst, TCvSubst)
_ <- ((TCvSubst, TCvSubst)
-> (Var, Role, Coercion) -> LintM (TCvSubst, TCvSubst))
-> (TCvSubst, TCvSubst)
-> [(Var, Role, Coercion)]
-> LintM (TCvSubst, TCvSubst)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (TCvSubst, TCvSubst)
-> (Var, Role, Coercion) -> LintM (TCvSubst, TCvSubst)
check_ki (TCvSubst
empty_subst, TCvSubst
empty_subst)
([Var] -> [Role] -> [Coercion] -> [(Var, Role, Coercion)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 ([Var]
ktvs [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
cvs) [Role]
roles [Coercion]
cos')
; let fam_tc :: TyCon
fam_tc = CoAxiom Branched -> TyCon
forall (br :: BranchFlag). CoAxiom br -> TyCon
coAxiomTyCon CoAxiom Branched
con
; case Coercion -> Maybe CoAxBranch
checkAxInstCo Coercion
co of
Just CoAxBranch
bad_branch -> SDoc -> LintM ()
bad_ax (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"inconsistent with" SDoc -> SDoc -> SDoc
<+>
TyCon -> CoAxBranch -> SDoc
pprCoAxBranch TyCon
fam_tc CoAxBranch
bad_branch
Maybe CoAxBranch
Nothing -> () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (CoAxiom Branched -> Int -> [Coercion] -> Coercion
AxiomInstCo CoAxiom Branched
con Int
ind [Coercion]
cos') }
where
bad_ax :: SDoc -> LintM ()
bad_ax SDoc
what = SDoc -> LintM ()
addErrL (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Bad axiom application" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens SDoc
what)
Int
2 (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co))
check_ki :: (TCvSubst, TCvSubst)
-> (Var, Role, Coercion) -> LintM (TCvSubst, TCvSubst)
check_ki (TCvSubst
subst_l, TCvSubst
subst_r) (Var
ktv, Role
role, Coercion
arg')
= do { let Pair Type
s' Type
t' = Coercion -> Pair Type
coercionKind Coercion
arg'
sk' :: Type
sk' = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
s'
tk' :: Type
tk' = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
t'
; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
arg' Role
role (Coercion -> Role
coercionRole Coercion
arg')
; let ktv_kind_l :: Type
ktv_kind_l = HasDebugCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst_l (Var -> Type
tyVarKind Var
ktv)
ktv_kind_r :: Type
ktv_kind_r = HasDebugCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst_r (Var -> Type
tyVarKind Var
ktv)
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type
sk' Type -> Type -> Bool
`eqType` Type
ktv_kind_l)
(SDoc -> LintM ()
bad_ax (String -> SDoc
text String
"check_ki1" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [ Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sk', Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
ktv, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ktv_kind_l ] ))
; Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type
tk' Type -> Type -> Bool
`eqType` Type
ktv_kind_r)
(SDoc -> LintM ()
bad_ax (String -> SDoc
text String
"check_ki2" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [ Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
tk', Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
ktv, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ktv_kind_r ] ))
; (TCvSubst, TCvSubst) -> LintM (TCvSubst, TCvSubst)
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst -> Var -> Type -> TCvSubst
extendTCvSubst TCvSubst
subst_l Var
ktv Type
s',
TCvSubst -> Var -> Type -> TCvSubst
extendTCvSubst TCvSubst
subst_r Var
ktv Type
t') }
lintCoercion (KindCo Coercion
co)
= do { Coercion
co' <- Coercion -> LintM Coercion
lintCoercion Coercion
co
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Coercion
KindCo Coercion
co') }
lintCoercion (SubCo Coercion
co')
= do { Coercion
co' <- Coercion -> LintM Coercion
lintCoercion Coercion
co'
; Coercion -> Role -> Role -> LintM ()
forall thing. Outputable thing => thing -> Role -> Role -> LintM ()
lintRole Coercion
co' Role
Nominal (Coercion -> Role
coercionRole Coercion
co')
; Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Coercion
SubCo Coercion
co') }
lintCoercion this :: Coercion
this@(AxiomRuleCo CoAxiomRule
ax [Coercion]
cos)
= do { [Coercion]
cos' <- (Coercion -> LintM Coercion) -> [Coercion] -> LintM [Coercion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Coercion -> LintM Coercion
lintCoercion [Coercion]
cos
; Int -> [Role] -> [Coercion] -> LintM ()
lint_roles Int
0 (CoAxiomRule -> [Role]
coaxrAsmpRoles CoAxiomRule
ax) [Coercion]
cos'
; case CoAxiomRule -> [Pair Type] -> Maybe (Pair Type)
coaxrProves CoAxiomRule
ax ((Coercion -> Pair Type) -> [Coercion] -> [Pair Type]
forall a b. (a -> b) -> [a] -> [b]
map Coercion -> Pair Type
coercionKind [Coercion]
cos') of
Maybe (Pair Type)
Nothing -> String -> [SDoc] -> LintM Coercion
forall a. String -> [SDoc] -> LintM a
err String
"Malformed use of AxiomRuleCo" [ Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
this ]
Just Pair Type
_ -> Coercion -> LintM Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (CoAxiomRule -> [Coercion] -> Coercion
AxiomRuleCo CoAxiomRule
ax [Coercion]
cos') }
where
err :: forall a. String -> [SDoc] -> LintM a
err :: String -> [SDoc] -> LintM a
err String
m [SDoc]
xs = SDoc -> LintM a
forall a. SDoc -> LintM a
failWithL (SDoc -> LintM a) -> SDoc -> LintM a
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
m) Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat (String -> SDoc
text String
"Rule:" SDoc -> SDoc -> SDoc
<+> FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoAxiomRule -> FastString
coaxrName CoAxiomRule
ax) SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [SDoc]
xs)
lint_roles :: Int -> [Role] -> [Coercion] -> LintM ()
lint_roles Int
n (Role
e : [Role]
es) (Coercion
co : [Coercion]
cos)
| Role
e Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Coercion -> Role
coercionRole Coercion
co = Int -> [Role] -> [Coercion] -> LintM ()
lint_roles (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Role]
es [Coercion]
cos
| Bool
otherwise = String -> [SDoc] -> LintM ()
forall a. String -> [SDoc] -> LintM a
err String
"Argument roles mismatch"
[ String -> SDoc
text String
"In argument:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
, String -> SDoc
text String
"Expected:" SDoc -> SDoc -> SDoc
<+> Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr Role
e
, String -> SDoc
text String
"Found:" SDoc -> SDoc -> SDoc
<+> Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Role
coercionRole Coercion
co) ]
lint_roles Int
_ [] [] = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lint_roles Int
n [] [Coercion]
rs = String -> [SDoc] -> LintM ()
forall a. String -> [SDoc] -> LintM a
err String
"Too many coercion arguments"
[ String -> SDoc
text String
"Expected:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
n
, String -> SDoc
text String
"Provided:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Coercion] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Coercion]
rs) ]
lint_roles Int
n [Role]
es [] = String -> [SDoc] -> LintM ()
forall a. String -> [SDoc] -> LintM a
err String
"Not enough coercion arguments"
[ String -> SDoc
text String
"Expected:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Role] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Role]
es)
, String -> SDoc
text String
"Provided:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
n ]
lintCoercion (HoleCo CoercionHole
h)
= do { SDoc -> LintM ()
addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Unfilled coercion hole:" SDoc -> SDoc -> SDoc
<+> CoercionHole -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoercionHole
h
; Coercion -> LintM Coercion
lintCoercion (Var -> Coercion
CoVarCo (CoercionHole -> Var
coHoleCoVar CoercionHole
h)) }
lintAxioms :: Logger
-> DynFlags
-> SDoc
-> [CoAxiom Branched]
-> IO ()
lintAxioms :: Logger -> DynFlags -> SDoc -> [CoAxiom Branched] -> IO ()
lintAxioms Logger
logger DynFlags
dflags SDoc
what [CoAxiom Branched]
axioms =
Logger -> Bool -> SDoc -> SDoc -> WarnsAndErrs -> IO ()
displayLintResults Logger
logger Bool
True SDoc
what ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (CoAxiom Branched -> SDoc) -> [CoAxiom Branched] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CoAxiom Branched -> SDoc
forall (br :: BranchFlag). CoAxiom br -> SDoc
pprCoAxiom [CoAxiom Branched]
axioms) (WarnsAndErrs -> IO ()) -> WarnsAndErrs -> IO ()
forall a b. (a -> b) -> a -> b
$
DynFlags -> LintFlags -> [Var] -> LintM () -> WarnsAndErrs
forall a. DynFlags -> LintFlags -> [Var] -> LintM a -> WarnsAndErrs
initL DynFlags
dflags (DynFlags -> LintFlags
defaultLintFlags DynFlags
dflags) [] (LintM () -> WarnsAndErrs) -> LintM () -> WarnsAndErrs
forall a b. (a -> b) -> a -> b
$
do { (CoAxiom Branched -> LintM ()) -> [CoAxiom Branched] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CoAxiom Branched -> LintM ()
lint_axiom [CoAxiom Branched]
axioms
; let axiom_groups :: [NonEmpty (CoAxiom Branched)]
axiom_groups = (CoAxiom Branched -> TyCon)
-> [CoAxiom Branched] -> [NonEmpty (CoAxiom Branched)]
forall (f :: * -> *) b a.
(Foldable f, Eq b) =>
(a -> b) -> f a -> [NonEmpty a]
groupWith CoAxiom Branched -> TyCon
forall (br :: BranchFlag). CoAxiom br -> TyCon
coAxiomTyCon [CoAxiom Branched]
axioms
; (NonEmpty (CoAxiom Branched) -> LintM ())
-> [NonEmpty (CoAxiom Branched)] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty (CoAxiom Branched) -> LintM ()
lint_axiom_group [NonEmpty (CoAxiom Branched)]
axiom_groups }
lint_axiom :: CoAxiom Branched -> LintM ()
lint_axiom :: CoAxiom Branched -> LintM ()
lint_axiom ax :: CoAxiom Branched
ax@(CoAxiom { co_ax_tc :: forall (br :: BranchFlag). CoAxiom br -> TyCon
co_ax_tc = TyCon
tc, co_ax_branches :: forall (br :: BranchFlag). CoAxiom br -> Branches br
co_ax_branches = Branches Branched
branches
, co_ax_role :: forall (br :: BranchFlag). CoAxiom br -> Role
co_ax_role = Role
ax_role })
= LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (CoAxiom Branched -> LintLocInfo
InAxiom CoAxiom Branched
ax) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
do { (CoAxBranch -> LintM ()) -> [CoAxBranch] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TyCon -> CoAxBranch -> LintM ()
lint_branch TyCon
tc) [CoAxBranch]
branch_list
; LintM ()
extra_checks }
where
branch_list :: [CoAxBranch]
branch_list = Branches Branched -> [CoAxBranch]
forall (br :: BranchFlag). Branches br -> [CoAxBranch]
fromBranches Branches Branched
branches
extra_checks :: LintM ()
extra_checks
| TyCon -> Bool
isNewTyCon TyCon
tc
= do { CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
cab_tvs = [Var]
tvs
, cab_eta_tvs :: CoAxBranch -> [Var]
cab_eta_tvs = [Var]
eta_tvs
, cab_cvs :: CoAxBranch -> [Var]
cab_cvs = [Var]
cvs
, cab_roles :: CoAxBranch -> [Role]
cab_roles = [Role]
roles
, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs_tys }
<- case [CoAxBranch]
branch_list of
[CoAxBranch
branch] -> CoAxBranch -> LintM CoAxBranch
forall (m :: * -> *) a. Monad m => a -> m a
return CoAxBranch
branch
[CoAxBranch]
_ -> SDoc -> LintM CoAxBranch
forall a. SDoc -> LintM a
failWithL (String -> SDoc
text String
"multi-branch axiom with newtype")
; let ax_lhs :: Type
ax_lhs = [Var] -> Type -> Type
mkInfForAllTys [Var]
tvs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
lhs_tys
nt_tvs :: [Var]
nt_tvs = [Var] -> [Var] -> [Var]
forall b a. [b] -> [a] -> [a]
takeList [Var]
tvs (TyCon -> [Var]
tyConTyVars TyCon
tc)
nt_lhs :: Type
nt_lhs = [Var] -> Type -> Type
mkInfForAllTys [Var]
nt_tvs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
TyCon -> [Type] -> Type
mkTyConApp TyCon
tc ([Var] -> [Type]
mkTyVarTys [Var]
nt_tvs)
; Bool -> SDoc -> LintM ()
lintL (Type
ax_lhs Type -> Type -> Bool
`eqType` Type
nt_lhs)
(String -> SDoc
text String
"Newtype axiom LHS does not match newtype definition")
; Bool -> SDoc -> LintM ()
lintL ([Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
cvs)
(String -> SDoc
text String
"Newtype axiom binds coercion variables")
; Bool -> SDoc -> LintM ()
lintL ([Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
eta_tvs)
(String -> SDoc
text String
"Newtype axiom has eta-tvs")
; Bool -> SDoc -> LintM ()
lintL (Role
ax_role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Representational)
(String -> SDoc
text String
"Newtype axiom role not representational")
; Bool -> SDoc -> LintM ()
lintL ([Role]
roles [Role] -> [Var] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Var]
tvs)
(String -> SDoc
text String
"Newtype axiom roles list is the wrong length." SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"roles:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep ((Role -> SDoc) -> [Role] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Role]
roles))
; Bool -> SDoc -> LintM ()
lintL ([Role]
roles [Role] -> [Role] -> Bool
forall a. Eq a => a -> a -> Bool
== [Role] -> [Role] -> [Role]
forall b a. [b] -> [a] -> [a]
takeList [Role]
roles (TyCon -> [Role]
tyConRoles TyCon
tc))
([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Newtype axiom roles do not match newtype tycon's."
, String -> SDoc
text String
"axiom roles:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep ((Role -> SDoc) -> [Role] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Role]
roles)
, String -> SDoc
text String
"tycon roles:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep ((Role -> SDoc) -> [Role] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Role]
tyConRoles TyCon
tc)) ])
}
| TyCon -> Bool
isFamilyTyCon TyCon
tc
= do { if | TyCon -> Bool
isTypeFamilyTyCon TyCon
tc
-> Bool -> SDoc -> LintM ()
lintL (Role
ax_role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Nominal)
(String -> SDoc
text String
"type family axiom is not nominal")
| TyCon -> Bool
isDataFamilyTyCon TyCon
tc
-> Bool -> SDoc -> LintM ()
lintL (Role
ax_role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Representational)
(String -> SDoc
text String
"data family axiom is not representational")
| Bool
otherwise
-> SDoc -> LintM ()
addErrL (String -> SDoc
text String
"A family TyCon is neither a type family nor a data family:" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; (CoAxBranch -> LintM ()) -> [CoAxBranch] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TyCon -> CoAxBranch -> LintM ()
lint_family_branch TyCon
tc) [CoAxBranch]
branch_list }
| Bool
otherwise
= SDoc -> LintM ()
addErrL (String -> SDoc
text String
"Axiom tycon is neither a newtype nor a family.")
lint_branch :: TyCon -> CoAxBranch -> LintM ()
lint_branch :: TyCon -> CoAxBranch -> LintM ()
lint_branch TyCon
ax_tc (CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
cab_tvs = [Var]
tvs, cab_cvs :: CoAxBranch -> [Var]
cab_cvs = [Var]
cvs
, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs_args, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs })
= BindingSite -> [Var] -> ([Var] -> LintM ()) -> LintM ()
forall a. BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
lintBinders BindingSite
LambdaBind ([Var]
tvs [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
cvs) (([Var] -> LintM ()) -> LintM ())
-> ([Var] -> LintM ()) -> LintM ()
forall a b. (a -> b) -> a -> b
$ \[Var]
_ ->
do { let lhs :: Type
lhs = TyCon -> [Type] -> Type
mkTyConApp TyCon
ax_tc [Type]
lhs_args
; Type
lhs' <- Type -> LintM Type
lintType Type
lhs
; Type
rhs' <- Type -> LintM Type
lintType Type
rhs
; let lhs_kind :: Type
lhs_kind = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
lhs'
rhs_kind :: Type
rhs_kind = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
rhs'
; Bool -> SDoc -> LintM ()
lintL (Type
lhs_kind Type -> Type -> Bool
`eqType` Type
rhs_kind) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Inhomogeneous axiom")
Int
2 (String -> SDoc
text String
"lhs:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
lhs SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
lhs_kind SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"rhs:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs_kind) }
lint_family_branch :: TyCon -> CoAxBranch -> LintM ()
lint_family_branch :: TyCon -> CoAxBranch -> LintM ()
lint_family_branch TyCon
fam_tc br :: CoAxBranch
br@(CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
cab_tvs = [Var]
tvs
, cab_eta_tvs :: CoAxBranch -> [Var]
cab_eta_tvs = [Var]
eta_tvs
, cab_cvs :: CoAxBranch -> [Var]
cab_cvs = [Var]
cvs
, cab_roles :: CoAxBranch -> [Role]
cab_roles = [Role]
roles
, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs
, cab_incomps :: CoAxBranch -> [CoAxBranch]
cab_incomps = [CoAxBranch]
incomps })
= do { Bool -> SDoc -> LintM ()
lintL (TyCon -> Bool
isDataFamilyTyCon TyCon
fam_tc Bool -> Bool -> Bool
|| [Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
eta_tvs)
(String -> SDoc
text String
"Type family axiom has eta-tvs")
; Bool -> SDoc -> LintM ()
lintL ((Var -> Bool) -> [Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Var -> VarSet -> Bool
`elemVarSet` [Type] -> VarSet
tyCoVarsOfTypes [Type]
lhs) [Var]
tvs)
(String -> SDoc
text String
"Quantified variable in family axiom unused in LHS")
; Bool -> SDoc -> LintM ()
lintL ((Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTyFamFree [Type]
lhs)
(String -> SDoc
text String
"Type family application on LHS of family axiom")
; Bool -> SDoc -> LintM ()
lintL ((Role -> Bool) -> [Role] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Nominal) [Role]
roles)
(String -> SDoc
text String
"Non-nominal role in family axiom" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"roles:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep ((Role -> SDoc) -> [Role] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Role]
roles))
; Bool -> SDoc -> LintM ()
lintL ([Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
cvs)
(String -> SDoc
text String
"Coercion variables bound in family axiom")
; [CoAxBranch] -> (CoAxBranch -> LintM ()) -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [CoAxBranch]
incomps ((CoAxBranch -> LintM ()) -> LintM ())
-> (CoAxBranch -> LintM ()) -> LintM ()
forall a b. (a -> b) -> a -> b
$ \ CoAxBranch
br' ->
Bool -> SDoc -> LintM ()
lintL (Bool -> Bool
not (CoAxBranch -> CoAxBranch -> Bool
compatible_branches CoAxBranch
br CoAxBranch
br')) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Incorrect incompatible branch:" SDoc -> SDoc -> SDoc
<+> CoAxBranch -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoAxBranch
br' }
lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM ()
lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM ()
lint_axiom_group (CoAxiom Branched
_ :| []) = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lint_axiom_group (CoAxiom Branched
ax :| [CoAxiom Branched]
axs)
= do { Bool -> SDoc -> LintM ()
lintL (TyCon -> Bool
isOpenFamilyTyCon TyCon
tc)
(String -> SDoc
text String
"Non-open-family with multiple axioms")
; let all_pairs :: [(CoAxiom Branched, CoAxiom Branched)]
all_pairs = [ (CoAxiom Branched
ax1, CoAxiom Branched
ax2) | CoAxiom Branched
ax1 <- [CoAxiom Branched]
all_axs
, CoAxiom Branched
ax2 <- [CoAxiom Branched]
all_axs ]
; ((CoAxiom Branched, CoAxiom Branched) -> LintM ())
-> [(CoAxiom Branched, CoAxiom Branched)] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM ()
lint_axiom_pair TyCon
tc) [(CoAxiom Branched, CoAxiom Branched)]
all_pairs }
where
all_axs :: [CoAxiom Branched]
all_axs = CoAxiom Branched
ax CoAxiom Branched -> [CoAxiom Branched] -> [CoAxiom Branched]
forall a. a -> [a] -> [a]
: [CoAxiom Branched]
axs
tc :: TyCon
tc = CoAxiom Branched -> TyCon
forall (br :: BranchFlag). CoAxiom br -> TyCon
coAxiomTyCon CoAxiom Branched
ax
lint_axiom_pair :: TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM ()
lint_axiom_pair :: TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM ()
lint_axiom_pair TyCon
tc (CoAxiom Branched
ax1, CoAxiom Branched
ax2)
| Just br1 :: CoAxBranch
br1@(CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
cab_tvs = [Var]
tvs1
, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs1
, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs1 }) <- CoAxiom Branched -> Maybe CoAxBranch
forall (br :: BranchFlag). CoAxiom br -> Maybe CoAxBranch
coAxiomSingleBranch_maybe CoAxiom Branched
ax1
, Just br2 :: CoAxBranch
br2@(CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
cab_tvs = [Var]
tvs2
, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs2
, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs2 }) <- CoAxiom Branched -> Maybe CoAxBranch
forall (br :: BranchFlag). CoAxiom br -> Maybe CoAxBranch
coAxiomSingleBranch_maybe CoAxiom Branched
ax2
= Bool -> SDoc -> LintM ()
lintL (CoAxBranch -> CoAxBranch -> Bool
compatible_branches CoAxBranch
br1 CoAxBranch
br2) (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"Axioms", CoAxiom Branched -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoAxiom Branched
ax1, String -> SDoc
text String
"and", CoAxiom Branched -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoAxiom Branched
ax2
, String -> SDoc
text String
"are incompatible" ]
, String -> SDoc
text String
"tvs1 =" SDoc -> SDoc -> SDoc
<+> [Var] -> SDoc
pprTyVars [Var]
tvs1
, String -> SDoc
text String
"lhs1 =" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
lhs1)
, String -> SDoc
text String
"rhs1 =" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs1
, String -> SDoc
text String
"tvs2 =" SDoc -> SDoc -> SDoc
<+> [Var] -> SDoc
pprTyVars [Var]
tvs2
, String -> SDoc
text String
"lhs2 =" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
lhs2)
, String -> SDoc
text String
"rhs2 =" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs2 ]
| Bool
otherwise
= SDoc -> LintM ()
addErrL (String -> SDoc
text String
"Open type family axiom has more than one branch: either" SDoc -> SDoc -> SDoc
<+>
CoAxiom Branched -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoAxiom Branched
ax1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"or" SDoc -> SDoc -> SDoc
<+> CoAxiom Branched -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoAxiom Branched
ax2)
compatible_branches :: CoAxBranch -> CoAxBranch -> Bool
compatible_branches :: CoAxBranch -> CoAxBranch -> Bool
compatible_branches (CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
cab_tvs = [Var]
tvs1
, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs1
, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs1 })
(CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
cab_tvs = [Var]
tvs2
, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs2
, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs2 })
=
let in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet ([Var] -> VarSet
mkVarSet [Var]
tvs1)
subst0 :: TCvSubst
subst0 = InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope
(TCvSubst
subst, [Var]
_) = HasDebugCallStack => TCvSubst -> [Var] -> (TCvSubst, [Var])
TCvSubst -> [Var] -> (TCvSubst, [Var])
substTyVarBndrs TCvSubst
subst0 [Var]
tvs2
lhs2' :: [Type]
lhs2' = HasDebugCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTys TCvSubst
subst [Type]
lhs2
rhs2' :: Type
rhs2' = HasDebugCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
rhs2
in
case BindFun -> [Type] -> [Type] -> Maybe TCvSubst
tcUnifyTys BindFun
alwaysBindFun [Type]
lhs1 [Type]
lhs2' of
Just TCvSubst
unifying_subst -> HasDebugCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
unifying_subst Type
rhs1 Type -> Type -> Bool
`eqType`
HasDebugCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
unifying_subst Type
rhs2'
Maybe TCvSubst
Nothing -> Bool
True
data LintEnv
= LE { LintEnv -> LintFlags
le_flags :: LintFlags
, LintEnv -> [LintLocInfo]
le_loc :: [LintLocInfo]
, LintEnv -> TCvSubst
le_subst :: TCvSubst
, LintEnv -> VarEnv (Var, Type)
le_ids :: VarEnv (Id, LintedType)
, LintEnv -> VarSet
le_joins :: IdSet
, LintEnv -> DynFlags
le_dynflags :: DynFlags
, LintEnv -> NameEnv UsageEnv
le_ue_aliases :: NameEnv UsageEnv
}
data LintFlags
= LF { LintFlags -> Bool
lf_check_global_ids :: Bool
, LintFlags -> Bool
lf_check_inline_loop_breakers :: Bool
, LintFlags -> StaticPtrCheck
lf_check_static_ptrs :: StaticPtrCheck
, LintFlags -> Bool
lf_report_unsat_syns :: Bool
, LintFlags -> Bool
lf_check_linearity :: Bool
, LintFlags -> Bool
lf_check_fixed_rep :: Bool
}
data StaticPtrCheck
= AllowAnywhere
| AllowAtTopLevel
| RejectEverywhere
deriving StaticPtrCheck -> StaticPtrCheck -> Bool
(StaticPtrCheck -> StaticPtrCheck -> Bool)
-> (StaticPtrCheck -> StaticPtrCheck -> Bool) -> Eq StaticPtrCheck
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StaticPtrCheck -> StaticPtrCheck -> Bool
$c/= :: StaticPtrCheck -> StaticPtrCheck -> Bool
== :: StaticPtrCheck -> StaticPtrCheck -> Bool
$c== :: StaticPtrCheck -> StaticPtrCheck -> Bool
Eq
defaultLintFlags :: DynFlags -> LintFlags
defaultLintFlags :: DynFlags -> LintFlags
defaultLintFlags DynFlags
dflags = LF :: Bool -> Bool -> StaticPtrCheck -> Bool -> Bool -> Bool -> LintFlags
LF { lf_check_global_ids :: Bool
lf_check_global_ids = Bool
False
, lf_check_inline_loop_breakers :: Bool
lf_check_inline_loop_breakers = Bool
True
, lf_check_static_ptrs :: StaticPtrCheck
lf_check_static_ptrs = StaticPtrCheck
AllowAnywhere
, lf_check_linearity :: Bool
lf_check_linearity = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoLinearCoreLinting DynFlags
dflags
, lf_report_unsat_syns :: Bool
lf_report_unsat_syns = Bool
True
, lf_check_fixed_rep :: Bool
lf_check_fixed_rep = Bool
True
}
newtype LintM a =
LintM { LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
unLintM ::
LintEnv ->
WarnsAndErrs ->
(Maybe a, WarnsAndErrs) }
deriving (a -> LintM b -> LintM a
(a -> b) -> LintM a -> LintM b
(forall a b. (a -> b) -> LintM a -> LintM b)
-> (forall a b. a -> LintM b -> LintM a) -> Functor LintM
forall a b. a -> LintM b -> LintM a
forall a b. (a -> b) -> LintM a -> LintM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> LintM b -> LintM a
$c<$ :: forall a b. a -> LintM b -> LintM a
fmap :: (a -> b) -> LintM a -> LintM b
$cfmap :: forall a b. (a -> b) -> LintM a -> LintM b
Functor)
type WarnsAndErrs = (Bag SDoc, Bag SDoc)
instance Applicative LintM where
pure :: a -> LintM a
pure a
x = (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
-> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
_ WarnsAndErrs
errs -> (a -> Maybe a
forall a. a -> Maybe a
Just a
x, WarnsAndErrs
errs)
<*> :: LintM (a -> b) -> LintM a -> LintM b
(<*>) = LintM (a -> b) -> LintM a -> LintM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad LintM where
LintM a
m >>= :: LintM a -> (a -> LintM b) -> LintM b
>>= a -> LintM b
k = (LintEnv -> WarnsAndErrs -> (Maybe b, WarnsAndErrs)) -> LintM b
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM (\ LintEnv
env WarnsAndErrs
errs ->
let (Maybe a
res, WarnsAndErrs
errs') = LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
forall a.
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
unLintM LintM a
m LintEnv
env WarnsAndErrs
errs in
case Maybe a
res of
Just a
r -> LintM b -> LintEnv -> WarnsAndErrs -> (Maybe b, WarnsAndErrs)
forall a.
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
unLintM (a -> LintM b
k a
r) LintEnv
env WarnsAndErrs
errs'
Maybe a
Nothing -> (Maybe b
forall a. Maybe a
Nothing, WarnsAndErrs
errs'))
instance MonadFail LintM where
fail :: String -> LintM a
fail String
err = SDoc -> LintM a
forall a. SDoc -> LintM a
failWithL (String -> SDoc
text String
err)
instance HasDynFlags LintM where
getDynFlags :: LintM DynFlags
getDynFlags = (LintEnv -> WarnsAndErrs -> (Maybe DynFlags, WarnsAndErrs))
-> LintM DynFlags
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM (\ LintEnv
e WarnsAndErrs
errs -> (DynFlags -> Maybe DynFlags
forall a. a -> Maybe a
Just (LintEnv -> DynFlags
le_dynflags LintEnv
e), WarnsAndErrs
errs))
data LintLocInfo
= RhsOf Id
| OccOf Id
| LambdaBodyOf Id
| RuleOf Id
| UnfoldingOf Id
| BodyOfLetRec [Id]
| CaseAlt CoreAlt
| CasePat CoreAlt
| CaseTy CoreExpr
| IdTy Id
| AnExpr CoreExpr
| ImportedUnfolding SrcLoc
| TopLevelBindings
| InType Type
| InCo Coercion
| InAxiom (CoAxiom Branched)
initL :: DynFlags
-> LintFlags
-> [Var]
-> LintM a
-> WarnsAndErrs
initL :: DynFlags -> LintFlags -> [Var] -> LintM a -> WarnsAndErrs
initL DynFlags
dflags LintFlags
flags [Var]
vars LintM a
m
= case LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
forall a.
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
unLintM LintM a
m LintEnv
env (Bag SDoc
forall a. Bag a
emptyBag, Bag SDoc
forall a. Bag a
emptyBag) of
(Just a
_, WarnsAndErrs
errs) -> WarnsAndErrs
errs
(Maybe a
Nothing, errs :: WarnsAndErrs
errs@(Bag SDoc
_, Bag SDoc
e)) | Bool -> Bool
not (Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
e) -> WarnsAndErrs
errs
| Bool
otherwise -> String -> SDoc -> WarnsAndErrs
forall a. HasCallStack => String -> SDoc -> a
pprPanic (String
"Bug in Lint: a failure occurred " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"without reporting an error message") SDoc
empty
where
([Var]
tcvs, [Var]
ids) = (Var -> Bool) -> [Var] -> ([Var], [Var])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Var -> Bool
isTyCoVar [Var]
vars
env :: LintEnv
env = LE :: LintFlags
-> [LintLocInfo]
-> TCvSubst
-> VarEnv (Var, Type)
-> VarSet
-> DynFlags
-> NameEnv UsageEnv
-> LintEnv
LE { le_flags :: LintFlags
le_flags = LintFlags
flags
, le_subst :: TCvSubst
le_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet ([Var] -> VarSet
mkVarSet [Var]
tcvs))
, le_ids :: VarEnv (Var, Type)
le_ids = [(Var, (Var, Type))] -> VarEnv (Var, Type)
forall a. [(Var, a)] -> VarEnv a
mkVarEnv [(Var
id, (Var
id,Var -> Type
idType Var
id)) | Var
id <- [Var]
ids]
, le_joins :: VarSet
le_joins = VarSet
emptyVarSet
, le_loc :: [LintLocInfo]
le_loc = []
, le_dynflags :: DynFlags
le_dynflags = DynFlags
dflags
, le_ue_aliases :: NameEnv UsageEnv
le_ue_aliases = NameEnv UsageEnv
forall a. NameEnv a
emptyNameEnv }
setReportUnsat :: Bool -> LintM a -> LintM a
setReportUnsat :: Bool -> LintM a -> LintM a
setReportUnsat Bool
ru LintM a
thing_inside
= (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
-> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env WarnsAndErrs
errs ->
let env' :: LintEnv
env' = LintEnv
env { le_flags :: LintFlags
le_flags = (LintEnv -> LintFlags
le_flags LintEnv
env) { lf_report_unsat_syns :: Bool
lf_report_unsat_syns = Bool
ru } }
in LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
forall a.
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
unLintM LintM a
thing_inside LintEnv
env' WarnsAndErrs
errs
noFixedRuntimeRepChecks :: LintM a -> LintM a
noFixedRuntimeRepChecks :: LintM a -> LintM a
noFixedRuntimeRepChecks LintM a
thing_inside
= (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
-> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a b. (a -> b) -> a -> b
$ \LintEnv
env WarnsAndErrs
errs ->
let env' :: LintEnv
env' = LintEnv
env { le_flags :: LintFlags
le_flags = (LintEnv -> LintFlags
le_flags LintEnv
env) { lf_check_fixed_rep :: Bool
lf_check_fixed_rep = Bool
False } }
in LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
forall a.
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
unLintM LintM a
thing_inside LintEnv
env' WarnsAndErrs
errs
getLintFlags :: LintM LintFlags
getLintFlags :: LintM LintFlags
getLintFlags = (LintEnv -> WarnsAndErrs -> (Maybe LintFlags, WarnsAndErrs))
-> LintM LintFlags
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> (Maybe LintFlags, WarnsAndErrs))
-> LintM LintFlags)
-> (LintEnv -> WarnsAndErrs -> (Maybe LintFlags, WarnsAndErrs))
-> LintM LintFlags
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env WarnsAndErrs
errs -> (LintFlags -> Maybe LintFlags
forall a. a -> Maybe a
Just (LintEnv -> LintFlags
le_flags LintEnv
env), WarnsAndErrs
errs)
checkL :: Bool -> SDoc -> LintM ()
checkL :: Bool -> SDoc -> LintM ()
checkL Bool
True SDoc
_ = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkL Bool
False SDoc
msg = SDoc -> LintM ()
forall a. SDoc -> LintM a
failWithL SDoc
msg
lintL :: Bool -> SDoc -> LintM ()
lintL :: Bool -> SDoc -> LintM ()
lintL = Bool -> SDoc -> LintM ()
checkL
checkWarnL :: Bool -> SDoc -> LintM ()
checkWarnL :: Bool -> SDoc -> LintM ()
checkWarnL Bool
True SDoc
_ = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkWarnL Bool
False SDoc
msg = SDoc -> LintM ()
addWarnL SDoc
msg
failWithL :: SDoc -> LintM a
failWithL :: SDoc -> LintM a
failWithL SDoc
msg = (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
-> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env (Bag SDoc
warns,Bag SDoc
errs) ->
(Maybe a
forall a. Maybe a
Nothing, (Bag SDoc
warns, Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc
addMsg Bool
True LintEnv
env Bag SDoc
errs SDoc
msg))
addErrL :: SDoc -> LintM ()
addErrL :: SDoc -> LintM ()
addErrL SDoc
msg = (LintEnv -> WarnsAndErrs -> (Maybe (), WarnsAndErrs)) -> LintM ()
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> (Maybe (), WarnsAndErrs)) -> LintM ())
-> (LintEnv -> WarnsAndErrs -> (Maybe (), WarnsAndErrs))
-> LintM ()
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env (Bag SDoc
warns,Bag SDoc
errs) ->
(() -> Maybe ()
forall a. a -> Maybe a
Just (), (Bag SDoc
warns, Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc
addMsg Bool
True LintEnv
env Bag SDoc
errs SDoc
msg))
addWarnL :: SDoc -> LintM ()
addWarnL :: SDoc -> LintM ()
addWarnL SDoc
msg = (LintEnv -> WarnsAndErrs -> (Maybe (), WarnsAndErrs)) -> LintM ()
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> (Maybe (), WarnsAndErrs)) -> LintM ())
-> (LintEnv -> WarnsAndErrs -> (Maybe (), WarnsAndErrs))
-> LintM ()
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env (Bag SDoc
warns,Bag SDoc
errs) ->
(() -> Maybe ()
forall a. a -> Maybe a
Just (), (Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc
addMsg Bool
False LintEnv
env Bag SDoc
warns SDoc
msg, Bag SDoc
errs))
addMsg :: Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc
addMsg :: Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc
addMsg Bool
is_error LintEnv
env Bag SDoc
msgs SDoc
msg
= Bool -> SDoc -> Bag SDoc -> Bag SDoc
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([(SrcLoc, SDoc)] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [(SrcLoc, SDoc)]
loc_msgs) SDoc
msg (Bag SDoc -> Bag SDoc) -> Bag SDoc -> Bag SDoc
forall a b. (a -> b) -> a -> b
$
Bag SDoc
msgs Bag SDoc -> SDoc -> Bag SDoc
forall a. Bag a -> a -> Bag a
`snocBag` SDoc -> SDoc
mk_msg SDoc
msg
where
loc_msgs :: [(SrcLoc, SDoc)]
loc_msgs :: [(SrcLoc, SDoc)]
loc_msgs = (LintLocInfo -> (SrcLoc, SDoc))
-> [LintLocInfo] -> [(SrcLoc, SDoc)]
forall a b. (a -> b) -> [a] -> [b]
map LintLocInfo -> (SrcLoc, SDoc)
dumpLoc (LintEnv -> [LintLocInfo]
le_loc LintEnv
env)
cxt_doc :: SDoc
cxt_doc = [SDoc] -> SDoc
vcat [ [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> [SDoc]
forall a. [a] -> [a]
reverse ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ((SrcLoc, SDoc) -> SDoc) -> [(SrcLoc, SDoc)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SrcLoc, SDoc) -> SDoc
forall a b. (a, b) -> b
snd [(SrcLoc, SDoc)]
loc_msgs
, String -> SDoc
text String
"Substitution:" SDoc -> SDoc -> SDoc
<+> TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LintEnv -> TCvSubst
le_subst LintEnv
env) ]
context :: SDoc
context | Bool
is_error = SDoc
cxt_doc
| Bool
otherwise = SDoc -> SDoc
whenPprDebug SDoc
cxt_doc
msg_span :: SrcSpan
msg_span = case [ SrcSpan
span | (SrcLoc
loc,SDoc
_) <- [(SrcLoc, SDoc)]
loc_msgs
, let span :: SrcSpan
span = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
loc
, SrcSpan -> Bool
isGoodSrcSpan SrcSpan
span ] of
[] -> SrcSpan
noSrcSpan
(SrcSpan
s:[SrcSpan]
_) -> SrcSpan
s
!diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts (LintEnv -> DynFlags
le_dynflags LintEnv
env)
mk_msg :: SDoc -> SDoc
mk_msg SDoc
msg = MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage (DiagOpts -> DiagnosticReason -> MessageClass
mkMCDiagnostic DiagOpts
diag_opts DiagnosticReason
WarningWithoutFlag) SrcSpan
msg_span
(SDoc
msg SDoc -> SDoc -> SDoc
$$ SDoc
context)
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc LintLocInfo
extra_loc LintM a
m
= (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
-> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env WarnsAndErrs
errs ->
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
forall a.
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
unLintM LintM a
m (LintEnv
env { le_loc :: [LintLocInfo]
le_loc = LintLocInfo
extra_loc LintLocInfo -> [LintLocInfo] -> [LintLocInfo]
forall a. a -> [a] -> [a]
: LintEnv -> [LintLocInfo]
le_loc LintEnv
env }) WarnsAndErrs
errs
inCasePat :: LintM Bool
inCasePat :: LintM Bool
inCasePat = (LintEnv -> WarnsAndErrs -> (Maybe Bool, WarnsAndErrs))
-> LintM Bool
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> (Maybe Bool, WarnsAndErrs))
-> LintM Bool)
-> (LintEnv -> WarnsAndErrs -> (Maybe Bool, WarnsAndErrs))
-> LintM Bool
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env WarnsAndErrs
errs -> (Bool -> Maybe Bool
forall a. a -> Maybe a
Just (LintEnv -> Bool
is_case_pat LintEnv
env), WarnsAndErrs
errs)
where
is_case_pat :: LintEnv -> Bool
is_case_pat (LE { le_loc :: LintEnv -> [LintLocInfo]
le_loc = CasePat {} : [LintLocInfo]
_ }) = Bool
True
is_case_pat LintEnv
_other = Bool
False
addInScopeId :: Id -> LintedType -> LintM a -> LintM a
addInScopeId :: Var -> Type -> LintM a -> LintM a
addInScopeId Var
id Type
linted_ty LintM a
m
= (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
-> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a b. (a -> b) -> a -> b
$ \ env :: LintEnv
env@(LE { le_ids :: LintEnv -> VarEnv (Var, Type)
le_ids = VarEnv (Var, Type)
id_set, le_joins :: LintEnv -> VarSet
le_joins = VarSet
join_set }) WarnsAndErrs
errs ->
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
forall a.
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
unLintM LintM a
m (LintEnv
env { le_ids :: VarEnv (Var, Type)
le_ids = VarEnv (Var, Type) -> Var -> (Var, Type) -> VarEnv (Var, Type)
forall a. VarEnv a -> Var -> a -> VarEnv a
extendVarEnv VarEnv (Var, Type)
id_set Var
id (Var
id, Type
linted_ty)
, le_joins :: VarSet
le_joins = VarSet -> VarSet
add_joins VarSet
join_set }) WarnsAndErrs
errs
where
add_joins :: VarSet -> VarSet
add_joins VarSet
join_set
| Var -> Bool
isJoinId Var
id = VarSet -> Var -> VarSet
extendVarSet VarSet
join_set Var
id
| Bool
otherwise = VarSet -> Var -> VarSet
delVarSet VarSet
join_set Var
id
getInScopeIds :: LintM (VarEnv (Id,LintedType))
getInScopeIds :: LintM (VarEnv (Var, Type))
getInScopeIds = (LintEnv
-> WarnsAndErrs -> (Maybe (VarEnv (Var, Type)), WarnsAndErrs))
-> LintM (VarEnv (Var, Type))
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM (\LintEnv
env WarnsAndErrs
errs -> (VarEnv (Var, Type) -> Maybe (VarEnv (Var, Type))
forall a. a -> Maybe a
Just (LintEnv -> VarEnv (Var, Type)
le_ids LintEnv
env), WarnsAndErrs
errs))
extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a
extendTvSubstL :: Var -> Type -> LintM a -> LintM a
extendTvSubstL Var
tv Type
ty LintM a
m
= (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
-> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env WarnsAndErrs
errs ->
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
forall a.
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
unLintM LintM a
m (LintEnv
env { le_subst :: TCvSubst
le_subst = TCvSubst -> Var -> Type -> TCvSubst
Type.extendTvSubst (LintEnv -> TCvSubst
le_subst LintEnv
env) Var
tv Type
ty }) WarnsAndErrs
errs
updateTCvSubst :: TCvSubst -> LintM a -> LintM a
updateTCvSubst :: TCvSubst -> LintM a -> LintM a
updateTCvSubst TCvSubst
subst' LintM a
m
= (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
-> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env WarnsAndErrs
errs -> LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
forall a.
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
unLintM LintM a
m (LintEnv
env { le_subst :: TCvSubst
le_subst = TCvSubst
subst' }) WarnsAndErrs
errs
markAllJoinsBad :: LintM a -> LintM a
markAllJoinsBad :: LintM a -> LintM a
markAllJoinsBad LintM a
m
= (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
-> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env WarnsAndErrs
errs -> LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
forall a.
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
unLintM LintM a
m (LintEnv
env { le_joins :: VarSet
le_joins = VarSet
emptyVarSet }) WarnsAndErrs
errs
markAllJoinsBadIf :: Bool -> LintM a -> LintM a
markAllJoinsBadIf :: Bool -> LintM a -> LintM a
markAllJoinsBadIf Bool
True LintM a
m = LintM a -> LintM a
forall a. LintM a -> LintM a
markAllJoinsBad LintM a
m
markAllJoinsBadIf Bool
False LintM a
m = LintM a
m
getValidJoins :: LintM IdSet
getValidJoins :: LintM VarSet
getValidJoins = (LintEnv -> WarnsAndErrs -> (Maybe VarSet, WarnsAndErrs))
-> LintM VarSet
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM (\ LintEnv
env WarnsAndErrs
errs -> (VarSet -> Maybe VarSet
forall a. a -> Maybe a
Just (LintEnv -> VarSet
le_joins LintEnv
env), WarnsAndErrs
errs))
getTCvSubst :: LintM TCvSubst
getTCvSubst :: LintM TCvSubst
getTCvSubst = (LintEnv -> WarnsAndErrs -> (Maybe TCvSubst, WarnsAndErrs))
-> LintM TCvSubst
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM (\ LintEnv
env WarnsAndErrs
errs -> (TCvSubst -> Maybe TCvSubst
forall a. a -> Maybe a
Just (LintEnv -> TCvSubst
le_subst LintEnv
env), WarnsAndErrs
errs))
getUEAliases :: LintM (NameEnv UsageEnv)
getUEAliases :: LintM (NameEnv UsageEnv)
getUEAliases = (LintEnv
-> WarnsAndErrs -> (Maybe (NameEnv UsageEnv), WarnsAndErrs))
-> LintM (NameEnv UsageEnv)
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM (\ LintEnv
env WarnsAndErrs
errs -> (NameEnv UsageEnv -> Maybe (NameEnv UsageEnv)
forall a. a -> Maybe a
Just (LintEnv -> NameEnv UsageEnv
le_ue_aliases LintEnv
env), WarnsAndErrs
errs))
getInScope :: LintM InScopeSet
getInScope :: LintM InScopeSet
getInScope = (LintEnv -> WarnsAndErrs -> (Maybe InScopeSet, WarnsAndErrs))
-> LintM InScopeSet
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM (\ LintEnv
env WarnsAndErrs
errs -> (InScopeSet -> Maybe InScopeSet
forall a. a -> Maybe a
Just (TCvSubst -> InScopeSet
getTCvInScope (TCvSubst -> InScopeSet) -> TCvSubst -> InScopeSet
forall a b. (a -> b) -> a -> b
$ LintEnv -> TCvSubst
le_subst LintEnv
env), WarnsAndErrs
errs))
lookupIdInScope :: Id -> LintM (Id, LintedType)
lookupIdInScope :: Var -> LintM (Var, Type)
lookupIdInScope Var
id_occ
= do { VarEnv (Var, Type)
in_scope_ids <- LintM (VarEnv (Var, Type))
getInScopeIds
; case VarEnv (Var, Type) -> Var -> Maybe (Var, Type)
forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv VarEnv (Var, Type)
in_scope_ids Var
id_occ of
Just (Var
id_bndr, Type
linted_ty)
-> do { Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not (Var -> Bool
bad_global Var
id_bndr)) SDoc
global_in_scope
; (Var, Type) -> LintM (Var, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Var
id_bndr, Type
linted_ty) }
Maybe (Var, Type)
Nothing -> do { Bool -> SDoc -> LintM ()
checkL (Bool -> Bool
not Bool
is_local) SDoc
local_out_of_scope
; (Var, Type) -> LintM (Var, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Var
id_occ, Var -> Type
idType Var
id_occ) } }
where
is_local :: Bool
is_local = Var -> Bool
mustHaveLocalBinding Var
id_occ
local_out_of_scope :: SDoc
local_out_of_scope = String -> SDoc
text String
"Out of scope:" SDoc -> SDoc -> SDoc
<+> BindingSite -> Var -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Var
id_occ
global_in_scope :: SDoc
global_in_scope = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Occurrence is GlobalId, but binding is LocalId")
Int
2 (BindingSite -> Var -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Var
id_occ)
bad_global :: Var -> Bool
bad_global Var
id_bnd = Var -> Bool
isGlobalId Var
id_occ
Bool -> Bool -> Bool
&& Var -> Bool
isLocalId Var
id_bnd
Bool -> Bool -> Bool
&& Bool -> Bool
not (Var -> Bool
forall thing. NamedThing thing => thing -> Bool
isWiredIn Var
id_occ)
lookupJoinId :: Id -> LintM (Maybe JoinArity)
lookupJoinId :: Var -> LintM (Maybe Int)
lookupJoinId Var
id
= do { VarSet
join_set <- LintM VarSet
getValidJoins
; case VarSet -> Var -> Maybe Var
lookupVarSet VarSet
join_set Var
id of
Just Var
id' -> Maybe Int -> LintM (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Maybe Int
isJoinId_maybe Var
id')
Maybe Var
Nothing -> Maybe Int -> LintM (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing }
addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a
addAliasUE :: Var -> UsageEnv -> LintM a -> LintM a
addAliasUE Var
id UsageEnv
ue LintM a
thing_inside = (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a.
(LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
LintM ((LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a)
-> (LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)) -> LintM a
forall a b. (a -> b) -> a -> b
$ \ LintEnv
env WarnsAndErrs
errs ->
let new_ue_aliases :: NameEnv UsageEnv
new_ue_aliases =
NameEnv UsageEnv -> Name -> UsageEnv -> NameEnv UsageEnv
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv (LintEnv -> NameEnv UsageEnv
le_ue_aliases LintEnv
env) (Var -> Name
forall a. NamedThing a => a -> Name
getName Var
id) UsageEnv
ue
in
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
forall a.
LintM a -> LintEnv -> WarnsAndErrs -> (Maybe a, WarnsAndErrs)
unLintM LintM a
thing_inside (LintEnv
env { le_ue_aliases :: NameEnv UsageEnv
le_ue_aliases = NameEnv UsageEnv
new_ue_aliases }) WarnsAndErrs
errs
varCallSiteUsage :: Id -> LintM UsageEnv
varCallSiteUsage :: Var -> LintM UsageEnv
varCallSiteUsage Var
id =
do NameEnv UsageEnv
m <- LintM (NameEnv UsageEnv)
getUEAliases
UsageEnv -> LintM UsageEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (UsageEnv -> LintM UsageEnv) -> UsageEnv -> LintM UsageEnv
forall a b. (a -> b) -> a -> b
$ case NameEnv UsageEnv -> Name -> Maybe UsageEnv
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv UsageEnv
m (Var -> Name
forall a. NamedThing a => a -> Name
getName Var
id) of
Maybe UsageEnv
Nothing -> Var -> Type -> UsageEnv
forall n. NamedThing n => n -> Type -> UsageEnv
unitUE Var
id Type
One
Just UsageEnv
id_ue -> UsageEnv
id_ue
ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM ()
ensureEqTys :: Type -> Type -> SDoc -> LintM ()
ensureEqTys Type
ty1 Type
ty2 SDoc
msg = Bool -> SDoc -> LintM ()
lintL (Type
ty1 Type -> Type -> Bool
`eqType` Type
ty2) SDoc
msg
ensureSubUsage :: Usage -> Mult -> SDoc -> LintM ()
ensureSubUsage :: Usage -> Type -> SDoc -> LintM ()
ensureSubUsage Usage
Bottom Type
_ SDoc
_ = () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ensureSubUsage Usage
Zero Type
described_mult SDoc
err_msg = Type -> Type -> SDoc -> LintM ()
ensureSubMult Type
Many Type
described_mult SDoc
err_msg
ensureSubUsage (MUsage Type
m) Type
described_mult SDoc
err_msg = Type -> Type -> SDoc -> LintM ()
ensureSubMult Type
m Type
described_mult SDoc
err_msg
ensureSubMult :: Mult -> Mult -> SDoc -> LintM ()
ensureSubMult :: Type -> Type -> SDoc -> LintM ()
ensureSubMult Type
actual_usage Type
described_usage SDoc
err_msg = do
LintFlags
flags <- LintM LintFlags
getLintFlags
Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LintFlags -> Bool
lf_check_linearity LintFlags
flags) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$ case Type
actual_usage' Type -> Type -> IsSubmult
`submult` Type
described_usage' of
IsSubmult
Submult -> () -> LintM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
IsSubmult
Unknown -> case Type -> Maybe (Type, Type)
isMultMul Type
actual_usage' of
Just (Type
m1, Type
m2) -> Type -> Type -> SDoc -> LintM ()
ensureSubMult Type
m1 Type
described_usage' SDoc
err_msg LintM () -> LintM () -> LintM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
Type -> Type -> SDoc -> LintM ()
ensureSubMult Type
m2 Type
described_usage' SDoc
err_msg
Maybe (Type, Type)
Nothing -> Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Type
actual_usage' Type -> Type -> Bool
`eqType` Type
described_usage')) (SDoc -> LintM ()
addErrL SDoc
err_msg)
where actual_usage' :: Type
actual_usage' = Type -> Type
normalize Type
actual_usage
described_usage' :: Type
described_usage' = Type -> Type
normalize Type
described_usage
normalize :: Mult -> Mult
normalize :: Type -> Type
normalize Type
m = case Type -> Maybe (Type, Type)
isMultMul Type
m of
Just (Type
m1, Type
m2) -> Type -> Type -> Type
mkMultMul (Type -> Type
normalize Type
m1) (Type -> Type
normalize Type
m2)
Maybe (Type, Type)
Nothing -> Type
m
lintRole :: Outputable thing
=> thing
-> Role
-> Role
-> LintM ()
lintRole :: thing -> Role -> Role -> LintM ()
lintRole thing
co Role
r1 Role
r2
= Bool -> SDoc -> LintM ()
lintL (Role
r1 Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
r2)
(String -> SDoc
text String
"Role incompatibility: expected" SDoc -> SDoc -> SDoc
<+> Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr Role
r1 SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"got" SDoc -> SDoc -> SDoc
<+> Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr Role
r2 SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"in" SDoc -> SDoc -> SDoc
<+> thing -> SDoc
forall a. Outputable a => a -> SDoc
ppr thing
co)
dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
dumpLoc (RhsOf Var
v)
= (Var -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Var
v, String -> SDoc
text String
"In the RHS of" SDoc -> SDoc -> SDoc
<+> [Var] -> SDoc
pp_binders [Var
v])
dumpLoc (OccOf Var
v)
= (Var -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Var
v, String -> SDoc
text String
"In an occurrence of" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
pp_binder Var
v)
dumpLoc (LambdaBodyOf Var
b)
= (Var -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Var
b, String -> SDoc
text String
"In the body of lambda with binder" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
pp_binder Var
b)
dumpLoc (RuleOf Var
b)
= (Var -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Var
b, String -> SDoc
text String
"In a rule attached to" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
pp_binder Var
b)
dumpLoc (UnfoldingOf Var
b)
= (Var -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Var
b, String -> SDoc
text String
"In the unfolding of" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
pp_binder Var
b)
dumpLoc (BodyOfLetRec [])
= (SrcLoc
noSrcLoc, String -> SDoc
text String
"In body of a letrec with no binders")
dumpLoc (BodyOfLetRec bs :: [Var]
bs@(Var
_:[Var]
_))
= ( Var -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc ([Var] -> Var
forall a. [a] -> a
head [Var]
bs), String -> SDoc
text String
"In the body of letrec with binders" SDoc -> SDoc -> SDoc
<+> [Var] -> SDoc
pp_binders [Var]
bs)
dumpLoc (AnExpr CoreExpr
e)
= (SrcLoc
noSrcLoc, String -> SDoc
text String
"In the expression:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e)
dumpLoc (CaseAlt (Alt AltCon
con [Var]
args CoreExpr
_))
= (SrcLoc
noSrcLoc, String -> SDoc
text String
"In a case alternative:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
con SDoc -> SDoc -> SDoc
<+> [Var] -> SDoc
pp_binders [Var]
args))
dumpLoc (CasePat (Alt AltCon
con [Var]
args CoreExpr
_))
= (SrcLoc
noSrcLoc, String -> SDoc
text String
"In the pattern of a case alternative:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
con SDoc -> SDoc -> SDoc
<+> [Var] -> SDoc
pp_binders [Var]
args))
dumpLoc (CaseTy CoreExpr
scrut)
= (SrcLoc
noSrcLoc, SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the result-type of a case with scrutinee:")
Int
2 (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
scrut))
dumpLoc (IdTy Var
b)
= (Var -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Var
b, String -> SDoc
text String
"In the type of a binder:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
b)
dumpLoc (ImportedUnfolding SrcLoc
locn)
= (SrcLoc
locn, String -> SDoc
text String
"In an imported unfolding")
dumpLoc LintLocInfo
TopLevelBindings
= (SrcLoc
noSrcLoc, SDoc
Outputable.empty)
dumpLoc (InType Type
ty)
= (SrcLoc
noSrcLoc, String -> SDoc
text String
"In the type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty))
dumpLoc (InCo Coercion
co)
= (SrcLoc
noSrcLoc, String -> SDoc
text String
"In the coercion" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co))
dumpLoc (InAxiom CoAxiom Branched
ax)
= (Name -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
ax_name, String -> SDoc
text String
"In the coercion axiom" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
ax_name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> SDoc
pp_ax)
where
CoAxiom { co_ax_name :: forall (br :: BranchFlag). CoAxiom br -> Name
co_ax_name = Name
ax_name
, co_ax_tc :: forall (br :: BranchFlag). CoAxiom br -> TyCon
co_ax_tc = TyCon
tc
, co_ax_role :: forall (br :: BranchFlag). CoAxiom br -> Role
co_ax_role = Role
ax_role
, co_ax_branches :: forall (br :: BranchFlag). CoAxiom br -> Branches br
co_ax_branches = Branches Branched
branches } = CoAxiom Branched
ax
branch_list :: [CoAxBranch]
branch_list = Branches Branched -> [CoAxBranch]
forall (br :: BranchFlag). Branches br -> [CoAxBranch]
fromBranches Branches Branched
branches
pp_ax :: SDoc
pp_ax
| [CoAxBranch
branch] <- [CoAxBranch]
branch_list
= CoAxBranch -> SDoc
pp_branch CoAxBranch
branch
| Bool
otherwise
= SDoc -> SDoc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ((CoAxBranch -> SDoc) -> [CoAxBranch] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CoAxBranch -> SDoc
pp_branch [CoAxBranch]
branch_list)
pp_branch :: CoAxBranch -> SDoc
pp_branch (CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
cab_tvs = [Var]
tvs
, cab_cvs :: CoAxBranch -> [Var]
cab_cvs = [Var]
cvs
, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs_tys
, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs_ty })
= [SDoc] -> SDoc
sep [ SDoc -> SDoc
brackets ((Var -> SDoc) -> [Var] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Var -> SDoc
pprTyVar ([Var]
tvs [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
cvs)) SDoc -> SDoc -> SDoc
<> SDoc
dot
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
lhs_tys)
, String -> SDoc
text String
"~_" SDoc -> SDoc -> SDoc
<> Role -> SDoc
pp_role Role
ax_role
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty ]
pp_role :: Role -> SDoc
pp_role Role
Nominal = String -> SDoc
text String
"N"
pp_role Role
Representational = String -> SDoc
text String
"R"
pp_role Role
Phantom = String -> SDoc
text String
"P"
pp_binders :: [Var] -> SDoc
pp_binders :: [Var] -> SDoc
pp_binders [Var]
bs = [SDoc] -> SDoc
sep (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ((Var -> SDoc) -> [Var] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Var -> SDoc
pp_binder [Var]
bs))
pp_binder :: Var -> SDoc
pp_binder :: Var -> SDoc
pp_binder Var
b | Var -> Bool
isId Var
b = [SDoc] -> SDoc
hsep [Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
b, SDoc
dcolon, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
idType Var
b)]
| Bool
otherwise = [SDoc] -> SDoc
hsep [Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
b, SDoc
dcolon, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
tyVarKind Var
b)]
mkDefaultArgsMsg :: [Var] -> SDoc
mkDefaultArgsMsg :: [Var] -> SDoc
mkDefaultArgsMsg [Var]
args
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"DEFAULT case with binders")
Int
4 ([Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
args)
mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc
mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc
mkCaseAltMsg CoreExpr
e Type
ty1 Type
ty2
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Type of case alternatives not the same as the annotation on case:")
Int
4 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Actual type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty1,
String -> SDoc
text String
"Annotation on case:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2,
String -> SDoc
text String
"Alt Rhs:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e ])
mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> SDoc
mkScrutMsg :: Var -> Type -> Type -> TCvSubst -> SDoc
mkScrutMsg Var
var Type
var_ty Type
scrut_ty TCvSubst
subst
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Result binder in case doesn't match scrutinee:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
var,
String -> SDoc
text String
"Result binder type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
var_ty,
String -> SDoc
text String
"Scrutinee type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
scrut_ty,
[SDoc] -> SDoc
hsep [String -> SDoc
text String
"Current TCv subst", TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst]]
mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc
mkNonDefltMsg :: CoreExpr -> SDoc
mkNonDefltMsg CoreExpr
e
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Case expression with DEFAULT not at the beginning") Int
4 (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e)
mkNonIncreasingAltsMsg :: CoreExpr -> SDoc
mkNonIncreasingAltsMsg CoreExpr
e
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Case expression with badly-ordered alternatives") Int
4 (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e)
nonExhaustiveAltsMsg :: CoreExpr -> SDoc
nonExhaustiveAltsMsg :: CoreExpr -> SDoc
nonExhaustiveAltsMsg CoreExpr
e
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Case expression with non-exhaustive alternatives") Int
4 (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e)
mkBadConMsg :: TyCon -> DataCon -> SDoc
mkBadConMsg :: TyCon -> DataCon -> SDoc
mkBadConMsg TyCon
tycon DataCon
datacon
= [SDoc] -> SDoc
vcat [
String -> SDoc
text String
"In a case alternative, data constructor isn't in scrutinee type:",
String -> SDoc
text String
"Scrutinee type constructor:" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon,
String -> SDoc
text String
"Data con:" SDoc -> SDoc -> SDoc
<+> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
datacon
]
mkBadPatMsg :: Type -> Type -> SDoc
mkBadPatMsg :: Type -> Type -> SDoc
mkBadPatMsg Type
con_result_ty Type
scrut_ty
= [SDoc] -> SDoc
vcat [
String -> SDoc
text String
"In a case alternative, pattern result type doesn't match scrutinee type:",
String -> SDoc
text String
"Pattern result type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
con_result_ty,
String -> SDoc
text String
"Scrutinee type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
scrut_ty
]
integerScrutinisedMsg :: SDoc
integerScrutinisedMsg :: SDoc
integerScrutinisedMsg
= String -> SDoc
text String
"In a LitAlt, the literal is lifted (probably Integer)"
mkBadAltMsg :: Type -> CoreAlt -> SDoc
mkBadAltMsg :: Type -> Alt Var -> SDoc
mkBadAltMsg Type
scrut_ty Alt Var
alt
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Data alternative when scrutinee is not a tycon application",
String -> SDoc
text String
"Scrutinee type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
scrut_ty,
String -> SDoc
text String
"Alternative:" SDoc -> SDoc -> SDoc
<+> Alt Var -> SDoc
forall a. OutputableBndr a => Alt a -> SDoc
pprCoreAlt Alt Var
alt ]
mkNewTyDataConAltMsg :: Type -> CoreAlt -> SDoc
mkNewTyDataConAltMsg :: Type -> Alt Var -> SDoc
mkNewTyDataConAltMsg Type
scrut_ty Alt Var
alt
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Data alternative for newtype datacon",
String -> SDoc
text String
"Scrutinee type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
scrut_ty,
String -> SDoc
text String
"Alternative:" SDoc -> SDoc -> SDoc
<+> Alt Var -> SDoc
forall a. OutputableBndr a => Alt a -> SDoc
pprCoreAlt Alt Var
alt ]
mkAppMsg :: Type -> Type -> CoreExpr -> SDoc
mkAppMsg :: Type -> Type -> CoreExpr -> SDoc
mkAppMsg Type
expected_arg_ty Type
actual_arg_ty CoreExpr
arg
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Argument value doesn't match argument type:",
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Expected arg type:") Int
4 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
expected_arg_ty),
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Actual arg type:") Int
4 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
actual_arg_ty),
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Arg:") Int
4 (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
arg)]
mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc
mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc
mkNonFunAppMsg Type
fun_ty Type
arg_ty CoreExpr
arg
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Non-function type in function position",
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Fun type:") Int
4 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun_ty),
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Arg type:") Int
4 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty),
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Arg:") Int
4 (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
arg)]
mkLetErr :: TyVar -> CoreExpr -> SDoc
mkLetErr :: Var -> CoreExpr -> SDoc
mkLetErr Var
bndr CoreExpr
rhs
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Bad `let' binding:",
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Variable:")
Int
4 (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
bndr SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
bndr)),
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Rhs:")
Int
4 (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
rhs)]
mkTyAppMsg :: Type -> Type -> SDoc
mkTyAppMsg :: Type -> Type -> SDoc
mkTyAppMsg Type
ty Type
arg_ty
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Illegal type application:",
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Exp type:")
Int
4 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty)),
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Arg type:")
Int
4 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
arg_ty))]
emptyRec :: CoreExpr -> SDoc
emptyRec :: CoreExpr -> SDoc
emptyRec CoreExpr
e = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Empty Rec binding:") Int
2 (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e)
mkRhsMsg :: Id -> SDoc -> Type -> SDoc
mkRhsMsg :: Var -> SDoc -> Type -> SDoc
mkRhsMsg Var
binder SDoc
what Type
ty
= [SDoc] -> SDoc
vcat
[[SDoc] -> SDoc
hsep [String -> SDoc
text String
"The type of this binder doesn't match the type of its" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<> SDoc
colon,
Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
binder],
[SDoc] -> SDoc
hsep [String -> SDoc
text String
"Binder's type:", Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
idType Var
binder)],
[SDoc] -> SDoc
hsep [String -> SDoc
text String
"Rhs type:", Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty]]
badBndrTyMsg :: Id -> SDoc -> SDoc
badBndrTyMsg :: Var -> SDoc -> SDoc
badBndrTyMsg Var
binder SDoc
what
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"The type of this binder is" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
binder
, String -> SDoc
text String
"Binder's type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
idType Var
binder) ]
mkNonTopExportedMsg :: Id -> SDoc
mkNonTopExportedMsg :: Var -> SDoc
mkNonTopExportedMsg Var
binder
= [SDoc] -> SDoc
hsep [String -> SDoc
text String
"Non-top-level binder is marked as exported:", Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
binder]
mkNonTopExternalNameMsg :: Id -> SDoc
mkNonTopExternalNameMsg :: Var -> SDoc
mkNonTopExternalNameMsg Var
binder
= [SDoc] -> SDoc
hsep [String -> SDoc
text String
"Non-top-level binder has an external name:", Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
binder]
mkTopNonLitStrMsg :: Id -> SDoc
mkTopNonLitStrMsg :: Var -> SDoc
mkTopNonLitStrMsg Var
binder
= [SDoc] -> SDoc
hsep [String -> SDoc
text String
"Top-level Addr# binder has a non-literal rhs:", Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
binder]
mkKindErrMsg :: TyVar -> Type -> SDoc
mkKindErrMsg :: Var -> Type -> SDoc
mkKindErrMsg Var
tyvar Type
arg_ty
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Kinds don't match in type application:",
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Type variable:")
Int
4 (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
tyvar SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
tyVarKind Var
tyvar)),
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Arg type:")
Int
4 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
arg_ty))]
mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc
mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc
mkCastErr CoreExpr
expr = String -> String -> SDoc -> Coercion -> Type -> Type -> SDoc
mk_cast_err String
"expression" String
"type" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr)
mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> SDoc
mkCastTyErr :: Type -> Coercion -> Type -> Type -> SDoc
mkCastTyErr Type
ty = String -> String -> SDoc -> Coercion -> Type -> Type -> SDoc
mk_cast_err String
"type" String
"kind" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
mk_cast_err :: String
-> String
-> SDoc
-> Coercion -> Type -> Type -> SDoc
mk_cast_err :: String -> String -> SDoc -> Coercion -> Type -> Type -> SDoc
mk_cast_err String
thing_str String
co_str SDoc
pp_thing Coercion
co Type
from_ty Type
thing_ty
= [SDoc] -> SDoc
vcat [SDoc
from_msg SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"of Cast differs from" SDoc -> SDoc -> SDoc
<+> SDoc
co_msg
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"of" SDoc -> SDoc -> SDoc
<+> SDoc
enclosed_msg,
SDoc
from_msg SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
from_ty,
String -> SDoc
text (String -> String
capitalise String
co_str) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"of" SDoc -> SDoc -> SDoc
<+> SDoc
enclosed_msg SDoc -> SDoc -> SDoc
<> SDoc
colon
SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
thing_ty,
String -> SDoc
text String
"Actual" SDoc -> SDoc -> SDoc
<+> SDoc
enclosed_msg SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> SDoc
pp_thing,
String -> SDoc
text String
"Coercion used in cast:" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co
]
where
co_msg, from_msg, enclosed_msg :: SDoc
co_msg :: SDoc
co_msg = String -> SDoc
text String
co_str
from_msg :: SDoc
from_msg = String -> SDoc
text String
"From-" SDoc -> SDoc -> SDoc
<> SDoc
co_msg
enclosed_msg :: SDoc
enclosed_msg = String -> SDoc
text String
"enclosed" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
thing_str
mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc
mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc
mkBadUnivCoMsg LeftOrRight
lr Coercion
co
= String -> SDoc
text String
"Kind mismatch on the" SDoc -> SDoc -> SDoc
<+> LeftOrRight -> SDoc
pprLeftOrRight LeftOrRight
lr SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"side of a UnivCo:" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co
mkBadProofIrrelMsg :: Type -> Coercion -> SDoc
mkBadProofIrrelMsg :: Type -> Coercion -> SDoc
mkBadProofIrrelMsg Type
ty Coercion
co
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Found a non-coercion in a proof-irrelevance UnivCo:")
Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty
, String -> SDoc
text String
"co:" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co ])
mkBadTyVarMsg :: Var -> SDoc
mkBadTyVarMsg :: Var -> SDoc
mkBadTyVarMsg Var
tv
= String -> SDoc
text String
"Non-tyvar used in TyVarTy:"
SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
tv SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
tv)
mkBadJoinBindMsg :: Var -> SDoc
mkBadJoinBindMsg :: Var -> SDoc
mkBadJoinBindMsg Var
var
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Bad join point binding:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
var
, String -> SDoc
text String
"Join points can be bound only by a non-top-level let" ]
mkInvalidJoinPointMsg :: Var -> Type -> SDoc
mkInvalidJoinPointMsg :: Var -> Type -> SDoc
mkInvalidJoinPointMsg Var
var Type
ty
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Join point has invalid type:")
Int
2 (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
var SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc
mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc
mkBadJoinArityMsg Var
var Int
ar Int
n CoreExpr
rhs
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Join point has too few lambdas",
String -> SDoc
text String
"Join var:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
var,
String -> SDoc
text String
"Join arity:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
ar,
String -> SDoc
text String
"Number of lambdas:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int
ar Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n),
String -> SDoc
text String
"Rhs = " SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
rhs
]
invalidJoinOcc :: Var -> SDoc
invalidJoinOcc :: Var -> SDoc
invalidJoinOcc Var
var
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Invalid occurrence of a join variable:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
var
, String -> SDoc
text String
"The binder is either not a join point, or not valid here" ]
mkBadJumpMsg :: Var -> Int -> Int -> SDoc
mkBadJumpMsg :: Var -> Int -> Int -> SDoc
mkBadJumpMsg Var
var Int
ar Int
nargs
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Join point invoked with wrong number of arguments",
String -> SDoc
text String
"Join var:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
var,
String -> SDoc
text String
"Join arity:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
ar,
String -> SDoc
text String
"Number of arguments:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
nargs ]
mkInconsistentRecMsg :: [Var] -> SDoc
mkInconsistentRecMsg :: [Var] -> SDoc
mkInconsistentRecMsg [Var]
bndrs
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Recursive let binders mix values and join points",
String -> SDoc
text String
"Binders:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep ((Var -> SDoc) -> [Var] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Var -> SDoc
ppr_with_details [Var]
bndrs) ]
where
ppr_with_details :: Var -> SDoc
ppr_with_details Var
bndr = Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
bndr SDoc -> SDoc -> SDoc
<> IdDetails -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> IdDetails
idDetails Var
bndr)
mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc
mkJoinBndrOccMismatchMsg :: Var -> Int -> Int -> SDoc
mkJoinBndrOccMismatchMsg Var
bndr Int
join_arity_bndr Int
join_arity_occ
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Mismatch in join point arity between binder and occurrence"
, String -> SDoc
text String
"Var:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
bndr
, String -> SDoc
text String
"Arity at binding site:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
join_arity_bndr
, String -> SDoc
text String
"Arity at occurrence: " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
join_arity_occ ]
mkBndrOccTypeMismatchMsg :: Var -> Var -> LintedType -> LintedType -> SDoc
mkBndrOccTypeMismatchMsg :: Var -> Var -> Type -> Type -> SDoc
mkBndrOccTypeMismatchMsg Var
bndr Var
var Type
bndr_ty Type
var_ty
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Mismatch in type between binder and occurrence"
, String -> SDoc
text String
"Binder:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
bndr SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
bndr_ty
, String -> SDoc
text String
"Occurrence:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
var SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
var_ty
, String -> SDoc
text String
" Before subst:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
idType Var
var) ]
mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc
mkBadJoinPointRuleMsg :: Var -> Int -> CoreRule -> SDoc
mkBadJoinPointRuleMsg Var
bndr Int
join_arity CoreRule
rule
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Join point has rule with wrong number of arguments"
, String -> SDoc
text String
"Var:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
bndr
, String -> SDoc
text String
"Join arity:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
join_arity
, String -> SDoc
text String
"Rule:" SDoc -> SDoc -> SDoc
<+> CoreRule -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreRule
rule ]
pprLeftOrRight :: LeftOrRight -> SDoc
pprLeftOrRight :: LeftOrRight -> SDoc
pprLeftOrRight LeftOrRight
CLeft = String -> SDoc
text String
"left"
pprLeftOrRight LeftOrRight
CRight = String -> SDoc
text String
"right"
dupVars :: [NonEmpty Var] -> SDoc
dupVars :: [NonEmpty Var] -> SDoc
dupVars [NonEmpty Var]
vars
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Duplicate variables brought into scope")
Int
2 ([[Var]] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((NonEmpty Var -> [Var]) -> [NonEmpty Var] -> [[Var]]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty Var -> [Var]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [NonEmpty Var]
vars))
dupExtVars :: [NonEmpty Name] -> SDoc
dupExtVars :: [NonEmpty Name] -> SDoc
dupExtVars [NonEmpty Name]
vars
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Duplicate top-level variables with the same qualified name")
Int
2 ([[Name]] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((NonEmpty Name -> [Name]) -> [NonEmpty Name] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty Name -> [Name]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [NonEmpty Name]
vars))
lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
lintAnnots SDoc
pname ModGuts -> CoreM ModGuts
pass ModGuts
guts = {-# SCC "lintAnnots" #-} do
DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- CoreM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoAnnotationLinting DynFlags
dflags) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$
IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ Logger -> String -> IO ()
Err.showPass Logger
logger String
"Annotation linting - first run"
ModGuts
nguts <- ModGuts -> CoreM ModGuts
pass ModGuts
guts
Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoAnnotationLinting DynFlags
dflags) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ do
IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ Logger -> String -> IO ()
Err.showPass Logger
logger String
"Annotation linting - second run"
ModGuts
nguts' <- (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
withoutAnnots ModGuts -> CoreM ModGuts
pass ModGuts
guts
IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ Logger -> String -> IO ()
Err.showPass Logger
logger String
"Annotation linting - comparison"
let binds :: [(Var, CoreExpr)]
binds = CoreProgram -> [(Var, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds (CoreProgram -> [(Var, CoreExpr)])
-> CoreProgram -> [(Var, CoreExpr)]
forall a b. (a -> b) -> a -> b
$ ModGuts -> CoreProgram
mg_binds ModGuts
nguts
binds' :: [(Var, CoreExpr)]
binds' = CoreProgram -> [(Var, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds (CoreProgram -> [(Var, CoreExpr)])
-> CoreProgram -> [(Var, CoreExpr)]
forall a b. (a -> b) -> a -> b
$ ModGuts -> CoreProgram
mg_binds ModGuts
nguts'
([SDoc]
diffs,RnEnv2
_) = Bool
-> RnEnv2
-> [(Var, CoreExpr)]
-> [(Var, CoreExpr)]
-> ([SDoc], RnEnv2)
diffBinds Bool
True (InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
emptyInScopeSet) [(Var, CoreExpr)]
binds [(Var, CoreExpr)]
binds'
Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([SDoc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SDoc]
diffs)) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreM ()
GHC.Core.Opt.Monad.putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc -> SDoc
lint_banner String
"warning" SDoc
pname
, String -> SDoc
text String
"Core changes with annotations:"
, PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [SDoc]
diffs
]
ModGuts -> CoreM ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
nguts
withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
withoutAnnots ModGuts -> CoreM ModGuts
pass ModGuts
guts = do
DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let removeFlag :: HscEnv -> HscEnv
removeFlag HscEnv
env = HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags (DynFlags
dflags { debugLevel :: Int
debugLevel = Int
0}) HscEnv
env
withoutFlag :: CoreM ModGuts -> CoreM (ModGuts, SimplCount)
withoutFlag CoreM ModGuts
corem =
IO (ModGuts, SimplCount) -> CoreM (ModGuts, SimplCount)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModGuts, SimplCount) -> CoreM (ModGuts, SimplCount))
-> CoreM (IO (ModGuts, SimplCount)) -> CoreM (ModGuts, SimplCount)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HscEnv
-> RuleBase
-> Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM ModGuts
-> IO (ModGuts, SimplCount)
forall a.
HscEnv
-> RuleBase
-> Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM a
-> IO (a, SimplCount)
runCoreM (HscEnv
-> RuleBase
-> Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM ModGuts
-> IO (ModGuts, SimplCount))
-> CoreM HscEnv
-> CoreM
(RuleBase
-> Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM ModGuts
-> IO (ModGuts, SimplCount))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HscEnv -> HscEnv) -> CoreM HscEnv -> CoreM HscEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HscEnv -> HscEnv
removeFlag CoreM HscEnv
getHscEnv CoreM
(RuleBase
-> Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM ModGuts
-> IO (ModGuts, SimplCount))
-> CoreM RuleBase
-> CoreM
(Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM ModGuts
-> IO (ModGuts, SimplCount))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoreM RuleBase
getRuleBase CoreM
(Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM ModGuts
-> IO (ModGuts, SimplCount))
-> CoreM Char
-> CoreM
(Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM ModGuts
-> IO (ModGuts, SimplCount))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
CoreM Char
getUniqMask CoreM
(Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM ModGuts
-> IO (ModGuts, SimplCount))
-> CoreM Module
-> CoreM
(ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM ModGuts
-> IO (ModGuts, SimplCount))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoreM Module
forall (m :: * -> *). HasModule m => m Module
getModule CoreM
(ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM ModGuts
-> IO (ModGuts, SimplCount))
-> CoreM ModuleSet
-> CoreM
(PrintUnqualified
-> SrcSpan -> CoreM ModGuts -> IO (ModGuts, SimplCount))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
CoreM ModuleSet
getVisibleOrphanMods CoreM
(PrintUnqualified
-> SrcSpan -> CoreM ModGuts -> IO (ModGuts, SimplCount))
-> CoreM PrintUnqualified
-> CoreM (SrcSpan -> CoreM ModGuts -> IO (ModGuts, SimplCount))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
CoreM PrintUnqualified
getPrintUnqualified CoreM (SrcSpan -> CoreM ModGuts -> IO (ModGuts, SimplCount))
-> CoreM SrcSpan
-> CoreM (CoreM ModGuts -> IO (ModGuts, SimplCount))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoreM SrcSpan
getSrcSpanM CoreM (CoreM ModGuts -> IO (ModGuts, SimplCount))
-> CoreM (CoreM ModGuts) -> CoreM (IO (ModGuts, SimplCount))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
CoreM ModGuts -> CoreM (CoreM ModGuts)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreM ModGuts
corem
let nukeTicks :: Expr b -> Expr b
nukeTicks = (CoreTickish -> Bool) -> Expr b -> Expr b
forall b. (CoreTickish -> Bool) -> Expr b -> Expr b
stripTicksE (Bool -> Bool
not (Bool -> Bool) -> (CoreTickish -> Bool) -> CoreTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode)
nukeAnnotsBind :: CoreBind -> CoreBind
nukeAnnotsBind :: Bind Var -> Bind Var
nukeAnnotsBind Bind Var
bind = case Bind Var
bind of
Rec [(Var, CoreExpr)]
bs -> [(Var, CoreExpr)] -> Bind Var
forall b. [(b, Expr b)] -> Bind b
Rec ([(Var, CoreExpr)] -> Bind Var) -> [(Var, CoreExpr)] -> Bind Var
forall a b. (a -> b) -> a -> b
$ ((Var, CoreExpr) -> (Var, CoreExpr))
-> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
b,CoreExpr
e) -> (Var
b, CoreExpr -> CoreExpr
forall b. Expr b -> Expr b
nukeTicks CoreExpr
e)) [(Var, CoreExpr)]
bs
NonRec Var
b CoreExpr
e -> Var -> CoreExpr -> Bind Var
forall b. b -> Expr b -> Bind b
NonRec Var
b (CoreExpr -> Bind Var) -> CoreExpr -> Bind Var
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
forall b. Expr b -> Expr b
nukeTicks CoreExpr
e
nukeAnnotsMod :: ModGuts -> ModGuts
nukeAnnotsMod mg :: ModGuts
mg@ModGuts{mg_binds :: ModGuts -> CoreProgram
mg_binds=CoreProgram
binds}
= ModGuts
mg{mg_binds :: CoreProgram
mg_binds = (Bind Var -> Bind Var) -> CoreProgram -> CoreProgram
forall a b. (a -> b) -> [a] -> [b]
map Bind Var -> Bind Var
nukeAnnotsBind CoreProgram
binds}
((ModGuts, SimplCount) -> ModGuts)
-> CoreM (ModGuts, SimplCount) -> CoreM ModGuts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModGuts, SimplCount) -> ModGuts
forall a b. (a, b) -> a
fst (CoreM (ModGuts, SimplCount) -> CoreM ModGuts)
-> CoreM (ModGuts, SimplCount) -> CoreM ModGuts
forall a b. (a -> b) -> a -> b
$ CoreM ModGuts -> CoreM (ModGuts, SimplCount)
withoutFlag (CoreM ModGuts -> CoreM (ModGuts, SimplCount))
-> CoreM ModGuts -> CoreM (ModGuts, SimplCount)
forall a b. (a -> b) -> a -> b
$ ModGuts -> CoreM ModGuts
pass (ModGuts -> ModGuts
nukeAnnotsMod ModGuts
guts)