X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=7594079ff1d0f422fdb85e0a5f5012f54a7d93e9;hp=09b58dd5b1184a4840b24717ef8ef85f7c033bf6;hb=59300a7161f44b3a2afe381a6ccd914043a32c4f;hpb=a6a4959cd94716d1e2e6624f370eb9c1bdd96ecc

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 09b58dd..7594079 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -702,6 +702,14 @@ reservedSymsFM = listToUFM $
        ,("→",   ITrarrow, unicodeSyntaxEnabled)
        ,("←",   ITlarrow, unicodeSyntaxEnabled)
        ,("⋯",   ITdotdot, unicodeSyntaxEnabled)
+
+       ,("⤙",   ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+       ,("⤚",   ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+       ,("⤛",   ITLarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+       ,("⤜",   ITRarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+
+       ,("★", ITstar, unicodeSyntaxEnabled)
+
         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
         -- form part of a large operator.  This would let us have a better
         -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
@@ -1127,7 +1135,7 @@ do_layout_left span _buf _len = do
 setLine :: Int -> Action
 setLine code span buf len = do
   let line = parseUnsignedInteger buf len 10 octDecDigit
-  setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0)
+  setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
 	-- subtract one: the line number refers to the *following* line
   _ <- popLexState
   pushLexState code
@@ -1136,6 +1144,7 @@ setLine code span buf len = do
 setFile :: Int -> Action
 setFile code span buf len = do
   let file = lexemeToFastString (stepOn buf) (len-2)
+  setAlrLastLoc noSrcSpan
   setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
   _ <- popLexState
   pushLexState code
@@ -1973,7 +1982,8 @@ alternativeLayoutRuleToken t
          mExpectingOCurly <- getAlrExpectingOCurly
          let thisLoc = getLoc t
              thisCol = srcSpanStartCol thisLoc
-             newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
+             newLine = (lastLoc == noSrcSpan)
+                    || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc)
          case (unLoc t, context, mExpectingOCurly) of
              -- I think our implicit open-curly handling is slightly
              -- different to John's, in how it interacts with newlines
@@ -1983,16 +1993,18 @@ alternativeLayoutRuleToken t
                     setNextToken t
                     lexTokenAlr
              (_, ALRLayout _ col : ls, Just expectingOCurly)
-              | thisCol > col ->
+              | (thisCol > col) ||
+                (thisCol == col &&
+                 isNonDecreasingIntentation expectingOCurly) ->
                  do setAlrExpectingOCurly Nothing
                     setALRContext (ALRLayout expectingOCurly thisCol : context)
                     setNextToken t
                     return (L thisLoc ITocurly)
               | otherwise ->
                  do setAlrExpectingOCurly Nothing
-                    setPendingImplicitTokens [L thisLoc ITccurly]
+                    setPendingImplicitTokens [L lastLoc ITccurly]
                     setNextToken t
-                    return (L thisLoc ITocurly)
+                    return (L lastLoc ITocurly)
              (_, _, Just expectingOCurly) ->
                  do setAlrExpectingOCurly Nothing
                     setALRContext (ALRLayout expectingOCurly thisCol : context)
@@ -2081,6 +2093,10 @@ isALRclose ITccurly = True
 isALRclose ITcubxparen = True
 isALRclose _        = False
 
+isNonDecreasingIntentation :: ALRLayout -> Bool
+isNonDecreasingIntentation ALRLayoutDo = True
+isNonDecreasingIntentation _           = False
+
 containsCommas :: Token -> Bool
 containsCommas IToparen = True
 containsCommas ITobrack = True