module Language.Haskell.Refact.Utils.LocUtils(
SimpPos,unmodified,modified
, simpPos0
, nullSrcSpan
, showToks
, whiteSpaceTokens
, realSrcLocFromTok
, isWhite
, notWhite
, isWhiteSpace
, isWhiteSpaceOrIgnored
, isIgnored
, isIgnoredNonComment
,isComment ,isMultiLineComment
,isOpenSquareBracket,isCloseSquareBracket ,isIn ,isComma ,isBar --,isMinus,
,endsWithNewLn,startsWithNewLn,hasNewLn ,compressPreNewLns,compressEndNewLns
, lengthOfLastLine
, getToks
,replaceTokNoReAlign,deleteToks,doRmWhites
, srcLocs
, getSrcSpan, getAllSrcLocs
, getBiggestStartEndLoc
,extendForwards,extendBackwards
, startEndLocIncFowComment
, startEndLocIncComments, startEndLocIncComments'
, tokenise
, basicTokenise
, prettyprintPatList
, groupTokensByLine
, toksOnSameLine
, addLocInfo
, getLineOffset
, tokenCol
, tokenColEnd
, tokenRow
, tokenPos
, tokenPosEnd
, tokenSrcSpan
, tokenCon
, increaseSrcSpan
, getGhcLoc
, getGhcLocEnd
, getLocatedStart
, getLocatedEnd
, getStartEndLoc
, startEndLocGhc
, realSrcLocEndTok
, fileNameFromTok
, splitToks
, emptyList, nonEmptyList
, divideComments
, notWhiteSpace
, isDoubleColon
, isEmpty
, isWhereOrLet
, isWhere
, isLet
, isElse
, isThen
, isOf
, isDo
, getIndentOffset
, splitOnNewLn
, tokenLen
, newLnToken
, newLinesToken
, monotonicLineToks
, reSequenceToks
, mkToken
, mkZeroToken
, markToken
, isMarked
, addOffsetToToks
, matchTokenPos
, rmOffsetFromToks
) where
import qualified FastString as GHC
import qualified GHC as GHC
import qualified Lexer as GHC
import qualified SrcLoc as GHC
import qualified Data.Generics as SYB
import qualified GHC.SYB.Utils as SYB
import Language.Haskell.Refact.Utils.GhcUtils
import Language.Haskell.Refact.Utils.GhcVersionSpecific
import Language.Haskell.Refact.Utils.Monad
import Language.Haskell.Refact.Utils.TypeSyn
import Data.Maybe
import Data.List
showToks :: [PosToken] -> String
showToks toks = show $ map (\(t@(GHC.L _ tok),s) ->
((getLocatedStart t, getLocatedEnd t),tok,s)) toks
instance Show (GHC.GenLocated GHC.SrcSpan GHC.Token) where
show t@(GHC.L _l tok) = show ((getLocatedStart t, getLocatedEnd t),tok)
unmodified, modified :: Bool
unmodified = False
modified = True
simpPos0 :: (Int,Int)
simpPos0 = (0,0)
nullSrcSpan :: GHC.SrcSpan
nullSrcSpan = GHC.UnhelpfulSpan $ GHC.mkFastString "HaRe nullSrcSpan"
isWhite :: PosToken -> Bool
isWhite (GHC.L _ (GHC.ITeof),_) = True
isWhite (GHC.L _ (GHC.ITdocCommentNext _) ,_) = True
isWhite (GHC.L _ (GHC.ITdocCommentPrev _) ,_) = True
isWhite (GHC.L _ (GHC.ITdocCommentNamed _),_) = True
isWhite (GHC.L _ (GHC.ITdocSection _ _) ,_) = True
isWhite (GHC.L _ (GHC.ITdocOptions _) ,_) = True
isWhite (GHC.L _ (GHC.ITdocOptionsOld _) ,_) = True
isWhite (GHC.L _ (GHC.ITlineComment _) ,_) = True
isWhite (GHC.L _ (GHC.ITblockComment _) ,_) = True
isWhite (GHC.L _ _ ,_) = False
notWhite :: PosToken -> Bool
notWhite = not.isWhite
isMultiLineComment :: PosToken -> Bool
isMultiLineComment ((GHC.L _ t),s) = case t of
GHC.ITblockComment _ -> (isJust (find (=='\n') s))
_ -> False
isOpenSquareBracket :: PosToken -> Bool
isOpenSquareBracket ((GHC.L _ t),_s) = case t of
GHC.ITobrack -> True
_ -> False
isCloseSquareBracket :: PosToken -> Bool
isCloseSquareBracket ((GHC.L _ t),_s) = case t of
GHC.ITcbrack -> True
_ -> False
isIn :: PosToken -> Bool
isIn ((GHC.L _ t),_s) = case t of
GHC.ITin -> True
_ -> False
isComma :: PosToken -> Bool
isComma ((GHC.L _ t),_s) = case t of
GHC.ITcomma -> True
_ -> False
isBar :: PosToken -> Bool
isBar ((GHC.L _ t),_s) = case t of
GHC.ITvbar -> True
_ -> False
endsWithNewLn::PosToken->Bool
endsWithNewLn (_,s) =if s==[] then False
else (glast "endsWithNewLn" s=='\n')
startsWithNewLn::PosToken->Bool
startsWithNewLn (_,s) =if s==[] then False
else ((ghead "starsWithNewLn" s)=='\n')
hasNewLn :: PosToken -> Bool
hasNewLn (GHC.L l _,_) = case l of
GHC.RealSrcSpan ss -> (GHC.srcSpanStartLine ss /= GHC.srcSpanEndLine ss)
_ -> False
lastNonSpaceToken::[PosToken] -> PosToken
lastNonSpaceToken toks=case dropWhile isWhiteSpaceOrIgnored (reverse toks) of
[] -> defaultToken
l -> ghead "lastNonSpaceToken" l
compressPreNewLns::[PosToken] -> [PosToken]
compressPreNewLns toks = toks
compressEndNewLns::[PosToken]->[PosToken]
compressEndNewLns toks = toks
defaultToken :: PosToken
defaultToken = (GHC.noLoc (GHC.ITlineComment "defaultToken"), "defaultToken")
prettyprintPatList :: (t -> String) -> Bool -> [t] -> String
prettyprintPatList prpr beginWithSpace t
= replaceTabBySpaces $ if beginWithSpace then format1 t else format2 t
where
format1 tt = foldl (\x y -> x++ " "++ prpr y) "" tt
format2 [] = ""
format2 [p] = (prpr p)
format2 (p:ps) = (prpr p) ++ " " ++ format2 ps
replaceTabBySpaces::String->String
replaceTabBySpaces []=[]
replaceTabBySpaces (s:ss)
=if s=='\t' then replicate 8 ' ' ++replaceTabBySpaces ss
else s:replaceTabBySpaces ss
tokenise :: GHC.RealSrcLoc -> Int -> Bool -> String -> IO [PosToken]
tokenise _ _ _ [] = return []
tokenise startPos colOffset withFirstLineIndent str
= let str' = case lines str of
(ln:[]) -> addIndent ln ++ if glast "tokenise" str=='\n' then "\n" else ""
(ln:lns)-> addIndent ln ++ "\n" ++ concatMap (\n->replicate colOffset ' '++n++"\n") lns
[] -> []
str'' = if glast "tokenise" str' == '\n' && glast "tokenise" str /= '\n'
then genericTake (length str' 1) str'
else str'
toks = lexStringToRichTokens startPos str''
in toks
where
addIndent ln = if withFirstLineIndent
then replicate colOffset ' '++ ln
else ln
basicTokenise :: String -> IO [PosToken]
basicTokenise str = tokenise startPos 0 False str
where
startPos = (GHC.mkRealSrcLoc (GHC.mkFastString "foo") 0 1)
addLocInfo :: (GHC.LHsBind GHC.Name,[PosToken])
-> RefactGhc (GHC.LHsBind GHC.Name,[PosToken])
addLocInfo (decl, toks) = return (decl, toks)
lengthOfLastLine::[PosToken]->Int
lengthOfLastLine [] = 0
lengthOfLastLine toks
= let rtoks = reverse toks
x = head rtoks
(toks1,toks2)=break (\x' -> tokenRow x /= tokenRow x') rtoks
in if length toks2 == 0
then sum (map tokenLen toks1)
else sum (map tokenLen toks1) + lastLineLenOfToken (ghead "lengthOfLastLine" toks2)
where
lastLineLenOfToken (_,s)=(length.(takeWhile (\x->x/='\n')).reverse) s
getToks :: (SimpPos,SimpPos) -> [PosToken] -> [PosToken]
getToks (startPos,endPos) toks =
let (_,toks2) = break (\t -> tokenPos t >= startPos) toks
(toks21,_toks22) = break (\t -> tokenPos t > endPos) toks2
in
(toks21)
replaceTokNoReAlign:: [PosToken] -> SimpPos -> PosToken -> [PosToken]
replaceTokNoReAlign toks pos newTok =
toks1 ++ [newTok'] ++ toksRest
where
(toks1,toks2) = break (\t -> tokenPos t >= pos && tokenLen t > 0) toks
toksRest = if (emptyList toks2) then [] else (gtail "replaceTokNoReAlign" toks2)
oldTok = if (emptyList toks2) then newTok else (ghead "replaceTokNoReAlign" toks2)
newTok' = markToken $ matchTokenPos oldTok newTok
matchTokenPos :: PosToken -> PosToken -> PosToken
matchTokenPos (GHC.L l _,_) (GHC.L _ t,s) = (GHC.L l t,s)
getLineOffset :: [PosToken] -> SimpPos -> Int
getLineOffset toks pos
= let (ts1, ts2) = break (\t->tokenPos t >= pos) toks
in if (emptyList ts2)
then error "HaRe error: position does not exist in the token stream!"
else let (sl,_) = splitOnNewLn $ reverse ts1
in tokenCol (glast "getLineOffset" sl)
deleteToks:: [PosToken] -> SimpPos -> SimpPos -> [PosToken]
deleteToks toks startPos endPos
= case after of
(_:_) -> let nextPos =tokenPos $ ghead "deleteToks1" after
oldOffset = getIndentOffset toks nextPos
newOffset = getIndentOffset (toks1++before++after) nextPos
in toks1++before++adjustLayout (after++toks22) oldOffset newOffset
_ -> if (emptyList toks22)
then toks1++before
else let toks22'=let nextOffset = getIndentOffset toks (tokenPos (ghead "deleteToks2" toks22))
in if isMultiLineComment (lastNonSpaceToken toks21)
then whiteSpaceTokens (1111, 0) (nextOffset1) ++ toks22
else toks22
in if endsWithNewLn (last (toks1++before)) || startsWithNewLn (ghead "deleteToks3" toks22')
then toks1++before++toks22'
else toks1++before++[newLnToken (last before)]++toks22'
where
(toks1, toks2) = let (ts1, ts2) = break (\t->tokenPos t >= startPos) toks
(ts11, ts12) = break hasNewLn (reverse ts1)
in (reverse ts12, reverse ts11 ++ ts2)
(toks21, toks22)=let (ts1, ts2) = break (\t -> tokenPos t >= endPos) toks2
(ts11, ts12) = break hasNewLn ts2
in (ts1++ts11++if (emptyList ts12) then [] else [ghead "deleteToks4" ts12], if (emptyList ts12) then [] else gtail "deleteToks5" ts12)
before = takeWhile (\t->tokenPos t<startPos) toks21
after = let ts= dropWhile (\t -> tokenPosEnd t <= endPos) toks21
in if (emptyList ts) then ts
else ts
adjustLayout:: [PosToken] -> Int -> Int -> [PosToken]
adjustLayout [] _ _ = []
adjustLayout toks _oldOffset _newOffset = toks
doRmWhites::Int -> [PosToken] -> [PosToken]
doRmWhites 0 ts = ts
doRmWhites _ [] = []
doRmWhites _ ts = ts
whiteSpaceTokens :: (Int,Int) -> Int -> [PosToken]
whiteSpaceTokens (_row, _col) _n = []
srcLocs::(SYB.Data t) => t -> [SimpPos]
srcLocs t =(nub.srcLocs') t \\ [simpPos0]
where srcLocs'= SYB.everythingStaged SYB.Parser (++) []
([]
`SYB.mkQ` pnt
`SYB.extQ` sn
`SYB.extQ` literalInExp
`SYB.extQ` literalInPat)
pnt :: GHC.GenLocated GHC.SrcSpan GHC.Name -> [SimpPos]
pnt (GHC.L l _) = [getGhcLoc l]
sn :: GHC.HsModule GHC.RdrName -> [SimpPos]
sn (GHC.HsModule (Just (GHC.L l _)) _ _ _ _ _) = [getGhcLoc l]
sn _ = []
literalInExp :: GHC.LHsExpr GHC.Name -> [SimpPos]
literalInExp (GHC.L l _) = [getGhcLoc l]
literalInPat :: GHC.LPat GHC.Name -> [SimpPos]
literalInPat (GHC.L l _) = [getGhcLoc l]
getBiggestStartEndLoc :: (SYB.Data t) => t -> (SimpPos,SimpPos)
getBiggestStartEndLoc t = (start,end)
where
locs = getAllSrcLocs t
start = minimum $ map fst locs
end = maximum $ map snd locs
getAllSrcLocs::(SYB.Data t) => t -> [(SimpPos,SimpPos)]
getAllSrcLocs t = res t
where
res = SYB.everythingStaged SYB.Renamer (++) []
([]
`SYB.mkQ` bind
`SYB.extQ` sig
`SYB.extQ` pnt
`SYB.extQ` sn
`SYB.extQ` literalInExp
`SYB.extQ` literalInPat
`SYB.extQ` importDecl
`SYB.extQ` ty
)
bind :: GHC.GenLocated GHC.SrcSpan (GHC.HsBind GHC.Name) -> [(SimpPos,SimpPos)]
bind (GHC.L l _) = [(getGhcLoc l,getGhcLocEnd l)]
sig :: (GHC.LSig GHC.Name) -> [(SimpPos,SimpPos)]
sig (GHC.L l _) = [(getGhcLoc l,getGhcLocEnd l)]
ty :: (GHC.LHsType GHC.Name) -> [(SimpPos,SimpPos)]
ty (GHC.L l _) = [(getGhcLoc l,getGhcLocEnd l)]
pnt :: GHC.GenLocated GHC.SrcSpan GHC.Name -> [(SimpPos,SimpPos)]
pnt (GHC.L l _) = [(getGhcLoc l,getGhcLocEnd l)]
sn :: GHC.HsModule GHC.RdrName -> [(SimpPos,SimpPos)]
sn (GHC.HsModule (Just (GHC.L l _)) _ _ _ _ _) = [(getGhcLoc l,getGhcLocEnd l)]
sn _ = []
literalInExp :: GHC.LHsExpr GHC.Name -> [(SimpPos,SimpPos)]
literalInExp (GHC.L l _) = [(getGhcLoc l,getGhcLocEnd l)]
literalInPat :: GHC.LPat GHC.Name -> [(SimpPos,SimpPos)]
literalInPat (GHC.L l _) = [(getGhcLoc l,getGhcLocEnd l)]
importDecl :: GHC.LImportDecl GHC.Name -> [(SimpPos,SimpPos)]
importDecl (GHC.L l _) = [(getGhcLoc l,getGhcLocEnd l)]
extendBackwards :: [PosToken] -> (SimpPos ,SimpPos) -> (PosToken -> Bool)
-> (SimpPos,SimpPos)
extendBackwards toks (startLoc,endLoc) condFun
= let toks1 = takeWhile (\t->tokenPos t /= startLoc) toks
firstLoc = case (dropWhile (not.condFun) (reverse toks1)) of
[] -> startLoc
l -> (tokenPos.ghead "extendBackwards") l
in (firstLoc, endLoc)
extendForwards :: [PosToken] -> (SimpPos ,SimpPos) -> (PosToken -> Bool)
-> (SimpPos,SimpPos)
extendForwards toks (startLoc,endLoc) condFun
= let toks1 = gtail "extendForwards" $ dropWhile (\t->tokenPosEnd t /= endLoc) toks
lastLoc = case (dropWhile (condFun) toks1) of
[] ->endLoc
l ->(tokenPos. ghead "extendForwards") l
in (startLoc, lastLoc)
startEndLocIncFowComment::(SYB.Data t)=>[PosToken]->t->(SimpPos,SimpPos)
startEndLocIncFowComment toks t
= let (startLoc,_endLoc)=getStartEndLoc t
(_,endLocIncComments) = startEndLocIncComments toks t
in (startLoc, endLocIncComments)
tokenCol :: PosToken -> Int
tokenCol (GHC.L l _,_) = c where (_,c) = getGhcLoc l
tokenColEnd :: PosToken -> Int
tokenColEnd (GHC.L l _,_) = c where (_,c) = getGhcLocEnd l
tokenRow :: PosToken -> Int
tokenRow (GHC.L l _,_) = r where (r,_) = getGhcLoc l
tokenPos :: (GHC.GenLocated GHC.SrcSpan t1, t) -> SimpPos
tokenPos (GHC.L l _,_) = getGhcLoc l
tokenPosEnd :: (GHC.GenLocated GHC.SrcSpan t1, t) -> SimpPos
tokenPosEnd (GHC.L l _,_) = getGhcLocEnd l
tokenSrcSpan :: (GHC.Located t1, t) -> GHC.SrcSpan
tokenSrcSpan (GHC.L l _,_) = l
tokenCon :: PosToken -> String
tokenCon (_,s) = s
increaseSrcSpan :: SimpPos -> PosToken -> PosToken
increaseSrcSpan (lineAmount,colAmount) posToken@(lt@(GHC.L _l t), s)
= (GHC.L newL t, s)
where
filename = fileNameFromTok posToken
newL = GHC.mkSrcSpan (GHC.mkSrcLoc filename startLine startCol)
(GHC.mkSrcLoc filename endLine endCol)
(startLine, startCol) = add1 $ getLocatedStart lt
(endLine, endCol) = add1 $ getLocatedEnd lt
add1 :: (Int, Int) -> (Int, Int)
add1 (r,c) = (r+lineAmount,c+colAmount)
getGhcLoc :: GHC.SrcSpan -> (Int, Int)
getGhcLoc (GHC.RealSrcSpan ss) = (GHC.srcSpanStartLine ss, GHC.srcSpanStartCol ss)
getGhcLoc (GHC.UnhelpfulSpan _) = (1,1)
getGhcLocEnd :: GHC.SrcSpan -> (Int, Int)
getGhcLocEnd (GHC.RealSrcSpan ss) = (GHC.srcSpanEndLine ss, GHC.srcSpanEndCol ss)
getGhcLocEnd (GHC.UnhelpfulSpan _) = (1,1)
getLocatedStart :: GHC.GenLocated GHC.SrcSpan t -> (Int, Int)
getLocatedStart (GHC.L l _) = getGhcLoc l
getLocatedEnd :: GHC.GenLocated GHC.SrcSpan t -> (Int, Int)
getLocatedEnd (GHC.L l _) = getGhcLocEnd l
getStartEndLoc :: (SYB.Data t) => t -> (SimpPos,SimpPos)
getStartEndLoc t =
let
ss = getSrcSpan t
in
case ss of
Just l -> startEndLocGhc (GHC.L l ss)
Nothing -> ((0,0),(0,0))
startEndLocGhc :: GHC.Located b -> (SimpPos,SimpPos)
startEndLocGhc (GHC.L l _) =
case l of
(GHC.RealSrcSpan ss) ->
((GHC.srcSpanStartLine ss,GHC.srcSpanStartCol ss),
(GHC.srcSpanEndLine ss, GHC.srcSpanEndCol ss))
(GHC.UnhelpfulSpan _) -> ((0,0),(0,0))
realSrcLocFromTok :: PosToken -> GHC.RealSrcLoc
realSrcLocFromTok (GHC.L (GHC.RealSrcSpan srcspan) _,_) = GHC.realSrcSpanStart srcspan
realSrcLocFromTok (GHC.L _ _,_) = GHC.mkRealSrcLoc (GHC.mkFastString "") 1 1
realSrcLocEndTok :: PosToken -> GHC.RealSrcLoc
realSrcLocEndTok (GHC.L (GHC.RealSrcSpan srcspan) _,_) = GHC.realSrcSpanEnd srcspan
realSrcLocEndTok (GHC.L _ _,_) = GHC.mkRealSrcLoc (GHC.mkFastString "") 1 1
fileNameFromTok :: PosToken -> GHC.FastString
fileNameFromTok (GHC.L (GHC.RealSrcSpan srcspan) _,_) = GHC.srcSpanFile srcspan
fileNameFromTok (GHC.L _ _,_) = GHC.mkFastString "f"
splitToks::(SimpPos,SimpPos)->[PosToken]->([PosToken],[PosToken],[PosToken])
splitToks (startPos, endPos) toks =
let (toks1,toks2) = break (\t -> tokenPos t >= startPos) toks
(toks21,toks22) = break (\t -> tokenPos t >= endPos) toks2
in
(toks1,toks21,toks22)
emptyList :: [t] -> Bool
emptyList [] = True
emptyList _ = False
nonEmptyList :: [t] -> Bool
nonEmptyList [] = False
nonEmptyList _ = True
startEndLocIncComments::(SYB.Data t) => [PosToken] -> t -> (SimpPos,SimpPos)
startEndLocIncComments toks t = startEndLocIncComments' toks (getStartEndLoc t)
startEndLocIncComments' :: [PosToken] -> (SimpPos,SimpPos) -> (SimpPos,SimpPos)
startEndLocIncComments' toks (startLoc,endLoc) =
let
(begin,middle,end) = splitToks (startLoc,endLoc) toks
notIgnored tt = not (isWhiteSpaceOrIgnored tt)
(leadinr,leadr) = break notIgnored $ reverse begin
leadr' = filter (\t -> not (isEmpty t)) leadr
prevLine = if (emptyList leadr') then 0 else (tokenRow $ ghead "startEndLocIncComments'1" leadr')
firstLine = if (emptyList middle) then 0 else (tokenRow $ ghead "startEndLocIncComments'1" middle)
(_nonleadComments,leadComments') = divideComments prevLine firstLine $ reverse leadinr
leadComments = dropWhile (\tt -> (isEmpty tt)) leadComments'
(trail,trailrest) = break notWhiteSpace end
trail' = filter (\t -> not (isEmpty t)) trail
lastLine = if (emptyList middle)
then 0
else (tokenRow $ glast "startEndLocIncComments'2" middle)
nextLine = if (emptyList trailrest)
then 100000
else (tokenRow $ ghead "startEndLocIncComments'2" trailrest)
(trailComments,_) = divideComments lastLine nextLine trail'
middle' = leadComments ++ middle ++ trailComments
in
if (emptyList middle')
then ((0,0),(0,0))
else ((tokenPos $ ghead "startEndLocIncComments 4" middle'),(tokenPosEnd $ last middle'))
divideComments :: Int -> Int -> [PosToken] -> ([PosToken],[PosToken])
divideComments startLine endLine toks = (first,second)
where
groups = groupBy groupByAdjacent toks
groupLines = map (\ts -> ((tokenRow $ ghead "divideComments" ts,tokenRow $ glast "divideComments" ts),ts)) groups
groupLines' = [((startLine,startLine),[])] ++ groupLines ++ [((endLine,endLine),[])]
groupGaps = go [] groupLines'
biggest = maximum $ map fst groupGaps
(firsts,seconds) = break (\(g,_) -> g >= biggest) groupGaps
first = concatMap snd firsts
second = concatMap snd seconds
groupByAdjacent :: PosToken -> PosToken -> Bool
groupByAdjacent a b = 1 + tokenRow a == tokenRow b
go :: [(Int,[PosToken])] -> [((Int,Int),[PosToken])] -> [(Int,[PosToken])]
go acc [] = acc
go acc [_x] = acc
go acc (((_s1,e1),_t1):b@((s2,_e2),t2):xs) = go (acc ++ [((s2 e1),t2)] ) (b:xs)
isWhiteSpace :: PosToken -> Bool
isWhiteSpace tok = isComment tok || isEmpty tok
notWhiteSpace :: PosToken -> Bool
notWhiteSpace tok = not (isWhiteSpace tok)
isWhiteSpaceOrIgnored :: PosToken -> Bool
isWhiteSpaceOrIgnored tok = isWhiteSpace tok || isIgnored tok
isIgnored :: PosToken -> Bool
isIgnored tok = isThen tok || isElse tok || isIn tok || isDo tok
isIgnoredNonComment :: PosToken -> Bool
isIgnoredNonComment tok = isThen tok || isElse tok || isWhiteSpace tok
isDoubleColon :: PosToken -> Bool
isDoubleColon ((GHC.L _ (GHC.ITdcolon)), "::") = True
isDoubleColon _ = False
isComment :: PosToken -> Bool
isComment ((GHC.L _ (GHC.ITdocCommentNext _)),_s) = True
isComment ((GHC.L _ (GHC.ITdocCommentPrev _)),_s) = True
isComment ((GHC.L _ (GHC.ITdocCommentNamed _)),_s) = True
isComment ((GHC.L _ (GHC.ITdocSection _ _)),_s) = True
isComment ((GHC.L _ (GHC.ITdocOptions _)),_s) = True
isComment ((GHC.L _ (GHC.ITdocOptionsOld _)),_s) = True
isComment ((GHC.L _ (GHC.ITlineComment _)),_s) = True
isComment ((GHC.L _ (GHC.ITblockComment _)),_s) = True
isComment ((GHC.L _ _),_s) = False
isEmpty :: PosToken -> Bool
isEmpty ((GHC.L _ (GHC.ITsemi)), "") = True
isEmpty ((GHC.L _ (GHC.ITvocurly)), "") = True
isEmpty ((GHC.L _ _), "") = True
isEmpty _ = False
isWhereOrLet :: PosToken -> Bool
isWhereOrLet t = isWhere t || isLet t
isWhere :: PosToken -> Bool
isWhere ((GHC.L _ t),_s) = case t of
GHC.ITwhere -> True
_ -> False
isLet :: PosToken -> Bool
isLet ((GHC.L _ t),_s) = case t of
GHC.ITlet -> True
_ -> False
isElse :: PosToken -> Bool
isElse ((GHC.L _ t),_s) = case t of
GHC.ITelse -> True
_ -> False
isThen :: PosToken -> Bool
isThen ((GHC.L _ t),_s) = case t of
GHC.ITthen -> True
_ -> False
isOf :: PosToken -> Bool
isOf ((GHC.L _ t),_s) = case t of
GHC.ITof -> True
_ -> False
isDo :: PosToken -> Bool
isDo ((GHC.L _ t),_s) = case t of
GHC.ITdo -> True
_ -> False
getSrcSpan::(SYB.Data t) => t -> Maybe GHC.SrcSpan
getSrcSpan t = res t
where
res = somethingStaged SYB.Renamer Nothing
(Nothing
`SYB.mkQ` bind
`SYB.extQ` sig
`SYB.extQ` pnt
`SYB.extQ` literalInExp
`SYB.extQ` literalInPat
`SYB.extQ` importDecl
`SYB.extQ` ty
)
bind :: GHC.GenLocated GHC.SrcSpan (GHC.HsBind GHC.Name) -> Maybe GHC.SrcSpan
bind (GHC.L l _) = Just l
sig :: (GHC.LSig GHC.Name) -> Maybe GHC.SrcSpan
sig (GHC.L l _) = Just l
ty :: (GHC.LHsType GHC.Name) -> Maybe GHC.SrcSpan
ty (GHC.L l _) = Just l
pnt :: GHC.GenLocated GHC.SrcSpan GHC.Name -> Maybe GHC.SrcSpan
pnt (GHC.L l _) = Just l
literalInExp :: GHC.LHsExpr GHC.Name -> Maybe GHC.SrcSpan
literalInExp (GHC.L l _) = Just l
literalInPat :: GHC.LPat GHC.Name -> Maybe GHC.SrcSpan
literalInPat (GHC.L l _) = Just l
importDecl :: GHC.LImportDecl GHC.Name -> Maybe GHC.SrcSpan
importDecl (GHC.L l _) = Just l
getIndentOffset :: [PosToken] -> SimpPos -> Int
getIndentOffset [] _pos = 1
getIndentOffset _toks (0,0) = 1
getIndentOffset toks pos
= let (ts1, ts2) = break (\t->tokenPos t >= pos) toks
in if (emptyList ts2)
then error "HaRe error: position does not exist in the token stream!"
else let (sl,_) = splitOnNewLn $ reverse ts1
(sls,_) = break isWhereOrLet $ filter (\t -> tokenLen t > 0) sl
firstTok = (glast "getIndentOffset" sls)
in if startLayout firstTok
then if (length sls > 1)
then tokenOffset (last $ init sls)
else 4 + tokenOffset firstTok
else tokenOffset firstTok
where
tokenOffset t = (tokenCol t) 1
startLayout ((GHC.L _ (GHC.ITdo)),_) = True
startLayout ((GHC.L _ (GHC.ITin)),_) = True
startLayout ((GHC.L _ (GHC.ITlet)),_) = True
startLayout ((GHC.L _ (GHC.ITwhere)),_) = True
startLayout _ = False
splitOnNewLn :: [PosToken] -> ([PosToken],[PosToken])
splitOnNewLn toks = go [] toks
where
go [] [] = ([],[])
go ss [] = (ss,[])
go [] xs = go [head xs] (tail xs)
go ss xs
| onSameLn (glast "splitOnNewLn" ss) (head xs) = go (ss ++ [head xs]) (tail xs)
| otherwise = (ss,xs)
tokenLen :: PosToken -> Int
tokenLen (_,s) = length s
newLnToken :: PosToken -> PosToken
newLnToken tok = newLinesToken 1 tok
newLinesToken :: Int -> PosToken -> PosToken
newLinesToken jump (GHC.L l _,_) = (GHC.L l' GHC.ITvocurly,"")
where
l' = case l of
GHC.RealSrcSpan ss ->
let
loc = GHC.mkSrcLoc (GHC.srcSpanFile ss) (jump + GHC.srcSpanEndLine ss) 1
in
GHC.mkSrcSpan loc loc
_ -> l
groupTokensByLine :: [PosToken] -> [[PosToken]]
groupTokensByLine xs = groupBy toksOnSameLine xs
toksOnSameLine :: PosToken -> PosToken -> Bool
toksOnSameLine t1 t2 = tokenRow t1 == tokenRow t2
monotonicLineToks :: [PosToken] -> [PosToken]
monotonicLineToks toks = goMonotonicLineToks (0,0) toks
goMonotonicLineToks :: SimpPos -> [PosToken] -> [PosToken]
goMonotonicLineToks _ [] = []
goMonotonicLineToks _ [t] = [t]
goMonotonicLineToks (orow,ocol) (t1:t2:ts)
= t1:goMonotonicLineToks offset' (t2':ts)
where
offset' = if (tokenRow t1 orow) > (tokenRow t2)
then (orow + (tokenRow t1) tokenRow t2 + 1, ocol)
else (orow,ocol)
t2' = increaseSrcSpan offset' t2
reSequenceToks :: [PosToken] -> [PosToken]
reSequenceToks toks = toks
mkToken::GHC.Token -> SimpPos -> String -> PosToken
mkToken t (row,col) c = ((GHC.L l t),c)
where
filename = (GHC.mkFastString "f")
l = GHC.mkSrcSpan (GHC.mkSrcLoc filename row col) (GHC.mkSrcLoc filename row (col + (length c) ))
mkZeroToken :: PosToken
mkZeroToken = mkToken GHC.ITsemi (0,0) ""
addOffsetToToks :: SimpPos -> [PosToken] -> [PosToken]
addOffsetToToks (r,c) toks = map (\t -> increaseSrcSpan (r,c) t) toks
onSameLn :: PosToken -> PosToken -> Bool
onSameLn (GHC.L l1 _,_) (GHC.L l2 _,_) = r1 == r2
where
(r1,_) = getGhcLoc l1
(r2,_) = getGhcLoc l2
tokenFileMark :: GHC.FastString
tokenFileMark = GHC.mkFastString "HaRe"
markToken :: PosToken -> PosToken
markToken tok = tok'
where
(GHC.L l t,s) = tok
tok' = (GHC.L (GHC.RealSrcSpan l') t,s)
l' = case l of
GHC.RealSrcSpan ss ->
GHC.mkRealSrcSpan
(GHC.mkRealSrcLoc tokenFileMark (GHC.srcSpanStartLine ss) (GHC.srcSpanStartCol ss))
(GHC.mkRealSrcLoc tokenFileMark (GHC.srcSpanEndLine ss) (GHC.srcSpanEndCol ss))
_ -> error $ "markToken: expecting a real SrcSpan, got"
isMarked :: PosToken -> Bool
isMarked (GHC.L l _,_) =
case l of
GHC.RealSrcSpan ss -> GHC.srcSpanFile ss == tokenFileMark
_ -> False
rmOffsetFromToks :: [PosToken] -> [PosToken]
rmOffsetFromToks [] = []
rmOffsetFromToks toks = toks'
where
ro' = tokenRow $ head toks
co' = tokenCol $ head toks
toks' = addOffsetToToks (ro',co') toks