| ... |
... |
@@ -434,11 +434,15 @@ The Lint monad |
|
434
|
434
|
************************************************************************
|
|
435
|
435
|
-}
|
|
436
|
436
|
|
|
|
437
|
+data LintReaderEnv = LintReaderEnv
|
|
|
438
|
+ { le_mod :: !Module
|
|
|
439
|
+ , le_flags :: !LintFlags
|
|
|
440
|
+ , le_diag_opts :: !DiagOpts -- Diagnostic options
|
|
|
441
|
+ , le_ppr_opts :: !StgPprOpts -- Pretty-printing options
|
|
|
442
|
+ }
|
|
|
443
|
+
|
|
437
|
444
|
newtype LintM a = LintM'
|
|
438
|
|
- { unLintM :: Module
|
|
439
|
|
- -> LintFlags
|
|
440
|
|
- -> DiagOpts -- Diagnostic options
|
|
441
|
|
- -> StgPprOpts -- Pretty-printing options
|
|
|
445
|
+ { unLintM :: LintReaderEnv
|
|
442
|
446
|
-> [LintLocInfo] -- Locations
|
|
443
|
447
|
-> IdSet -- Local vars in scope
|
|
444
|
448
|
-> Bag SDoc -- Error messages so far
|
| ... |
... |
@@ -446,16 +450,13 @@ newtype LintM a = LintM' |
|
446
|
450
|
}
|
|
447
|
451
|
instance Functor LintM where
|
|
448
|
452
|
fmap f (LintM m) =
|
|
449
|
|
- LintM $ \mod lf diag_opts opts loc scope errs ->
|
|
450
|
|
- case m mod lf diag_opts opts loc scope errs of
|
|
|
453
|
+ LintM $ \env loc scope errs ->
|
|
|
454
|
+ case m env loc scope errs of
|
|
451
|
455
|
(a, errs') -> (f a, errs')
|
|
452
|
456
|
|
|
453
|
457
|
-- See Note [The one-shot state monad trick] in GHC.Utils.Monad
|
|
454
|
458
|
{-# COMPLETE LintM #-}
|
|
455
|
|
-pattern LintM :: (Module
|
|
456
|
|
- -> LintFlags
|
|
457
|
|
- -> DiagOpts
|
|
458
|
|
- -> StgPprOpts
|
|
|
459
|
+pattern LintM :: (LintReaderEnv
|
|
459
|
460
|
-> [LintLocInfo]
|
|
460
|
461
|
-> IdSet
|
|
461
|
462
|
-> Bag SDoc
|
| ... |
... |
@@ -463,13 +464,10 @@ pattern LintM :: (Module |
|
463
|
464
|
-> LintM a
|
|
464
|
465
|
pattern LintM m <- LintM' m
|
|
465
|
466
|
where
|
|
466
|
|
- LintM m = LintM' $ oneShot (\mod -> oneShot
|
|
467
|
|
- (\lf -> oneShot
|
|
468
|
|
- (\diag_opts -> oneShot
|
|
469
|
|
- (\opts -> oneShot
|
|
|
467
|
+ LintM m = LintM' $ oneShot (\env -> oneShot
|
|
470
|
468
|
(\loc -> oneShot
|
|
471
|
469
|
(\scope -> oneShot
|
|
472
|
|
- (\errs -> m mod lf diag_opts opts loc scope errs)))))))
|
|
|
470
|
+ (\errs -> m env loc scope errs))))
|
|
473
|
471
|
|
|
474
|
472
|
data LintFlags = LintFlags { lf_unarised :: !Bool
|
|
475
|
473
|
, lf_platform :: !Platform
|
| ... |
... |
@@ -500,14 +498,16 @@ pp_binders bs |
|
500
|
498
|
|
|
501
|
499
|
initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
|
|
502
|
500
|
initL platform diag_opts this_mod unarised opts locals (LintM m) = do
|
|
503
|
|
- let (_, errs) = m this_mod (LintFlags unarised platform) diag_opts opts [] locals emptyBag
|
|
|
501
|
+ let !flags = LintFlags unarised platform
|
|
|
502
|
+ !env = LintReaderEnv this_mod flags diag_opts opts
|
|
|
503
|
+ (_, errs) = m env [] locals emptyBag
|
|
504
|
504
|
if isEmptyBag errs then
|
|
505
|
505
|
Nothing
|
|
506
|
506
|
else
|
|
507
|
507
|
Just (vcat (punctuate blankLine (bagToList errs)))
|
|
508
|
508
|
|
|
509
|
509
|
instance Applicative LintM where
|
|
510
|
|
- pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs)
|
|
|
510
|
+ pure a = LintM $ \_env _loc _scope errs -> (a, errs)
|
|
511
|
511
|
(<*>) = ap
|
|
512
|
512
|
(*>) = thenL_
|
|
513
|
513
|
|
| ... |
... |
@@ -516,14 +516,14 @@ instance Monad LintM where |
|
516
|
516
|
(>>) = (*>)
|
|
517
|
517
|
|
|
518
|
518
|
thenL :: LintM a -> (a -> LintM b) -> LintM b
|
|
519
|
|
-thenL m k = LintM $ \mod lf diag_opts opts loc scope errs
|
|
520
|
|
- -> case unLintM m mod lf diag_opts opts loc scope errs of
|
|
521
|
|
- (r, errs') -> unLintM (k r) mod lf diag_opts opts loc scope errs'
|
|
|
519
|
+thenL m k = LintM $ \env loc scope errs
|
|
|
520
|
+ -> case unLintM m env loc scope errs of
|
|
|
521
|
+ (r, errs') -> unLintM (k r) env loc scope errs'
|
|
522
|
522
|
|
|
523
|
523
|
thenL_ :: LintM a -> LintM b -> LintM b
|
|
524
|
|
-thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs
|
|
525
|
|
- -> case unLintM m mod lf diag_opts opts loc scope errs of
|
|
526
|
|
- (_, errs') -> unLintM k mod lf diag_opts opts loc scope errs'
|
|
|
524
|
+thenL_ m k = LintM $ \env loc scope errs
|
|
|
525
|
+ -> case unLintM m env loc scope errs of
|
|
|
526
|
+ (_, errs') -> unLintM k env loc scope errs'
|
|
527
|
527
|
|
|
528
|
528
|
checkL :: Bool -> SDoc -> LintM ()
|
|
529
|
529
|
checkL True _ = return ()
|
| ... |
... |
@@ -552,7 +552,8 @@ checkPostUnariseId id |
|
552
|
552
|
id_ty = idType id
|
|
553
|
553
|
|
|
554
|
554
|
addErrL :: SDoc -> LintM ()
|
|
555
|
|
-addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc)
|
|
|
555
|
+addErrL msg = LintM $ \LintReaderEnv{le_diag_opts = df} loc _scope errs
|
|
|
556
|
+ -> ((), addErr df errs msg loc)
|
|
556
|
557
|
|
|
557
|
558
|
addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
|
|
558
|
559
|
addErr diag_opts errs_so_far msg locs
|
| ... |
... |
@@ -564,23 +565,23 @@ addErr diag_opts errs_so_far msg locs |
|
564
|
565
|
mk_msg [] = msg
|
|
565
|
566
|
|
|
566
|
567
|
addLoc :: LintLocInfo -> LintM a -> LintM a
|
|
567
|
|
-addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs
|
|
568
|
|
- -> unLintM m mod lf diag_opts opts (extra_loc:loc) scope errs
|
|
|
568
|
+addLoc extra_loc m = LintM $ \env loc scope errs
|
|
|
569
|
+ -> unLintM m env (extra_loc:loc) scope errs
|
|
569
|
570
|
|
|
570
|
571
|
addInScopeVars :: [Id] -> LintM a -> LintM a
|
|
571
|
|
-addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs
|
|
|
572
|
+addInScopeVars ids m = LintM $ \env loc scope errs
|
|
572
|
573
|
-> let
|
|
573
|
574
|
new_set = mkVarSet ids
|
|
574
|
|
- in unLintM m mod lf diag_opts opts loc (scope `unionVarSet` new_set) errs
|
|
|
575
|
+ in unLintM m env loc (scope `unionVarSet` new_set) errs
|
|
575
|
576
|
|
|
576
|
577
|
getLintFlags :: LintM LintFlags
|
|
577
|
|
-getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs)
|
|
|
578
|
+getLintFlags = LintM $ \LintReaderEnv{le_flags = lf} _loc _scope errs -> (lf, errs)
|
|
578
|
579
|
|
|
579
|
580
|
getStgPprOpts :: LintM StgPprOpts
|
|
580
|
|
-getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs)
|
|
|
581
|
+getStgPprOpts = LintM $ \LintReaderEnv{le_ppr_opts = opts} _loc _scope errs -> (opts, errs)
|
|
581
|
582
|
|
|
582
|
583
|
checkInScope :: Id -> LintM ()
|
|
583
|
|
-checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs
|
|
|
584
|
+checkInScope id = LintM $ \LintReaderEnv{le_mod = mod, le_diag_opts = diag_opts} loc scope errs
|
|
584
|
585
|
-> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
|
|
585
|
586
|
((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id),
|
|
586
|
587
|
text "is out of scope"]) loc)
|