[improve the parser to accept a lot more valid (but odd) haskell programs
John Meacham <john@repetae.net>**20100728001911
 Ignore-this: 4934f5b3c1c2df53ea1e1894b93e7d8e
] hunk ./src/FrontEnd/HsParser.y 165
-      : impdecls ';' topdecls optsemi                 { (reverse $1, fixupHsDecls (reverse $3)) }
-      |              topdecls optsemi                 { ([], fixupHsDecls (reverse $1)) }
-      | impdecls              optsemi                 { (reverse $1, []) }
-      | {- empty -}                                   { ([], []) }
+      : optsemis impdecls semis topdecls              { (reverse $2, fixupHsDecls $4) }
+      | optsemis                topdecls              { ([], fixupHsDecls $2) }
+      | optsemis impdecls optsemis                    { (reverse $2, []) }
+      | optsemis                                      { ([], []) }
hunk ./src/FrontEnd/HsParser.y 174
+semis :: { () }
+       : optsemis ';'				{ () }
+optsemis :: { () }
+       : semis					{ () }
+       | {- empty -}				{ () }
hunk ./src/FrontEnd/HsParser.y 218
-      : impdecls ';' impdecl                  { $3 : $1 }
+      : impdecls semis impdecl                  { $3 : $1 }
hunk ./src/FrontEnd/HsParser.y 239
-      :  '(' importlist maybecomma ')'        { (False, reverse $2) }
-      |  '(' ')'                              { (False, []) }
+      :  '(' importlist maybecomma ')'          { (False, reverse $2) }
+      |  '(' ')'                                { (False, []) }
hunk ./src/FrontEnd/HsParser.y 242
+      |  'hiding' '(' ')'                       { (True, []) }
hunk ./src/FrontEnd/HsParser.y 290
-      : topdecls ';' topdecl          { $3 : $1 }
-      | topdecls ';'                  { $1 }
+      : topdecls1 optsemis          { reverse $1 } -- TODO checkRevDecls
+
+topdecls1 :: { [HsDecl] }
+      : topdecls1 semis topdecl       { $3 : $1  }
hunk ./src/FrontEnd/HsParser.y 368
-      : decls1 optsemi                { fixupHsDecls ( reverse $1 ) }
-      | optsemi                       { [] }
+      : optsemis decls1 optsemis      { fixupHsDecls ( reverse $2 ) }
+      | optsemis                      { [] }
hunk ./src/FrontEnd/HsParser.y 372
-      : decls1 ';' decl               { $3 : $1 }
+      : decls1 semis decl             { $3 : $1 }
hunk ./src/FrontEnd/HsParser.y 477
-      : qconid                        { $1 }
+      : qcon                          { $1 }
hunk ./src/FrontEnd/HsParser.y 495
-      : btype '=>' type               {% checkContext $1 `thenP` \c ->
-                                         returnP (HsQualType c $3) }
+      : context '=>' type             { HsQualType $1 $3 }
hunk ./src/FrontEnd/HsParser.y 498
+context :: { HsContext }
+        : btype				{% checkContext $1 }
+
hunk ./src/FrontEnd/HsParser.y 532
+      | srcloc mexists con '{' '}'
+                                      { HsRecDecl { hsConDeclSrcLoc = $1, hsConDeclName = $3, hsConDeclRecArg = [], hsConDeclExists = $2 } }
hunk ./src/FrontEnd/HsParser.y 828
-      : infixexp srcloc '<-' exp      {% checkPattern $1 `thenP` \p ->
+      : exp srcloc '<-' exp      {% checkPattern $1 `thenP` \p ->
hunk ./src/FrontEnd/HsParser.y 868
-      : stmts1 ';' exp                { reverse (HsQualifier $3 : $1) }
+      : stmts1 semis exp              { reverse (HsQualifier $3 : $1) }
hunk ./src/FrontEnd/HsParser.y 872
-      : stmts1 ';' qual               { $3 : $1 }
+      : stmts1 semis qual             { $3 : $1 }
hunk ./src/FrontEnd/HsParser.y 1025
-layout_on  :: { () }  : optsemi  {% getSrcLoc `thenP` \sl ->
+layout_on  :: { () }  :   {% getSrcLoc `thenP` \sl ->
hunk ./src/FrontEnd/Lexer.hs 216
-lexer = runL $ do
-	bol <- checkBOL
-	bol <- lexWhiteSpace bol
-	startToken
-	if bol then lexBOL else lexToken
+lexer = runL topLexer
+
+topLexer :: Lex a Token
+topLexer = do
+    b <- pullCtxtFlag
+    if b
+     then setBOL >> return VRightCurly -- the lex context state flags that we must do an empty {} - UGLY
+     else do
+    bol <- checkBOL
+    bol <- lexWhiteSpace bol
+    startToken
+    if bol then lexBOL else lexToken
hunk ./src/FrontEnd/Lexer.hs 380
-		return $ case lookup ident (reserved_ids ++ special_varids) of
+		case lookup ident (reserved_ids ++ special_varids) of
hunk ./src/FrontEnd/Lexer.hs 382
-                            | doFFI -> KW_Foreign
-                            | otherwise -> VarId ident
-			Just keyword -> keyword
-			Nothing -> VarId ident
+                            | doFFI -> return KW_Foreign
+                            | otherwise -> return $ VarId ident
+                        Just KW_Do -> setFlagDo >> return KW_Do
+			Just keyword -> return keyword
+			Nothing -> return $ VarId ident
hunk ./src/FrontEnd/Lexer.hs 446
-                        'e':_ -> lexExponent
-                        'E':_ -> lexExponent
+                        e:pm:d:_ | e `elem` "eE", (pm `elem` "+-" && isDigit d) || isDigit pm -> lexExponent
+--                        'e':_ -> lexExponent
+ --                       'E':_ -> lexExponent
hunk ./src/FrontEnd/ParseMonad.hs 1
--- #hide
+{-# LANGUAGE NamedFieldPuns #-}
hunk ./src/FrontEnd/ParseMonad.hs 26
-		pushContextL, popContextL, lexParseMode
+		pushContextL, popContextL, lexParseMode,
+                pullCtxtFlag, setFlagDo
hunk ./src/FrontEnd/ParseMonad.hs 32
+import Control.Monad
hunk ./src/FrontEnd/ParseMonad.hs 57
-data ParseState = ParseState { psLexContext :: [LexContext], psWarnings :: [Warning] }
-    deriving(Show)
+data ParseState = ParseState {
+    psLexContext :: [LexContext],
+    psWarnings :: [Warning],
+    psInDo :: !Bool,
+    psForceClose :: !Bool
+    } deriving(Show)
hunk ./src/FrontEnd/ParseMonad.hs 89
-emptyParseState = ParseState { psLexContext = [], psWarnings = [] }
+emptyParseState = ParseState { psLexContext = [], psWarnings = [], psForceClose = False, psInDo = False }
hunk ./src/FrontEnd/ParseMonad.hs 176
-	loc <- getSrcLoc
+	lc <- getSrcLoc
hunk ./src/FrontEnd/ParseMonad.hs 178
-	pushContext (Layout (max (indent) (srcLocColumn loc)))
+        let loc = srcLocColumn lc
+        dob <- pullDoStatus
+        when (if dob then loc < indent else loc <= indent) pushCtxtFlag
+	pushContext (Layout loc)
hunk ./src/FrontEnd/ParseMonad.hs 198
+pullCtxtFlag :: Lex a Bool
+pullCtxtFlag = Lex $ \cont -> P $ \r x y loc s ->
+        runP (cont $ psForceClose s) r x y loc s { psForceClose = False }
+
+pushCtxtFlag :: P ()
+pushCtxtFlag =
+    P $ \_i _x _y _l s _m -> case psForceClose s of
+        False -> Ok s { psForceClose = True } ()
+        _     -> error "Internal error: context flag already pushed"
+
+pullDoStatus :: P Bool
+pullDoStatus = P $ \_i _x _y _l s _m -> Ok s { psInDo = False } (psInDo s)
+
+setFlagDo :: Lex a ()
+setFlagDo = Lex $ \cont -> P $ \r x y loc s ->
+        runP (cont ()) r x y loc s { psInDo = True }
+
hunk ./src/FrontEnd/ParseMonad.hs 217
-
+--