Fix layout process for empty let statements

.gitignore

@@ -1,2 +1,3 @@
 /dist/
+/.stack-work/
 *.out

haskell-src-exts.cabal

@@ -49,10 +49,12 @@ Library
                         base >= 4.5 && < 5,
                         -- this is needed to access GHC.Generics on GHC 7.4
                         ghc-prim
-  -- this is needed to access Data.Semigroup on GHCs before 8.0
+  -- this is needed to access Data.Semigroup and Control.Monad.Fail on GHCs
+  -- before 8.0
   if !impl(ghc >= 8.0)
     Build-Depends:
-                        semigroups >= 0.18.3
+                        semigroups >= 0.18.3,
+                        fail == 4.9.*
 
   Exposed-modules:      Language.Haskell.Exts,
                         Language.Haskell.Exts.Lexer,

src/Language/Haskell/Exts/ExactPrint.hs

@@ -733,7 +733,7 @@ instance ExactP Decl where
         let pts = srcInfoPoints l
         printInterleaved' (zip pts (replicate (length pts - 1) "," ++ ["::"])) ns
         exactPC t
-    PatSynSig l ns dh c1 c2 t -> do
+    PatSynSig l ns dh c1 _ c2 t -> do
         let (pat:pts) = srcInfoPoints l
         printStringAt (pos pat) "pattern"
         printInterleaved' (zip pts (replicate (length ns - 1) "," ++ ["::"])) ns
@@ -1361,7 +1361,7 @@ instance ExactP ConDecl where
     RecDecl l n fds -> exactP n >> curlyList (srcInfoPoints l) fds
 
 instance ExactP GadtDecl where
