Add transitional rules for the alternative layout rule

If enabled, these accept more layout, but give warnings

2 files changed, 26 insertions, 2 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index abef731fb0..3a4f625d44 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -184,6 +184,7 @@ data DynFlag
    | Opt_WarnLazyUnliftedBindings
    | Opt_WarnUnusedDoBind
    | Opt_WarnWrongDoBind
+   | Opt_WarnAlternativeLayoutRuleTransitional
 
 
    -- language opts
@@ -252,6 +253,7 @@ data DynFlag
    | Opt_NewQualifiedOperators
    | Opt_ExplicitForAll
    | Opt_AlternativeLayoutRule
+   | Opt_AlternativeLayoutRuleTransitional
 
    | Opt_PrintExplicitForalls
 
@@ -930,7 +932,8 @@ standardWarnings
         Opt_WarnDuplicateExports,
         Opt_WarnLazyUnliftedBindings,
         Opt_WarnDodgyForeignImports,
-        Opt_WarnWrongDoBind
+        Opt_WarnWrongDoBind,
+        Opt_WarnAlternativeLayoutRuleTransitional
       ]
 
 minusWOpts :: [DynFlag]
@@ -1464,6 +1467,7 @@ fFlags = [
     const $ Deprecated "lazy unlifted bindings will be an error in GHC 6.14, and this flag will no longer exist"),
   ( "warn-unused-do-bind",              Opt_WarnUnusedDoBind, const Supported ),
   ( "warn-wrong-do-bind",               Opt_WarnWrongDoBind, const Supported ),
+  ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, const Supported ),
   ( "print-explicit-foralls",           Opt_PrintExplicitForalls, const Supported ),
   ( "strictness",                       Opt_Strictness, const Supported ),
   ( "specialise",                       Opt_Specialise, const Supported ),
@@ -1601,6 +1605,7 @@ xFlags = [
   ( "MonoPatBinds",                     Opt_MonoPatBinds, const Supported ),
   ( "ExplicitForAll",                   Opt_ExplicitForAll, const Supported ),
   ( "AlternativeLayoutRule",            Opt_AlternativeLayoutRule, const Supported ),
+  ( "AlternativeLayoutRuleTransitional",Opt_AlternativeLayoutRuleTransitional, const Supported ),
   ( "MonoLocalBinds",                   Opt_MonoLocalBinds, const Supported ),
   ( "RelaxedPolyRec",                   Opt_RelaxedPolyRec, const Supported ),
   ( "ExtendedDefaultRules",             Opt_ExtendedDefaultRules, const Supported ),
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 3a001bd08e..a4a343985a 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -1981,7 +1981,9 @@ alternativeLayoutRuleToken t
          mExpectingOCurly <- getAlrExpectingOCurly
          justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
          setJustClosedExplicitLetBlock False
-         let thisLoc = getLoc t
+         dflags <- getDynFlags
+         let transitional = dopt Opt_AlternativeLayoutRuleTransitional dflags
+             thisLoc = getLoc t
              thisCol = srcSpanStartCol thisLoc
              newLine = (lastLoc == noSrcSpan)
                     || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc)
@@ -2040,6 +2042,18 @@ alternativeLayoutRuleToken t
                  do setPendingImplicitTokens [t]
                     setALRContext ls
                     return (L thisLoc ITccurly)
+             -- This next case is to handle a transitional issue:
+             (ITwhere, ALRLayout _ col : ls, _)
+              | newLine && thisCol == col && transitional ->
+                 do addWarning Opt_WarnAlternativeLayoutRuleTransitional
+                               thisLoc
+                               (transitionalAlternativeLayoutWarning
+                                    "`where' clause at the same depth as implicit layout block")
+                    setALRContext ls
+                    setNextToken t
+                    -- Note that we use lastLoc, as we may need to close
+                    -- more layouts, or give a semicolon
+                    return (L lastLoc ITccurly)
              (_, ALRLayout _ col : ls, _)
               | newLine && thisCol == col ->
                  do setNextToken t
@@ -2090,6 +2104,11 @@ alternativeLayoutRuleToken t
              -- the other ITwhere case omitted; general case below covers it
              (_, _, _) -> return t
 
+transitionalAlternativeLayoutWarning :: String -> SDoc
+transitionalAlternativeLayoutWarning msg
+    = text "transitional layout will not be accepted in the future:"
+   $$ text msg
+
 isALRopen :: Token -> Bool
 isALRopen ITcase        = True
 isALRopen ITif          = True