| ... |
... |
@@ -92,6 +92,7 @@ be ill-typed in Core. But it must still be well-kinded! |
|
92
|
92
|
-}
|
|
93
|
93
|
|
|
94
|
94
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
95
|
+{-# LANGUAGE PatternSynonyms #-}
|
|
95
|
96
|
|
|
96
|
97
|
module GHC.Stg.Lint ( lintStgTopBindings ) where
|
|
97
|
98
|
|
| ... |
... |
@@ -123,6 +124,7 @@ import GHC.Unit.Module ( Module ) |
|
123
|
124
|
import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
|
|
124
|
125
|
|
|
125
|
126
|
import Control.Monad
|
|
|
127
|
+import GHC.Exts ( oneShot )
|
|
126
|
128
|
import GHC.Core.Multiplicity (scaledThing)
|
|
127
|
129
|
import GHC.Settings (Platform)
|
|
128
|
130
|
import GHC.Core.TyCon (primRepCompatible, primRepsCompatible)
|
| ... |
... |
@@ -432,17 +434,40 @@ The Lint monad |
|
432
|
434
|
************************************************************************
|
|
433
|
435
|
-}
|
|
434
|
436
|
|
|
435
|
|
-newtype LintM a = LintM
|
|
436
|
|
- { unLintM :: Module
|
|
437
|
|
- -> LintFlags
|
|
438
|
|
- -> DiagOpts -- Diagnostic options
|
|
439
|
|
- -> StgPprOpts -- Pretty-printing options
|
|
|
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
|
+
|
|
|
444
|
+newtype LintM a = LintM'
|
|
|
445
|
+ { unLintM :: LintReaderEnv
|
|
440
|
446
|
-> [LintLocInfo] -- Locations
|
|
441
|
447
|
-> IdSet -- Local vars in scope
|
|
442
|
448
|
-> Bag SDoc -- Error messages so far
|
|
443
|
449
|
-> (a, Bag SDoc) -- Result and error messages (if any)
|
|
444
|
450
|
}
|
|
445
|
|
- deriving (Functor)
|
|
|
451
|
+instance Functor LintM where
|
|
|
452
|
+ fmap f (LintM m) =
|
|
|
453
|
+ LintM $ \env loc scope errs ->
|
|
|
454
|
+ case m env loc scope errs of
|
|
|
455
|
+ (a, errs') -> (f a, errs')
|
|
|
456
|
+
|
|
|
457
|
+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad
|
|
|
458
|
+{-# COMPLETE LintM #-}
|
|
|
459
|
+pattern LintM :: (LintReaderEnv
|
|
|
460
|
+ -> [LintLocInfo]
|
|
|
461
|
+ -> IdSet
|
|
|
462
|
+ -> Bag SDoc
|
|
|
463
|
+ -> (a, Bag SDoc))
|
|
|
464
|
+ -> LintM a
|
|
|
465
|
+pattern LintM m <- LintM' m
|
|
|
466
|
+ where
|
|
|
467
|
+ LintM m = LintM' $ oneShot (\env -> oneShot
|
|
|
468
|
+ (\loc -> oneShot
|
|
|
469
|
+ (\scope -> oneShot
|
|
|
470
|
+ (\errs -> m env loc scope errs))))
|
|
446
|
471
|
|
|
447
|
472
|
data LintFlags = LintFlags { lf_unarised :: !Bool
|
|
448
|
473
|
, lf_platform :: !Platform
|
| ... |
... |
@@ -473,14 +498,16 @@ pp_binders bs |
|
473
|
498
|
|
|
474
|
499
|
initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
|
|
475
|
500
|
initL platform diag_opts this_mod unarised opts locals (LintM m) = do
|
|
476
|
|
- 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
|
|
477
|
504
|
if isEmptyBag errs then
|
|
478
|
505
|
Nothing
|
|
479
|
506
|
else
|
|
480
|
507
|
Just (vcat (punctuate blankLine (bagToList errs)))
|
|
481
|
508
|
|
|
482
|
509
|
instance Applicative LintM where
|
|
483
|
|
- pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs)
|
|
|
510
|
+ pure a = LintM $ \_env _loc _scope errs -> (a, errs)
|
|
484
|
511
|
(<*>) = ap
|
|
485
|
512
|
(*>) = thenL_
|
|
486
|
513
|
|
| ... |
... |
@@ -489,14 +516,14 @@ instance Monad LintM where |
|
489
|
516
|
(>>) = (*>)
|
|
490
|
517
|
|
|
491
|
518
|
thenL :: LintM a -> (a -> LintM b) -> LintM b
|
|
492
|
|
-thenL m k = LintM $ \mod lf diag_opts opts loc scope errs
|
|
493
|
|
- -> case unLintM m mod lf diag_opts opts loc scope errs of
|
|
494
|
|
- (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'
|
|
495
|
522
|
|
|
496
|
523
|
thenL_ :: LintM a -> LintM b -> LintM b
|
|
497
|
|
-thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs
|
|
498
|
|
- -> case unLintM m mod lf diag_opts opts loc scope errs of
|
|
499
|
|
- (_, 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'
|
|
500
|
527
|
|
|
501
|
528
|
checkL :: Bool -> SDoc -> LintM ()
|
|
502
|
529
|
checkL True _ = return ()
|
| ... |
... |
@@ -525,7 +552,8 @@ checkPostUnariseId id |
|
525
|
552
|
id_ty = idType id
|
|
526
|
553
|
|
|
527
|
554
|
addErrL :: SDoc -> LintM ()
|
|
528
|
|
-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)
|
|
529
|
557
|
|
|
530
|
558
|
addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
|
|
531
|
559
|
addErr diag_opts errs_so_far msg locs
|
| ... |
... |
@@ -537,23 +565,23 @@ addErr diag_opts errs_so_far msg locs |
|
537
|
565
|
mk_msg [] = msg
|
|
538
|
566
|
|
|
539
|
567
|
addLoc :: LintLocInfo -> LintM a -> LintM a
|
|
540
|
|
-addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs
|
|
541
|
|
- -> 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
|
|
542
|
570
|
|
|
543
|
571
|
addInScopeVars :: [Id] -> LintM a -> LintM a
|
|
544
|
|
-addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs
|
|
|
572
|
+addInScopeVars ids m = LintM $ \env loc scope errs
|
|
545
|
573
|
-> let
|
|
546
|
574
|
new_set = mkVarSet ids
|
|
547
|
|
- 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
|
|
548
|
576
|
|
|
549
|
577
|
getLintFlags :: LintM LintFlags
|
|
550
|
|
-getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs)
|
|
|
578
|
+getLintFlags = LintM $ \LintReaderEnv{le_flags = lf} _loc _scope errs -> (lf, errs)
|
|
551
|
579
|
|
|
552
|
580
|
getStgPprOpts :: LintM StgPprOpts
|
|
553
|
|
-getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs)
|
|
|
581
|
+getStgPprOpts = LintM $ \LintReaderEnv{le_ppr_opts = opts} _loc _scope errs -> (opts, errs)
|
|
554
|
582
|
|
|
555
|
583
|
checkInScope :: Id -> LintM ()
|
|
556
|
|
-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
|
|
557
|
585
|
-> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
|
|
558
|
586
|
((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id),
|
|
559
|
587
|
text "is out of scope"]) loc)
|