-  exactP (GadtDecl l n ns' t) =
+  exactP (GadtDecl l n _mtvs mctxt ns' t) =
     case ns' of
         Nothing ->
             case srcInfoPoints l of
@@ -1375,6 +1375,7 @@ instance ExactP GadtDecl where
                 (a:b:c:d:rest) -> do
                     exactPC n
                     printStringAt (pos a) "::"
+                    maybeEP exactPC mctxt
                     printStringAt (pos b) "{"
                     printInterleaved' (zip rest (repeat ",")) ts
                     printStringAt (pos c) "}"

src/Language/Haskell/Exts/Extension.hs

@@ -546,6 +546,12 @@ data KnownExtension =
 
   | UnboxedSums
 
+  | TypeInType
+
+  | Strict
+
+  | StrictData
+
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Data, Typeable)
 
 -- | Certain extensions imply other extensions, and this function
@@ -581,6 +587,8 @@ impliesExts = go
                     ImpredicativeTypes   -> [ExplicitForAll]
                     PolyKinds           -> [KindSignatures]
                     TypeFamilyDependencies -> [TypeFamilies]
+                    TypeInType          -> [PolyKinds, DataKinds, KindSignatures]
+                    TypeOperators       -> [ExplicitNamespaces]
                     -- Deprecations
                     RecordPuns          -> [NamedFieldPuns]
                     PatternSignatures   -> [ScopedTypeVariables]

src/Language/Haskell/Exts/Fixity.hs

@@ -141,7 +141,7 @@ preludeFixities = concat
     [infixr_ 9  ["."]
     ,infixl_ 9  ["!!"]
     ,infixr_ 8  ["^","^^","**"]
-    ,infixl_ 7  ["*","/","`quot`","`rem`","`div`","`mod`",":%","%"]
+    ,infixl_ 7  ["*","/","`quot`","`rem`","`div`","`mod`"]
     ,infixl_ 6  ["+","-"]
     ,infixr_ 5  [":","++"]
     ,infix_  4  ["==","/=","<","<=",">=",">","`elem`","`notElem`"]
@@ -161,15 +161,17 @@ preludeFixities = concat
 baseFixities :: [Fixity]
 baseFixities = preludeFixities ++ concat
     [infixl_ 9 ["!","//","!:"]
+    ,infixr_ 9 ["`Compose`"]
     ,infixl_ 8 ["`shift`","`rotate`","`shiftL`","`shiftR`","`rotateL`","`rotateR`"]
-    ,infixl_ 7 [".&."]
+    ,infixl_ 7 [".&.","%"]
+    ,infixr_ 6 ["<>"]
     ,infixl_ 6 ["`xor`"]
     ,infix_  6 [":+"]
     ,infixl_ 5 [".|."]
-    ,infixr_ 5 ["+:+","<++","<+>"] -- fixity conflict for +++ between ReadP and Arrow
+    ,infixr_ 5 ["+:+","<++","<+>","<|"] -- fixity conflict for +++ between ReadP and Arrow
     ,infix_  5 ["\\\\"]
-    ,infixl_ 4 ["<**>"]
-    ,infix_  4 ["`elemP`","`notElemP`"]
+    ,infixl_ 4 ["<**>","$>","<$","<$!>"]
+    ,infix_  4 ["`elemP`","`notElemP`",":~:",":~~:"]
     ,infixl_ 3 ["<|>"]
     ,infixr_ 3 ["&&&","***"]
     ,infixr_ 2 ["+++","|||"]

src/Language/Haskell/Exts/InternalLexer.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# OPTIONS_HADDOCK hide #-}
 -----------------------------------------------------------------------------
 -- |
@@ -32,7 +33,10 @@ import Data.Ratio
 import Data.List (intercalate, isPrefixOf)
 import Control.Monad (when)
 
--- import Debug.Trace (trace)
+#ifdef DEBUG
+import Debug.Trace (trace)
+#endif
+
 
 data Token
         = VarId String
@@ -385,13 +389,26 @@ matchChar c msg = do
 
 lexer :: (Loc Token -> P a) -> P a
 lexer = runL topLexer
+#ifdef DEBUG
+    . \f token -> trace (show token) $ f token
+#endif
 
 topLexer :: Lex a (Loc Token)
 topLexer = do
     b <- pullCtxtFlag
-    if b then -- trace (show cf ++ ": " ++ show VRightCurly) $
-              -- the lex context state flags that we must do an empty {} - UGLY
-              setBOL >> getSrcLocL >>= \l -> return (Loc (mkSrcSpan l l) VRightCurly)
+    if b then do
+#ifdef DEBUG
+        trace ("By context flag: " ++ show VRightCurly) $ return ()
+#endif
+        pCtxtFlg <- checkParentContextL
+        when pCtxtFlg $
+            popContextL "lexBOL"
+
+        -- the lex context state flags that we must do an empty {} - UGLY
+        sl <- getSrcLocL
+        setBOL
+        el <- getSrcLocL
+        return $ Loc (mkSrcSpan sl el) VRightCurly
      else do
         bol <- checkBOL
         (bol', ws) <- lexWhiteSpace bol
@@ -512,7 +529,10 @@ lexNestedComment bol str = do
 lexBOL :: Lex a Token
 lexBOL = do
     pos <- getOffside
-    -- trace ("Off: " ++ (show pos)) $ do
+#ifdef DEBUG
+    currentLoc <- getSrcLocL
+    trace ("Off: " ++ show (pos, currentLoc)) $ return ()
+#endif
     case pos of
         LT -> do
                 -- trace "layout: inserting '}'\n" $
@@ -524,7 +544,7 @@ lexBOL = do
             popContextL "lexBOL"
             return VRightCurly
         EQ ->
-            -- trace "layout: inserting ';'\n" $
+            -- trace "layout: inserting ';'" $
             return SemiColon
         GT -> lexToken
 

src/Language/Haskell/Exts/InternalParser.ly

@@ -1127,10 +1127,14 @@ GADTs - require the GADTs extension enabled, but we handle that at the calling s
 
 > gadtconstr :: { [GadtDecl L] }
 >       : qcon '::' truectype            {% do { c <- checkUnQual $1;
->                                                return [GadtDecl ($1 <> $3 <** [$2]) c Nothing $3] } }
+>                                                return [GadtDecl ($1 <> $3 <** [$2]) c Nothing Nothing Nothing $3] } }
+>       | qcon '::' context '{' fielddecls '}' '->' truectype
+>                                       {% do { c <- checkUnQual $1;
+>                                               ctxt <- checkContext (Just $3) ;
+>                                               return [GadtDecl ($1 <> $8 <** [$2,$4,$6,$7] ++ snd $5) c Nothing ctxt (Just (reverse $ fst $5)) $8] } }
 >       | qcon '::' '{' fielddecls '}' '->' truectype
 >                                       {% do { c <- checkUnQual $1;
->                                               return [GadtDecl ($1 <> $7 <** [$2,$3,$5,$6] ++ snd $4) c (Just (reverse $ fst $4)) $7] } }
+>                                               return [GadtDecl ($1 <> $7 <** [$2,$3,$5,$6] ++ snd $4) c Nothing Nothing (Just (reverse $ fst $4)) $7] } }
 
 To allow the empty case we need the EmptyDataDecls extension.
 > constrs0 :: { ([QualConDecl L],[S],Maybe L) }
@@ -1803,7 +1807,7 @@ TODO: The points can't be added here, must be propagated!
 
 > stmtlist :: { ([Stmt L],L,[S]) }
 >       : '{'  stmts '}'                { (fst $2, $1 <^^> $3, $1:snd $2 ++ [$3])  }
