| ... |
... |
@@ -1719,27 +1719,41 @@ mkErrCtxt env ctxts |
|
1719
|
1719
|
-- if dbg -- In -dppr-debug style the output
|
|
1720
|
1720
|
-- then return empty -- just becomes too voluminous
|
|
1721
|
1721
|
-- else go dbg 0 env ctxts
|
|
1722
|
|
- = go False 0 env ctxts
|
|
|
1722
|
+ = do appDo <- xoptM LangExt.ApplicativeDo
|
|
|
1723
|
+ if appDo
|
|
|
1724
|
+ then go False 0 env ctxts
|
|
|
1725
|
+ else go1 False 0 env ctxts
|
|
1723
|
1726
|
|
|
1724
|
1727
|
where
|
|
1725
|
|
- go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg]
|
|
1726
|
|
- go _ _ _ [] = return []
|
|
1727
|
|
- go dbg n env ((is_landmark1, ctxt1) : (is_landmark2, ctxt2) : ctxts)
|
|
|
1728
|
+ go1, go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg]
|
|
|
1729
|
+ go1 _ _ _ [] = return []
|
|
|
1730
|
+ go1 dbg n env ((is_landmark1, ctxt1) : (is_landmark2, ctxt2) : ctxts)
|
|
1728
|
1731
|
| is_landmark1 || n < mAX_CONTEXTS -- Too verbose || dbg
|
|
1729
|
1732
|
= do { (env', msg1) <- liftZonkM $ ctxt1 env
|
|
1730
|
1733
|
; (_, msg2) <- liftZonkM $ ctxt2 env'
|
|
1731
|
1734
|
; case (msg1, msg2) of
|
|
1732
|
1735
|
(ExprCtxt{}, StmtErrCtxt (HsDoStmt (DoExpr{})) _)
|
|
1733
|
1736
|
-> do { let n' = if is_landmark2 then n else n+1
|
|
1734
|
|
- ; rest <- go dbg n' env' ctxts
|
|
|
1737
|
+ ; rest <- go1 dbg n' env' ctxts
|
|
1735
|
1738
|
; return (msg2 : rest) }
|
|
1736
|
1739
|
_
|
|
1737
|
1740
|
-> do { let n' = if is_landmark1 then n else n+1
|
|
1738
|
|
- ; rest <- go dbg n' env' ((is_landmark2, ctxt2) : ctxts)
|
|
|
1741
|
+ ; rest <- go1 dbg n' env' ((is_landmark2, ctxt2) : ctxts)
|
|
1739
|
1742
|
; return (msg1 : rest) }
|
|
1740
|
1743
|
}
|
|
1741
|
1744
|
| otherwise
|
|
1742
|
|
- = go dbg n env ((is_landmark2, ctxt2) : ctxts)
|
|
|
1745
|
+ = go1 dbg n env ((is_landmark2, ctxt2) : ctxts)
|
|
|
1746
|
+ go1 dbg n env ((is_landmark, ctxt) : ctxts)
|
|
|
1747
|
+ | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg
|
|
|
1748
|
+ = do { (env', msg) <- liftZonkM $ ctxt env
|
|
|
1749
|
+ ; let n' = if is_landmark then n else n+1
|
|
|
1750
|
+ ; rest <- go1 dbg n' env' ctxts
|
|
|
1751
|
+ ; return (msg : rest) }
|
|
|
1752
|
+ | otherwise
|
|
|
1753
|
+ = go1 dbg n env ctxts
|
|
|
1754
|
+
|
|
|
1755
|
+ -- Applicative do doesn't use expansion yet
|
|
|
1756
|
+ go _ _ _ [] = return []
|
|
1743
|
1757
|
go dbg n env ((is_landmark, ctxt) : ctxts)
|
|
1744
|
1758
|
| is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg
|
|
1745
|
1759
|
= do { (env', msg) <- liftZonkM $ ctxt env
|
| ... |
... |
@@ -1749,13 +1763,6 @@ mkErrCtxt env ctxts |
|
1749
|
1763
|
| otherwise
|
|
1750
|
1764
|
= go dbg n env ctxts
|
|
1751
|
1765
|
|
|
1752
|
|
- -- filter_stmt_adj :: [ErrCtxtMsg] -> [ErrCtxtMsg]
|
|
1753
|
|
- -- filter_stmt_adj = concat . map stmtAdj . tails
|
|
1754
|
|
-
|
|
1755
|
|
- -- stmtAdj :: [ErrCtxtMsg] -> [ErrCtxtMsg]
|
|
1756
|
|
- -- stmtAdj (ExprCtxt{} : StmtErrCtxt{} : _ ) = []
|
|
1757
|
|
- -- stmtAdj (s : _ ) = [s]
|
|
1758
|
|
- -- stmtAdj xs = xs
|
|
1759
|
1766
|
|
|
1760
|
1767
|
mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
|
|
1761
|
1768
|
mAX_CONTEXTS = 3
|