-- qualified varids.
{
-{-# OPTIONS -Wwarn -w #-}
--- The above -Wwarn supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
---
--- Note that Alex itself generates code with with some unused bindings and
--- without type signatures, so removing the flag might not be possible.
+-- XXX The above flags turn off warnings in the generated code:
+{-# OPTIONS_GHC -fno-warn-unused-matches #-}
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+-- But alex still generates some code that causes the "lazy unlifted bindings"
+-- warning, and old compilers don't know about it so we can't easily turn
+-- it off, so for now we use the sledge hammer:
+{-# OPTIONS_GHC -w #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
,("→", 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).
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
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
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
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
setALRContext (ALRLayout expectingOCurly thisCol : context)
setNextToken t
return (L thisLoc ITocurly)
+ -- We do the [] cases earlier than in the spec, as we
+ -- have an actual EOF token
+ (ITeof, ALRLayout _ _ : ls, _) ->
+ do setALRContext ls
+ setNextToken t
+ return (L thisLoc ITccurly)
+ (ITeof, _, _) ->
+ return t
+ -- the other ITeof case omitted; general case below covers it
(ITin, ALRLayout ALRLayoutLet _ : ls, _)
| newLine ->
do setPendingImplicitTokens [t]
setALRContext ls
return (L thisLoc ITccurly)
- (_, ls@(ALRLayout _ col : _), _)
- | newLine && thisCol <= col ->
- do let f ls'@(ALRLayout _ col' : ls'')
- | thisCol < col' = case f ls'' of
- (ts, ls''') ->
- (L thisLoc ITccurly : ts, ls''')
- | thisCol == col' = ([L thisLoc ITsemi], ls')
- | otherwise = ([], ls')
- f ls' = ([], ls')
- case f ls of
- (t' : ts, ls') ->
- do setPendingImplicitTokens ts
- setNextToken t
- return t'
- _ -> panic "Layout rule: [] when considering newline"
+ (_, ALRLayout _ col : ls, _)
+ | newLine && thisCol == col ->
+ do setNextToken t
+ return (L thisLoc ITsemi)
+ | newLine && thisCol < col ->
+ do 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)
(u, _, _)
| isALRopen u ->
do setALRContext (ALRNoLayout (containsCommas u) : context)
do setALRContext ls
setPendingImplicitTokens [t]
return (L thisLoc ITccurly)
- (ITin, _ : ls, _) ->
+ (ITin, ALRLayout _ _ : ls, _) ->
do setALRContext ls
setNextToken t
return (L thisLoc ITccurly)
setPendingImplicitTokens [t]
return (L thisLoc ITccurly)
-- the other ITwhere case omitted; general case below covers it
- -- The first [] case comes before the general case, as we
- -- have an actual EOF token
- (ITeof, ALRLayout _ _ : ls, _) ->
- do setALRContext ls
- setNextToken t
- return (L thisLoc ITccurly)
- -- the other ITeof case omitted; general case below covers it
(_, _, _) -> return t
isALRopen :: Token -> Bool
isALRopen IToparen = True
isALRopen ITobrack = True
isALRopen ITocurly = True
+-- GHC Extensions:
+isALRopen IToubxparen = True
isALRopen _ = False
isALRclose :: Token -> Bool
isALRclose ITcparen = True
isALRclose ITcbrack = True
isALRclose ITccurly = True
+-- GHC Extensions:
+isALRclose ITcubxparen = True
isALRclose _ = False
+isNonDecreasingIntentation :: ALRLayout -> Bool
+isNonDecreasingIntentation ALRLayoutDo = True
+isNonDecreasingIntentation _ = False
+
containsCommas :: Token -> Bool
containsCommas IToparen = True
containsCommas ITobrack = True
+-- GHC Extensions:
+containsCommas IToubxparen = True
containsCommas _ = False
topNoLayoutContainsCommas :: [ALRContext] -> Bool
projects / ghc-hetmet.git / blobdiff