->       | open stmts close              { let l' =  ann . last $ fst $2
+>       | stmtopen stmts close          { let l' =  ann . last $ fst $2
 >                                          in (fst $2, nIS $1 <++> l', $1:snd $2 ++ [$3]) }
 
 > stmts :: { ([Stmt L],[S]) }
@@ -2033,11 +2037,20 @@ Implicit parameter
 -----------------------------------------------------------------------------
 Layout
 
-> open  :: { S }  :       {% pushCurrentContext >> getSrcLoc >>= \s -> return $ mkSrcSpan s s {- >>= \x -> trace (show x) (return x) -} }
+> open  :: { S }  :       {% pushCurrentContext BindLayout >> getZeroSpanByLoc
+>                         {- >>= \x -> trace (show x) (return x) -}
+>                         }
+> stmtopen  :: { S }  :   {% pushCurrentContext StmtLayout >> getZeroSpanByLoc
+>                         {- >>= \x -> trace (show x) (return x) -}
+>                         }
 
 > close :: { S }
->       : vccurly               { $1 {- >>= \x -> trace (show x ++ show x ++ show x) (return x) -} } -- context popped in lexer.
->       | error                 {% popContext >> getSrcLoc >>= \s -> return $ mkSrcSpan s s {- >>= \x -> trace (show x ++ show x) (return x) -} }
+>       : vccurly               {% return $1
+>                               {- >>= \x -> trace (show x ++ show x ++ show x) (return x) -}
+>                               }
+>       | error                 {% popContext >> getZeroSpanByLoc
+>                               {- >>= \x -> trace (show x ++ show x) (return x) -}
+>                               }
 
 -----------------------------------------------------------------------------
 Pattern Synonyms
@@ -2087,25 +2100,31 @@ Pattern Synonyms
 > pattern_synonym_sig :: { Decl L }
 >       : 'pattern' con_list '::' pstype
 >             {% do { checkEnabled PatternSynonyms ;
->                     let {(qtvs, ps, prov, req, ty) = $4} ;
->                     let {sig = PatSynSig (nIS $1 <++> ann ty <** [$1] ++ fst $2 ++ [$3] ++ ps)  (snd $2) qtvs prov req ty} ;
+>                     let {(qtvs, ps, prov, req_vars, req, ty) = $4} ;
+>                     let {sig = PatSynSig (nIS $1 <++> ann ty <** [$1] ++ fst $2 ++ [$3] ++ ps)  (snd $2) qtvs prov req_vars req ty} ;
 >                     return sig } }
 
-> pstype :: { (Maybe [TyVarBind L], [S], Maybe (Context L), Maybe (Context L), Type L )}
+> pstype :: { (Maybe [TyVarBind L], [S], Maybe (Context L), Maybe [TyVarBind L]
+>                                       , Maybe (Context L), Type L )}
 >       :  'forall' ktyvars '.' pstype
->             { let (qtvs, ps, prov, req, ty) = $4
->                in (Just (reverse (fst $2) ++ fromMaybe [] qtvs), ($1 : $3 : ps), prov, req, ty) }
+>             { let (qtvs, ps, prov, req_vars, req, ty) = $4
+>                in (Just (reverse (fst $2) ++ fromMaybe [] qtvs), ($1 : $3 : ps), prov, req_vars, req, ty) }
 >       | context context type
 >             {% do { c1 <- checkContext (Just $1) ;
 >                     c2 <- checkContext (Just $2) ;
 >                     t  <- checkType $3 ;
->                     return $ (Nothing, [], c1, c2, t) }}
+>                     return $ (Nothing, [], c1, Nothing, c2, t) }}
+>       | context 'forall' ktyvars '.' context type
+>             {% do { c1 <- checkContext (Just $1) ;
+>                     c2 <- checkContext (Just $5) ;
+>                     t  <- checkType $6 ;
+>                     return $ (Nothing, [], c1, Just (reverse (fst $3)), c2, t) }}
 >       | context type
 >              {% do { c1 <- checkContext (Just $1);
 >                      t <- checkType $2;
->                      return (Nothing, [], c1, Nothing, t) } }
+>                      return (Nothing, [], c1, Nothing, Nothing, t) } }
 >       | type
->              {% checkType $1 >>= \t -> return (Nothing, [], Nothing, Nothing, t) }
+>              {% checkType $1 >>= \t -> return (Nothing, [], Nothing, Nothing, Nothing, t) }
 
 -----------------------------------------------------------------------------
 Deriving strategies
@@ -2196,4 +2215,7 @@ Exported as partial parsers:
 >        fail $ "Expected single declaration, found import declaration"
 >     checkSingleDecl ds
 
+> getZeroSpanByLoc :: P SrcSpan
+> getZeroSpanByLoc = getSrcLoc >>= \s -> return $ mkSrcSpan s s
+
 > }