HaRe-0.6: refactorer/RefacLocUtils.hs
module RefacLocUtils(module HsTokens,PosToken, simpPos,
SimpPos,unmodified,modified,simpPos0,ghead,glast,gfromJust,gtail,
tokenCol, tokenRow, tokenPos,tokenCon,tokenLen,lengthOfToks,
mkToken,defaultToken,newLnToken,whiteSpacesToken,whiteSpaceTokens,isWhite,
notWhite,isWhiteSpace,isNewLn,isCommentStart,isComment,
isNestedComment,isMultiLineComment,isOpenBracket,isCloseBracket,
isOpenSquareBracket,isCloseSquareBracket,isOpenBrace,isConid,
isLit,isWhereOrLet,isWhere,isLet,isIn,isCase,isDo,isIf,isForall,
isHiding,isModule,isComma,isEqual,isLambda,isIrrefute,isBar,isMinus,
endsWithNewLn,startsWithNewLn,hasNewLn,startsWithEmptyLn,
lastNonSpaceToken,firstNonSpaceToken,compressPreNewLns,compressEndNewLns,
lengthOfLastLine,
updateToks,
getToks,replaceToks,deleteToks, doRmWhites,doAddWhites,
srcLocs, getStartEndLoc, getStartEndLoc2,
startEndLoc,extendBothSides,extendForwards,extendBackwards,
startEndLocIncFowComment,startEndLocIncFowNewLn,startEndLocIncComments,
prettyprint ,deleteFromToks, prettyprintGuardsAlt,
addFormalParams, adjustOffset, -- try to remove it
StartEndLoc, isArrow,-- swapInToks,
commentToks,tokenise, prettyprintPatList,groupTokensByLine, addLocInfo, getOffset, splitToks, insertComments,
extractComments, insertTerms
) where
import RefacTypeSyn(SimpPos)
import PosSyntax
import UniqueNames
import HsLexerPass1 hiding (notWhite)
import HsTokens
import PrettySymbols(rarrow)
import HsLayoutPre (PosToken)
import PrettyPrint
import HsExpUtil
import PNT
import RefacTypeSyn
import Maybe
import List
import SourceNames
-------------------------
--import DriftStructUtils
import StrategyLib
------------------------
import Control.Monad.State
--In the token stream, locations are unique except the default locs.
{- Some related data types defined by Programatica's Lexer:
type Lexer = String -> LexerOutPut
type LexerOutput = [PosToken]
type PosToken = (Token,(Pos,String))
data Pos = Pos { char, line, column :: !Int } deriving (Show)
-- it seems that the field char is used to handle special characters including the '\t'
data Token
= Varid | Conid | Varsym | Consym
| Reservedid | Reservedop | Specialid
| IntLit | FloatLit | CharLit | StringLit
| Qvarid | Qconid | Qvarsym | Qconsym
| Special | Whitespace
| NestedCommentStart -- will cause a call to an external function
| NestedComment -- from the external function
| Commentstart -- dashes
| Comment -- what follows the dashes
| ErrorToken | GotEOF | TheRest
| ModuleName | ModuleAlias -- recognized in a later pass
-- Inserted during layout processing (see Haskell 98, 9.3):
| Layout -- for implicit braces
| Indent Int -- <n>, to preceed first token on each line
| Open Int -- {n}, after let, where, do or of, if not followed by a "{"
deriving (Show,Eq,Ord)
-}
--A flag used to indicate whether the token stream has been modified or not.
unmodified = False
modified = True
--- some default values----
pos0=Pos 0 0 0
simpPos0 = (0,0)
extractComments :: (SimpPos, SimpPos) -> [PosToken] -> [PosToken]
extractComments ((startPosl, startPosr), endPos) toks
= let (toks1, toks21, toks22) = splitToks ((startPosl, startPosr), endPos) toks
in toks1
------------------------------------------------
ghead info [] = error $ "ghead "++info++" []"
ghead ingp (h:_) = h
glast info [] = error $ "glast " ++ info ++ " []"
glast info h = last h
gtail info [] = error $ "gtail " ++ info ++ " []"
gtail info h = tail h
gfromJust info (Just h) = h
gfromJust info Nothing = error $ "gfromJust " ++ info ++ " Nothing"
--Some functions for fetching a specific field of a token
tokenCol (_,(Pos _ _ c,_)) = c
tokenRow (_,(Pos _ r _,_)) = r
tokenPos (_,(p,_)) = simpPos p
tokenCon (_,(_,s)) = s
tokenLen (_,(_,s)) = length s --check this again! need to handle the tab key.
lengthOfToks::[PosToken]->Int
lengthOfToks=length.(concatMap tokenCon)
--Some functions for checking whether a token is of a specific type of token.
isWhite (t,_) = t==Whitespace || t==Commentstart || t==Comment || t==NestedComment
notWhite = not.isWhite
isWhiteSpace (t,(_,s)) = t==Whitespace && s==" "
isNewLn (t,(_,s)) = t==Whitespace && s=="\n"
isCommentStart (t,(_,s)) = t==Commentstart && s=="--"
isComment (t,(_,s)) = t==Comment || t ==NestedComment
isNestedComment (t,(_,s)) = t==NestedComment
isMultiLineComment (t,(_,s)) = t==NestedComment && (isJust (find (=='\n') s))
isOpenBracket (t,(_,s)) = t==Special && s=="("
isCloseBracket (t,(_,s)) = t==Special && s==")"
isOpenSquareBracket (t,(_,s)) = t==Special && s=="["
isCloseSquareBracket (t,(_,s)) = t==Special && s=="]"
isOpenBrace (t,(_,s)) = t==Special && s=="{"
isCloseBrace (t,(_,s)) = t==Special && s=="}"
isConid (t,(_,_)) = t==Conid
isLit (t,(_,s)) = t==IntLit || t==FloatLit || t==CharLit || t==StringLit
isWhereOrLet t = isWhere t || isLet t
isWhere (t,(_,s)) = t==Reservedid && s=="where"
isLet (t,(_,s)) = t==Reservedid && s=="let"
isImport (t, (_,s))= t == Reservedid && s=="import"
isType (t, (_,s))= t == Reservedid && s=="type"
isData (t, (_,s))= t == Reservedid && s=="data"
isFixty (t, (_,s)) = t==Reservedid && (s=="infix" || s=="infixl" || s=="infixr")
isDefault (t, (_,s)) = t == Reservedid && s=="default"
isClass (t, (_,s)) = t == Reservedid && s=="class"
isInstance (t, (_,s)) = t == Reservedid && s=="instance"
isNewtype (t, (_,s)) = t == Reservedid && s=="newtype"
isIn (t,(_,s)) = t==Reservedid && s=="in"
isCase (t,(_,s)) = t==Reservedid && s=="case"
isDo (t,(_,s)) = t==Reservedid && s=="do"
isIf (t,(_,s)) = t==Reservedid && s=="if"
isForall (t,(_,s)) = t==Reservedid && s=="forall"
isHiding (t,(_,s)) = s=="hiding"
isModule (t,(_,s)) = t==Reservedid && s=="module"
isComma (t,(_,s)) = t==Special && s==","
isEqual (t,(_,s)) = t==Reservedop && s=="="
isLambda (t,(_,s)) = t==Reservedop && s=="\\"
isIrrefute (t,(_,s)) = t==Reservedop && s=="~"
isBar (t,(_,s)) = t==Reservedop && s=="|"
isArrow (t,(_,s)) = t==Reservedop && s=="->"
isMinus (t,(_,s)) = t==Varsym && s=="-"
-----------------------------------------------------------------
--Returns True if the token ends with '\n'
endsWithNewLn::PosToken->Bool
endsWithNewLn (_,(_,s)) =if s==[] then False
else (glast "endsWithNewLn" s=='\n')
--Returns True if the token starts with `\n`.
startsWithNewLn::PosToken->Bool
startsWithNewLn (_,(_,s)) =if s==[] then False
else ((ghead "starsWithNewLn" s)=='\n')
--Returns True if there is a '\n' in the token.
hasNewLn::PosToken->Bool
hasNewLn (_,(_,s))=isJust (find (=='\n') s) {-different from isNewLn -}
--Returns True if a token stream starts with a newline token (apart from the white spaces tokens)
startsWithEmptyLn::[PosToken]->Bool
startsWithEmptyLn toks=isJust (find isNewLn $ takeWhile (\t->isWhiteSpace t || isNewLn t) toks)
-- get the last non-space token in a token stream.
lastNonSpaceToken::[PosToken]->PosToken
lastNonSpaceToken toks=case dropWhile isWhiteSpace (reverse toks) of
[] ->defaultToken
l -> ghead "lastNonSpaceToken" l
--get the first non-space token in a token stream.
firstNonSpaceToken::[PosToken]->PosToken
firstNonSpaceToken toks=case dropWhile isWhiteSpace toks of
[] ->defaultToken
l -> ghead "firstNonSpaceToken" l
-- remove the extra preceding empty lines.
compressPreNewLns::[PosToken]->[PosToken]
compressPreNewLns toks= let (toks1, toks2) = break (not.(\t->isNewLn t || isWhiteSpace t)) toks
groupedToks = groupTokensByLine toks1
in if length groupedToks>1 then (last groupedToks)++toks2
else toks
--remove the following extra empty lines.
compressEndNewLns::[PosToken]->[PosToken]
compressEndNewLns toks=let (toks1, toks2) = break (not.(\t->isNewLn t || isWhiteSpace t)) (reverse toks)
groupedToks = groupTokensByLine toks1
in if length groupedToks>1 then reverse ((ghead "compressEndNewLns" groupedToks)++toks2)
else toks
prettyprintPatList beginWithSpace t
= replaceTabBySpaces $ if beginWithSpace then format1 t else format2 t
where
format1 t = foldl (\x y -> x++ " "++(render.ppi) y) "" t
format2 [] = ""
format2 [p] = (render.ppi) p
format2 (p:ps) = (render.ppi) p ++" " ++ format2 ps
prettyprint = replaceTabBySpaces.render.ppi
prettyprintGuardsAlt = replaceTabBySpaces.render.(ppRhs rarrow)
--Replace Tab by white spaces. (1 Tab=8 white spaces)
replaceTabBySpaces::String->String
replaceTabBySpaces []=[]
replaceTabBySpaces (s:ss)
=if s=='\t' then replicate 8 ' ' ++replaceTabBySpaces ss
else s:replaceTabBySpaces ss
--Compose a new token using the given arguments.
mkToken::Token->SimpPos->String->PosToken
mkToken t (row,col) c=(t,(Pos 0 row col,c))
---Restriction: the refactorer should not modify refactorer-modified/created tokens.
defaultToken = (Whitespace, (pos0," "))
newLnToken = (Whitespace, (pos0,"\n"))
tokenise startPos _ _ [] = []
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'
in expandNewLnTokens $ lexerPass0' startPos str''
where
addIndent ln = if withFirstLineIndent
then replicate colOffset ' '++ ln
else ln
--preprocssing the token stream to expand the white spaces to individual tokens.
expandNewLnTokens::[PosToken]->[PosToken]
expandNewLnTokens ts = concatMap expand ts
where
expand tok@(Whitespace,(pos,s)) = doExpanding pos s
expand x = [x]
doExpanding pos [] =[]
doExpanding pos@(Pos c row col) (t:ts)
= case t of
'\n' -> (Whitespace, (pos,[t])):(doExpanding (Pos c (row+1) 1) ts)
_ -> (Whitespace, (pos,[t])):(doExpanding (Pos c row (col+1)) ts)
--Should add cases for literals.
addLocInfo (decl, toks)
= runStateT (applyTP (full_tdTP (idTP `adhocTP` inPnt
`adhocTP` inSN)) decl) toks
where
inPnt (PNT pname ty (N (Just loc)))
= do loc' <- findLoc (pNtoName pname)
return (PNT pname ty (N (Just loc')))
inPnt x = return x
inSN (SN (PlainModule modName) (SrcLoc _ _ row col))
= do loc' <- findLoc modName
return (SN (PlainModule modName) loc')
inSN x = return x
pNtoName (PN (UnQual i) _)=i
pNtoName (PN (Qual (PlainModule modName) i) _) = modName++"."++i
pNtoName (PN (Qual (MainModule _) i) _) = "Main."++i
findLoc name
= do let name' = if name =="Prelude.[]" || name == "[]" then "["
else if name=="Prelude.(,)" || name == "(,)" || name == "()" then "("
else name ----Check this again.
toks' = dropWhile (\t->tokenCon t /= name') toks
(row, col) =if toks'==[] then error "HaRe: Error in addLocInfo!"
else tokenPos $ ghead "findLoc" toks'
return (SrcLoc "unknown" 0 row col)
groupTokensByLine [] = []
groupTokensByLine xs =let (xs', xs'') = break hasNewLn xs
in if xs''==[] then [xs']
else (xs'++ [ghead "groupTokensByLine" xs''])
: groupTokensByLine (gtail "groupTokensByLine" xs'')
--Give a token stream covering multi-lines, calculate the length of the last line
lengthOfLastLine::[PosToken]->Int
lengthOfLastLine toks
= let (toks1,toks2)=break hasNewLn $ reverse toks
in if toks2==[]
then sum (map tokenLen toks1)
else sum (map tokenLen toks1)+lastLineLenOfToken (ghead "lengthOfLastLine" toks2)
where
--Compute the length of a token, if the token covers multi-line, only count the last line.
--What about tab keys?
lastLineLenOfToken (_,(_,s))=(length.(takeWhile (\x->x/='\n')).reverse) s
--get a token stream specified by the start and end position.
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++ [ghead "getToks" toks22]) -- Should add error message for empty list?
-- Split the token stream into three parts: the tokens before the startPos,
-- the tokens between startPos and endPos, and the tokens after endPos.
splitToks::(SimpPos, SimpPos)->[PosToken]->([PosToken],[PosToken],[PosToken])
splitToks (startPos, endPos) toks
= if (startPos, endPos) == (simpPos0, simpPos0)
then error "Invalid token stream position!"
else let startPos'= if startPos==simpPos0 then endPos else startPos
endPos' = if endPos == simpPos0 then startPos else endPos
(toks1, toks2) = break (\t -> tokenPos t == startPos') toks
(toks21, toks22) = break (\t -> tokenPos t== endPos') toks2
-- Should add error message for empty list?
in if toks22==[] then error "Sorry, HaRe failed to finish this refactoring." -- (">" ++ (show (startPos, endPos) ++ show toks))
else (toks1, toks21++[ghead "splitToks" toks22], gtail "splitToks" toks22)
getOffset toks pos
= let (ts1, ts2) = break (\t->tokenPos t == pos) toks
in if ts2==[]
then error "HaRe error: position does not exist in the token stream!"
else lengthOfLastLine ts1
--comment a token stream specified by the start and end position.
commentToks::(SimpPos,SimpPos)->[PosToken]->[PosToken]
commentToks (startPos,endPos) toks
= let (toks1, toks21, toks22) = splitToks (startPos, endPos) toks
toks21' = case toks21 of
[] -> toks21
(t,(l,s)):[] -> (t, (l, ("{-" ++ s ++ "-}"))):[]
(t1,(l1,s1)):ts -> let lastTok@(t2, (l2, s2)) = glast "commentToks" ts
lastTok' = (t2, (l2, (s2++" -}")))
in (t1,(l1, ("{- "++s1))): (reverse (lastTok': gtail "commentToks" (reverse ts)))
in (toks1 ++ toks21' ++ toks22)
insertTerms :: (SimpPos, SimpPos) -> [PosToken] -> String -> [PosToken]
insertTerms ((startPosl, startPosr), endPos) toks com
= let (toks1, toks21, toks22) = splitToks ((startPosl, startPosr), endPos) toks
toks21' = (Commentstart, ((Pos 0 startPosl startPosr) , "")) : [(Comment, ((Pos 0 startPosl startPosr), ("\n" ++ com ++ "\n")))]
in (toks1 ++ toks21' ++ (toks21 ++ toks22))
insertComments :: (SimpPos, SimpPos) -> [PosToken] -> String -> [PosToken]
insertComments ((startPosl, startPosr), endPos) toks com
= let (toks1, toks21, toks22) = splitToks ((startPosl, startPosr), endPos) toks
toks21' = (Commentstart, ((Pos 0 startPosl startPosr) , "")) : [(Comment, ((Pos 0 startPosl startPosr), ("\n{- " ++ com ++ " -}\n")))]
in (toks1 ++ toks21' ++ (toks21 ++ toks22))
--- -} -}
updateToks oldAST newAST printFun
= do ((toks,_), (v1, v2)) <-get
let (startPos, endPos) = getStartEndLoc toks oldAST
(toks1, _, _) = splitToks (startPos, endPos) toks
offset = lengthOfLastLine toks1
newToks = tokenise (Pos 0 v1 1) offset False $ printFun newAST --check the startPos
toks' = replaceToks toks startPos endPos newToks
if newToks ==[] then put ((toks', modified), (v1,v2))
else put ((toks',modified), (tokenRow (glast "updateToks1" newToks) -10, v2))
-- error $ show (newToks, startPos, endPos)
-- put ((toks', modified), (v1,v2))
addLocInfo (newAST, newToks)
---REFACTORING: GENERALISE THIS FUNCTION.
addFormalParams t newParams
= do ((toks,_),(v1, v2))<-get
let (startPos,endPos) = getStartEndLoc toks t
tToks = getToks (startPos, endPos) toks
(toks1, _) = let (toks1', toks2') = break (\t-> tokenPos t == endPos) toks
in (toks1' ++ [ghead "addFormalParams" toks2'], gtail "addFormalParams" toks2')
offset = lengthOfLastLine toks1
newToks = tokenise (Pos 0 v1 1) offset False (prettyprintPatList True newParams )
toks' = replaceToks toks startPos endPos (tToks++newToks)
put ((toks',modified), ((tokenRow (glast "addFormalParams" newToks) -10), v2))
addLocInfo (newParams, newToks)
--Replace a list of tokens in the token stream by a new list of tokens, adjust the layout as well.
--To use this function make sure the start and end positions really exist in the token stream.
--QN: what happens if the start or end position does not exist?
replaceToks::[PosToken]->SimpPos->SimpPos->[PosToken]->[PosToken]
replaceToks toks startPos endPos newToks
= if toks22 == []
then toks1 ++ newToks
else let pos = tokenPos (ghead "replaceToks" toks22)
oldOffset = getOffset toks pos
newOffset = getOffset (toks1++newToks++ toks22) pos
in toks1++ newToks++ adjustLayout toks22 oldOffset newOffset
where
(toks1, toks21, toks22) = splitToks (startPos, endPos) toks
{- Delete an syntax phrase from the token stream, this function (instead of the following one)
should be the interface function for deleting tokens.
-}
-- deleteFromToks::( (MonadState (([PosToken], Bool), t1) m), StartEndLoc t,Printable t,Term t)=>t->m ()
deleteFromToks t getLocFun
=do ((toks,_),others)<-get
let (startPos,endPos)=getLocFun toks t
toks'=deleteToks toks startPos endPos
put ((toks',modified),others)
{-Delete a sequence of tokens specified by the start position and end position from the token stream,
then adjust the remaining token stream to preserve layout-}
deleteToks::[PosToken]->SimpPos->SimpPos->[PosToken]
deleteToks toks startPos@(startRow, startCol) endPos@(endRow, endCol)
= case after of
(_:_) -> let nextPos =tokenPos $ ghead "deleteToks1" after
oldOffset = getOffset toks nextPos
newOffset = getOffset (toks1++before++after) nextPos
in toks1++before++adjustLayout (after++toks22) oldOffset newOffset
_ -> if toks22 == []
then toks1++before
else let toks22'=let nextOffset = getOffset toks (tokenPos (ghead "deleteToks2" toks22))
in if isMultiLineComment (lastNonSpaceToken toks21)
then whiteSpaceTokens (-1111, 0) (nextOffset-1) ++ toks22
else toks22
in if endsWithNewLn (last (toks1++before)) || startsWithNewLn (ghead "deleteToks3" toks22')
then toks1++before++toks22'
--avoiding layout adjustment by adding a `\n', sometimes may produce extra lines.
else toks1++before++[newLnToken]++toks22'
-- else toks1 ++ 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 ts12==[] then [] else [ghead "deleteToks4" ts12], if ts12==[] then [] else gtail "deleteToks5" ts12)
-- tokens before the tokens to be deleted at the same line
before = takeWhile (\t->tokenPos t/=startPos) toks21
-- tokens after the tokens to be deleted at the same line.
after = let t= dropWhile (\t->tokenPos t /=endPos) toks21
in if t == [] then error "Sorry, HaRe failed to finish this refactoring."
else gtail "deleteToks6" t
-- Adjust the layout to compensate the change in the token stream.
adjustLayout::[PosToken]->Int->Int->[PosToken]
adjustLayout [] _ _ = []
adjustLayout toks oldOffset newOffset
| oldOffset == newOffset = toks
adjustLayout toks oldOffset newOffset
= case layoutRuleApplies of
True -> let (ts:ts') = groupTokensByLine toks
in ts ++ addRmSpaces (newOffset-oldOffset) oldOffset ts' -- THIS IS PROBLEMETIC.
_ -> toks
where
layoutRuleApplies
= let ts = dropWhile (\t-> (not.elem (tokenCon t)) keyWords)
$ filter notWhite
$ takeWhile (not.hasNewLn) toks
in case ts of
(_: t: _) -> tokenCon t /= "{"
_ -> False
keyWords = ["where","let","do","of"]
addRmSpaces n col [] = []
addRmSpaces n col toks@(ts:ts')
=case find notWhite ts of
Just t -> if length (concatMap tokenCon ts1) >= col
then (addRmSpaces' n ts) ++ addRmSpaces n col ts'
else concat toks
_ -> ts ++ addRmSpaces n col ts'
where
(ts1, ts2) = break notWhite ts
addRmSpaces' 0 ts = ts
addRmSpaces' _ [] = []
addRmSpaces' n ts@(t:ts')
= case n >0 of
True -> whiteSpaceTokens (tokenRow t,0) n ++ ts -- CHECK THIS.
_ -> if isWhiteSpace t
then addRmSpaces' (n+1) ts'
else error $ "Layout adjusting failed at line:"
++ show (tokenRow t)++ "."
-- remove at most n white space tokens from the beginning of ts
doRmWhites::Int->[PosToken]->[PosToken]
doRmWhites 0 ts=ts
doRmWhites n []=[]
doRmWhites n toks@(t:ts)=if isWhiteSpace t then doRmWhites (n-1) ts
else toks
--add n white space tokens to the beginning of ts
doAddWhites::Int->[PosToken]->[PosToken]
doAddWhites n []=[]
doAddWhites n ts@(t:_)= whiteSpacesToken (tokenRow t,0) n ++ts
whiteSpaceTokens (row, col) n
= if n<=0
then []
else (mkToken Whitespace (row,col) " "):whiteSpaceTokens (row,col+1) (n-1)
-------------------------------------------------------------------------------------------------
--get all the source locations (use locations) in an AST phrase t in according the the occurrence order of identifiers.
srcLocs::(Term t)=> t->[SimpPos]
srcLocs t =(nub.srcLocs') t \\ [simpPos0]
where srcLocs'=runIdentity.(applyTU (full_tdTU (constTU []
`adhocTU` pnt
`adhocTU` sn
`adhocTU` literalInExp
`adhocTU` literalInPat)))
pnt (PNT pname _ (N (Just (SrcLoc _ _ row col))))=return [(row,col)]
pnt _=return []
sn (SN (PlainModule modName) (SrcLoc _ _ row col))
= return [(row, col)]
sn _ = return []
literalInExp ((Exp (HsLit (SrcLoc _ _ row col) _))::HsExpP) = return [(row,col)]
literalInExp (Exp _) =return []
literalInPat ((Pat (HsPLit (SrcLoc _ _ row col) _))::HsPatP) = return [(row,col)]
literalInPat (Pat (HsPNeg (SrcLoc _ _ row col) _)) = return [(row,col)]
literalInPat _ =return []
class StartEndLocPat t where
startEndLoc2 :: [PosToken]->t->[(SimpPos,SimpPos)]
-- startEndLoc3 :: [PosToken]->t->[(SimpPos,SimpPos)]
instance StartEndLocPat [HsDeclP] where
startEndLoc2 toks ds=if ds==[] then [(simpPos0,simpPos0)]
else if length ds==1
then [startEndLoc toks (ghead "StartEndLoc:[HsDeclP]" ds)]
else concat (map (startEndLoc2 toks) ds)
instance StartEndLocPat HsMatchP where
startEndLoc2 toks (HsMatch loc i ps rhs ds)
=let (startLoc,_)=startEndLoc toks i
(_,endLoc) =if ds==[] then startEndLoc toks rhs
else startEndLoc toks (glast "StartEndLoc:HsMatchP" ds)
in [(startLoc,endLoc)]
instance StartEndLocPat HsDeclP where
startEndLoc2 toks (Dec (HsTypeDecl (SrcLoc _ _ r c) tp t))
= let (startLoc, _) = startEndLoc toks tp
(_ , endLoc) = startEndLoc toks t
in [extendForwards toks startLoc endLoc isType]
startEndLoc2 toks (Dec (HsDataDecl loc c tp decls is))
= let (startLoc, _) = startEndLoc toks tp
(_, endLoc) = if is == [] then startEndLoc toks (glast "StartEndLoc:HsDeclP1" decls)
else startEndLoc toks is
in [extendForwards toks startLoc endLoc isData]
startEndLoc2 toks (Dec (HsNewTypeDecl loc c tp decls is))
= let (startLoc, _) = startEndLoc toks tp
(_, endLoc) = if is == [] then startEndLoc toks decls
else startEndLoc toks is
in [extendForwards toks startLoc endLoc isNewtype]
startEndLoc2 toks (Dec (HsDefaultDecl _ ts))
= let (startLoc, _) = startEndLoc toks (head ts)
(_ , endLoc) = startEndLoc toks (last ts)
in [extendForwards toks startLoc endLoc isDefault]
startEndLoc2 toks (Dec (HsInfixDecl _ _ is))
= let (startLoc, _) = startEndLoc toks (head is)
(_, endLoc) = startEndLoc toks (last is)
in [extendForwards toks startLoc endLoc isFixty]
startEndLoc2 toks d@(Dec (HsFunBind _ ms))
= map (startEndLoc toks) ms
startEndLoc2 toks (Dec (HsPatBind _ p rhs ds))
= let (startLoc, _) = startEndLoc toks p
(_, endLoc) = if ds ==[] then startEndLoc toks rhs
else startEndLoc toks (glast "startEndLoc:HsDeclP5" ds)
toks1 = dropWhile (\t->tokenPos t /= endLoc) toks
endLoc1 = if toks1==[]
then endLoc
else let toks2 = takeWhile (\t -> isSpecialTok t) toks1
in (tokenPos.glast "startEndLoc::HsMatchP") toks2
in [(startLoc, endLoc1)]
where
isSpecialTok t = isWhiteSpace t || isCloseBracket t || isOpenBracket t || isOpenSquareBracket t
|| isCloseSquareBracket t
startEndLoc2 toks (Dec (HsTypeSig _ is c t))
= let (startLoc, _) = startEndLoc toks (ghead "startEndLoc:HsDeclP6" is)
(_, endLoc) = startEndLoc toks t
in [(startLoc, endLoc)]
startEndLoc2 toks decl@(Dec (HsClassDecl loc c tp funDeps ds))
= let locs = srcLocs decl
(startLoc, endLoc)
= if locs == [] then (simpPos0, simpPos0)
else (head locs, last locs)
in [extendForwards toks startLoc endLoc isClass]
startEndLoc2 toks decl@(Dec (HsInstDecl loc i c t ds))
= let locs = srcLocs decl
(startLoc, endLoc)
= if locs == [] then (simpPos0, simpPos0)
else (head locs, last locs)
in [extendForwards toks startLoc endLoc isInstance]
getStartEndLoc2::(Term t, StartEndLocPat t,Printable t)=>[PosToken]->t->[(SimpPos,SimpPos)]
getStartEndLoc2 toks t
= startEndLoc2 toks t
{- locs = srcLocs t
(startPos,endPos) = (if startPos' == simpPos0 && locs /=[] then ghead "getStartEndLoc2" locs
else startPos',
if endPos' == simpPos0 && locs /= [] then glast "gerStartEndLoc2" locs
else endPos')
in (startPos, endPos) -}
--given an AST phrase, 'startEndLoc' gets its start and end position in the program source.
class StartEndLoc t where
startEndLoc :: [PosToken]->t->(SimpPos,SimpPos)
instance StartEndLoc HsModuleP where
startEndLoc toks _ = (tokenPos (ghead "startEndLoc:HsModuleP" toks),
tokenPos (glast "startEndLoc:HsModuleP" toks))
instance StartEndLoc HsExpP where
startEndLoc toks (Exp e)=
case e of
HsId ident@(HsVar (PNT pn _ _)) ->let (startLoc, endLoc) = startEndLoc toks ident
{- To handle infix operator. for infix operators like (++), there
is no parenthesis in the syntax tree -}
(toks1,toks2) = break (\t->tokenPos t==startLoc) toks
toks1' = dropWhile isWhite (reverse toks1)
toks2' = dropWhile isWhite (gtail "startEndLoc:HsExpP"
(dropWhile (\t->tokenPos t /=endLoc) toks2))
in if toks1'/=[] && toks2'/=[] && isOpenBracket (head toks1')
&& isCloseBracket (head toks2')
then (tokenPos (head toks1'), tokenPos (head toks2'))
else (startLoc, endLoc)
HsId x ->startEndLoc toks x
HsLit (SrcLoc _ _ r c) _ -> ((r,c),(r,c))
HsInfixApp e1 op e2 ->let (startLoc,_)=startEndLoc toks e1
(_, endLoc) =startEndLoc toks e2
in (startLoc,endLoc)
e@(HsApp e1 e2) ->let (startLoc,endLoc)=startEndLoc toks e1
(startLoc1, endLoc1 )=startEndLoc toks e2
in (startLoc, endLoc1)
HsNegApp (SrcLoc _ _ r c) e ->let (_,endLoc)=startEndLoc toks e
in ((r,c), endLoc)
HsLambda ps e ->let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsLambda" ps) --ps can not be empty
(_,endLoc) =startEndLoc toks e
in extendForwards toks startLoc endLoc isLambda
HsIf e1 e2 e3 ->let (startLoc, _)=startEndLoc toks e1
(_, endLoc)=startEndLoc toks e3
in extendForwards toks startLoc endLoc isIf
HsLet ds e ->if ds==[]
then
let (startLoc,endLoc)=startEndLoc toks e
in extendForwards toks startLoc endLoc isLet
else
let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsLet" ds)
(_,endLoc) =startEndLoc toks e
in extendForwards toks startLoc endLoc isLet
HsCase e alts ->let (startLoc,_)=startEndLoc toks e
(_,endLoc) =startEndLoc toks (glast "HsCase" alts) --alts can not be empty.
in extendForwards toks startLoc endLoc isCase
HsDo stmts ->let (startLoc, endLoc)=startEndLoc toks stmts
in extendForwards toks startLoc endLoc isDo
HsTuple es ->if es==[]
then (simpPos0,simpPos0) --Empty tuple can cause problem.
else let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsTuple" es)
(_,endLoc) =startEndLoc toks (glast "startEndLoc:HsTuple" es)
in extendBothSides toks startLoc endLoc isOpenBracket isCloseBracket
HsList es ->if es==[]
then (simpPos0,simpPos0) --Empty list can cause problem.
else let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsList" es)
(_,endLoc) =startEndLoc toks (glast "startEndLoc:HsList" es)
in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket
HsParen e ->let (startLoc,(endLocR, endLocC))=startEndLoc toks e
in extendBothSides toks startLoc (endLocR, endLocC) isOpenBracket isCloseBracket
-- in if expIsPNT e
-- then (startLoc, (endLocR, endLocC+1))
-- else extendBothSides toks startLoc (endLocR, endLocC) isOpenBracket isCloseBracket
-- where
-- expIsPNT (Exp (HsId (HsVar pnt)))=True
-- expIsPNT (Exp (HsParen e))=expIsPNT e
-- expIsPNT _ =False
HsLeftSection e op ->let (startLoc,_)=startEndLoc toks e
(_, endLoc )=startEndLoc toks op
in (startLoc,endLoc)
HsRightSection op e ->let (startLoc,_)=startEndLoc toks op
(_, endLoc )=startEndLoc toks op
in (startLoc,endLoc)
HsRecConstr loc i upds ->let (startLoc,_)=startEndLoc toks i
(_,endLoc) =startEndLoc toks (glast "startEndLoc:HsRecConstr" upds) --can 'upds' be empty?
in extendBackwards toks startLoc endLoc isCloseBrace
HsRecUpdate loc e upds ->let (startLoc,_)=startEndLoc toks e
(_,endLoc) =startEndLoc toks (glast "startEndLoc:HsRecUpdate" upds) --ditto
in extendBackwards toks startLoc endLoc isCloseBrace
HsEnumFrom e ->let (startLoc,endLoc)=startEndLoc toks e
in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket
HsEnumFromTo e1 e2 ->let (startLoc,_)=startEndLoc toks e1
(_, endLoc)=startEndLoc toks e2
in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket
HsEnumFromThen e1 e2 ->let (startLoc,_)=startEndLoc toks e1
(_, endLoc)=startEndLoc toks e2
in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket
HsEnumFromThenTo e1 e2 e3 ->let (startLoc,_)=startEndLoc toks e1
(_, endLoc)=startEndLoc toks e3
in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket
HsListComp stmts ->let (startLoc,endLoc)=startEndLoc toks stmts
in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket
HsAsPat i e ->let (startLoc,_)=startEndLoc toks i
(_,endLoc)= startEndLoc toks e
in (startLoc,endLoc)
HsIrrPat e ->let (startLoc,endLoc)=startEndLoc toks e
in extendForwards toks startLoc endLoc isIrrefute
HsWildCard ->(simpPos0,simpPos0) -- wildcard can cause problem.
HsExpTypeSig loc e c t ->let (startLoc,_)=startEndLoc toks e
(_, endLoc )=startEndLoc toks t
in (startLoc,endLoc)
instance StartEndLoc HsTypeP where
startEndLoc toks (Typ p)=
case p of
HsTyFun t1 t2 -> let (startLoc,e)=startEndLoc toks t1
(_ , endLoc)=startEndLoc toks t2
in (startLoc,endLoc)
--HsTyTuple [t] ->
HsTyApp t1 t2 -> let (startLoc,endLoc)=startEndLoc toks t1
(startLoc1 , endLoc1)=startEndLoc toks t2
in case t1 of
(Typ (HsTyCon t)) -> if (render.ppi) t == "[]"
then extendBothSides toks startLoc1 endLoc1 isOpenSquareBracket isCloseSquareBracket
else (startLoc, endLoc1)
_ -> (startLoc, endLoc1)
HsTyVar i -> let (startLoc, endLoc) = startEndLoc toks i
in extendBothSides' toks startLoc endLoc isOpenBracket isCloseBracket
HsTyCon i -> let (startLoc, endLoc) = startEndLoc toks i
in if (render.ppi) i =="[]"
then extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket
else extendBothSides' toks startLoc endLoc isOpenBracket isCloseBracket
HsTyForall is ts t -> case is of
[] ->let (startLoc,endLoc)=startEndLoc toks t
in extendForwards toks startLoc endLoc isForall
l -> let (startLoc, _) =startEndLoc toks $ ghead "StartEndLoc:HsTypeP" is
( _ , endLoc) =startEndLoc toks t
in extendForwards toks startLoc endLoc isForall
extendBothSides' toks startLoc endLoc forwardCondFun backwardCondFun
=let (toks1,toks2)=break (\t->tokenPos t==startLoc) toks
toks21=dropWhile (\t->tokenPos t<=endLoc) toks2
firstLoc=case (dropWhile isWhite (reverse toks1)) of
[] -> startLoc -- is this the correct default?
ls -> if (forwardCondFun.ghead "extendBothSides:lastTok") ls then tokenPos (head ls)
else startLoc
lastLoc =case (dropWhile isWhite toks21) of
[] ->endLoc --is this a correct default?
ls -> if (backwardCondFun.ghead "extendBothSides:lastTok") ls then tokenPos (head ls)
else endLoc
in (firstLoc, lastLoc)
instance StartEndLoc HsPatP where
startEndLoc toks (Pat p)=
case p of
HsPId i ->startEndLoc toks i
HsPLit (SrcLoc _ _ r c) _ ->((r,c),(r,c))
HsPNeg (SrcLoc _ _ r c) p ->((r,c),(r,c))
HsPInfixApp p1 op p2 ->let (startLoc,_)=startEndLoc toks p1
(_ , endLoc)=startEndLoc toks p2
in (startLoc,endLoc)
HsPApp i ps ->let (startLoc,_)=startEndLoc toks i
(_,endLoc)=startEndLoc toks (glast "StartEndLoc:HsPatP" ps)
in (startLoc,endLoc)
HsPTuple loc ps -> if ps==[]
then (simpPos0,simpPos0) -- ****Update this using locations****.
else let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsPTuple" ps)
(_,endLoc)=startEndLoc toks (glast "startEndLoc:HsPTuple" ps)
in extendBothSides toks startLoc endLoc isOpenBracket isCloseBracket
HsPList loc ps ->if ps==[]
then (simpPos0,simpPos0) -- ***Update this using locations*****
else let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsPList" ps)
(_, endLoc) =startEndLoc toks (glast "startEndLoc:HsPList" ps)
in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket
HsPParen p ->let (startLoc,endLoc)=startEndLoc toks p
in extendBothSides toks startLoc endLoc isOpenBracket isCloseBracket
HsPRec i upds ->let (startLoc,_)=startEndLoc toks i
(_,endLoc)=startEndLoc toks (glast "startEndLoc:HsPRec" upds) --can upds be empty?
in extendBackwards toks startLoc endLoc isCloseBrace
HsPAsPat i p ->let (startLoc,_)=startEndLoc toks i
(_,endLoc)=startEndLoc toks p
in (startLoc,endLoc)
HsPIrrPat p ->let (startLoc,endLoc)=startEndLoc toks p
in extendForwards toks startLoc endLoc isIrrefute
HsPWildCard ->(simpPos0,simpPos0) -- wildcard can cause problem.
instance StartEndLoc [HsPatP] where
startEndLoc toks ps = let locs=(nub.(map (startEndLoc toks))) ps \\ [(simpPos0,simpPos0)]
in if locs==[] then (simpPos0,simpPos0)
else let (startLoc,_)=ghead "StartEndLoc:HsPatP" locs
(_,endLoc) =glast "StartEndLoc:HsPatP" locs
in (startLoc,endLoc)
instance StartEndLoc [HsExpP] where
startEndLoc toks es=let locs=(nub.(map (startEndLoc toks))) es \\ [(simpPos0,simpPos0)]
in if locs==[] then (simpPos0,simpPos0)
else let (startLoc,_)=ghead "StartEndLoc:HsExp" locs
(_,endLoc) =glast "startEndLoc:HsExp" locs
in (startLoc,endLoc)
instance StartEndLoc [HsDeclP] where
startEndLoc toks ds=if ds==[] then (simpPos0,simpPos0)
else if length ds==1
then startEndLoc toks (ghead "StartEndLoc:[HsDeclP]" ds)
else let (startLoc,_)=startEndLoc toks (ghead "StartEndLoc:[HsDeclP]" ds)
(_,endLoc) =startEndLoc toks (glast "StartEndLoc:[HsDeclP]" ds)
in (startLoc,endLoc)
instance StartEndLoc HsMatchP where
startEndLoc toks t@(HsMatch loc i ps rhs ds)
=let (startLoc,_)=startEndLoc toks i
(_,endLoc) =if ds==[] then startEndLoc toks rhs
else startEndLoc toks (glast "StartEndLoc:HsMatchP" ds)
locs = srcLocs t
(startLoc1,endLoc1) = (if startLoc == simpPos0 && locs /=[] then ghead "getStartEndLoc" locs
else startLoc,
if endLoc == simpPos0 && locs /= [] then glast "getStartEndLoc" locs
else endLoc)
toks1 = gtail "startEndLoc:HsMatchP" (dropWhile (\t->tokenPos t /= endLoc1) toks)
toks0 = getToks (startLoc1, endLoc1) toks
endLoc2 = if toks1==[]
then endLoc1
else let toks2 = takeWhile (\t -> isSpecialTok t && needmore toks t ) toks1
in if toks2 == [] || all (\t-> isWhiteSpace t ) toks2
then endLoc1
else (tokenPos.glast "startEndLoc::HsMatchP") toks2
in (startLoc1, endLoc2)
where
isSpecialTok t = isWhiteSpace t || isCloseBracket t || isOpenBracket t || isOpenSquareBracket t
|| isCloseSquareBracket t
needmore toks t = case isCloseBracket t of
True -> let openBrackets = length $ filter isOpenBracket toks
closeBrackets = length $ filter isCloseBracket toks
in closeBrackets < openBrackets
False -> case isCloseSquareBracket t of
True -> let openSqBrackets = length $ filter isOpenSquareBracket toks
closeSqBrackets = length $ filter isCloseSquareBracket toks
in closeSqBrackets < openSqBrackets
false -> True
instance StartEndLoc HsStmtP where -- Bug fixed. 20/05/2004
startEndLoc toks stmts=let s=getStmtList stmts
locs = map (startEndLoc toks) s
(startLocs, endLocs) =(sort (map fst locs), sort (map snd locs))
in (ghead "StartEndLoc::HsStmtP" startLocs, glast "StartEndLoc::HsStmtP" endLocs)
instance StartEndLoc (HsStmtAtom HsExpP HsPatP [HsDeclP]) where
startEndLoc toks stmt=
case stmt of
HsGeneratorAtom (SrcLoc _ _ r c) p e ->
let (startLoc,_)=startEndLoc toks p
(_,endLoc) =startEndLoc toks e
in (startLoc,endLoc)
HsQualifierAtom e -> startEndLoc toks e
HsLetStmtAtom ds -> if ds==[]
then (simpPos0,simpPos0)
else let (startLoc,_)= startEndLoc toks (ghead "StartEndLoc:HsStmtAtom" ds)
(_,endLoc) = startEndLoc toks (glast "StartEndLoc:HsStmtAtom" ds)
in (startLoc,endLoc)
HsLastAtom e ->startEndLoc toks e
instance (StartEndLoc i,StartEndLoc e)=>StartEndLoc (HsFieldI i e) where
startEndLoc toks (HsField i e)=let (startLoc,_)=startEndLoc toks i
(_,endLoc)=startEndLoc toks e
in (startLoc,endLoc)
instance StartEndLoc HsAltP where
startEndLoc toks (HsAlt l p rhs ds)=let (startLoc,_)=startEndLoc toks p
(_,endLoc)=if ds==[] then startEndLoc toks rhs
else startEndLoc toks (glast "StartEndLoc:HsAltP" ds)
in (startLoc,endLoc)
instance StartEndLoc RhsP where
startEndLoc toks (HsBody e)=startEndLoc toks e
startEndLoc toks (HsGuard es)=if es==[] then (simpPos0,simpPos0)
else let (_,e1,_)=ghead "StartEndLoc:RhsP" es
(_,_,e2)=glast "StartEndLoc:RhsP" es
(startLoc,_)=startEndLoc toks e1
(_,endLoc)=startEndLoc toks e2
in extendForwards toks startLoc endLoc isBar
instance StartEndLoc (HsIdentI PNT) where
startEndLoc toks ident =
case ident of
HsVar i ->startEndLoc toks i
HsCon i ->startEndLoc toks i
instance StartEndLoc [PNT] where
startEndLoc toks pnts
= if pnts==[] then (simpPos0, simpPos0)
else let (startPos, _) = startEndLoc toks (head pnts)
(_, endPos) = startEndLoc toks (last pnts)
in (startPos, endPos)
instance StartEndLoc (HsImportDeclI ModuleName PNT) where
startEndLoc toks (HsImportDecl (SrcLoc _ _ row col) modName qual as Nothing)
= let startPos=fst (startEndLoc toks modName)
endPos = if isJust as then snd (startEndLoc toks (fromJust as))
else snd (startEndLoc toks modName)
in extendForwards toks startPos endPos isImport
startEndLoc toks (HsImportDecl (SrcLoc _ _ row col) modName qual as (Just (_, ents)))
= let startPos = fst (startEndLoc toks modName)
endPos = if ents == [] then if isJust as then snd (startEndLoc toks (fromJust as))
else snd (startEndLoc toks modName)
else snd (startEndLoc toks (glast "startEndLocImport" ents))
in extendBothSides toks startPos endPos isImport isCloseBracket
instance StartEndLoc [HsExportSpecI ModuleName PNT] where
startEndLoc toks es
= if es == [] then (simpPos0, simpPos0)
else let (startLoc, _) = startEndLoc toks $ head es
(_, endLoc) = startEndLoc toks $ last es
in (startLoc, endLoc)
-- in extendBothSides toks startLoc endLoc isOpenBracket isCloseBracket
instance StartEndLoc (HsExportSpecI ModuleName PNT) where
startEndLoc toks (EntE ent) =startEndLoc toks ent
startEndLoc toks (ModuleE moduleName) = let (startPos, endPos) = startEndLoc toks moduleName
in extendForwards toks startPos endPos isModule
instance StartEndLoc(EntSpec PNT) where
startEndLoc toks (Var i)=startEndLoc toks i --- x (a variable identifier)
startEndLoc toks (Abs i) =startEndLoc toks i -- T, C
startEndLoc toks (AllSubs i) =let (startPos, endPos) =startEndLoc toks i -- T(..), C(..)
in extendBackwards toks startPos endPos isCloseBracket
startEndLoc toks (ListSubs i ents)= let (startPos, _) = startEndLoc toks i --T (C_1, ...,C_n, f1,...f_n)
(_, endPos) = startEndLoc toks (glast "startEnPosListSubs" ents)
in extendBackwards toks startPos endPos isCloseBracket
instance StartEndLoc ModuleName where
startEndLoc toks (SN modName (SrcLoc _ _ row col)) = ((row,col), (row,col))
instance StartEndLoc [EntSpec PNT] where
startEndLoc toks ents
= if ents==[] then (simpPos0,simpPos0)
else let (startPos, _)=startEndLoc toks $ head ents
(_, endPos) =startEndLoc toks $ last ents
in (startPos,endPos)
-- in extendBothSides toks startPos endPos isHiding isCloseBracket
instance StartEndLoc PNT where
startEndLoc toks pnt =
case pnt of
PNT pn _ (N (Just (SrcLoc _ _ row col)))->((row,col),(row,col))
_ ->(simpPos0,simpPos0) {-Shouldn't cause any problems here, as in a normal
AST, every PNT has a source location. -}
instance (Eq i, Eq t, StartEndLoc i, StartEndLoc t,StartEndLoc [i]) =>StartEndLoc (HsConDeclI i t c) where
startEndLoc toks (HsConDecl _ is c i ds)
= let (startLoc, _) = startEndLoc toks is
(_, endLoc) = if ds==[] then startEndLoc toks i
else startEndLoc toks (last ds)
in (startLoc, endLoc)
startEndLoc toks (HsRecDecl _ is c i ds)
= let (startLoc, _) = startEndLoc toks is
(_, endLoc) = if ds==[] then startEndLoc toks i
else startEndLoc toks (last ds)
in (startLoc, endLoc)
instance (StartEndLoc t)=>StartEndLoc (HsBangType t) where
startEndLoc toks (HsBangedType t) = startEndLoc toks t
startEndLoc toks (HsUnBangedType t) = startEndLoc toks t
instance (StartEndLoc t, StartEndLoc [i]) => StartEndLoc ([i], HsBangType t) where
startEndLoc toks (x,y)
= let (startLoc, endLoc) = startEndLoc toks y
in extendBackwards toks startLoc endLoc isCloseBrace
instance StartEndLoc HsDeclP where
startEndLoc toks (Dec (HsTypeDecl (SrcLoc _ _ r c) tp t))
= let (startLoc, _) = startEndLoc toks tp
(_ , endLoc) = startEndLoc toks t
in extendForwards toks startLoc endLoc isType
startEndLoc toks (Dec (HsDataDecl loc c tp decls is))
= let (startLoc, _) = startEndLoc toks tp
(_, endLoc) = if is == [] then startEndLoc toks (glast "StartEndLoc:HsDeclP1" decls)
else startEndLoc toks is
in extendForwards toks startLoc endLoc isData
startEndLoc toks (Dec (HsNewTypeDecl loc c tp decls is))
= let (startLoc, _) = startEndLoc toks tp
(_, endLoc) = if is == [] then startEndLoc toks decls
else startEndLoc toks is
in extendForwards toks startLoc endLoc isNewtype
startEndLoc toks (Dec (HsDefaultDecl _ ts))
= let (startLoc, _) = startEndLoc toks (head ts)
(_ , endLoc) = startEndLoc toks (last ts)
in extendForwards toks startLoc endLoc isDefault
startEndLoc toks (Dec (HsInfixDecl _ _ is))
= let (startLoc, _) = startEndLoc toks (head is)
(_, endLoc) = startEndLoc toks (last is)
in extendForwards toks startLoc endLoc isFixty
startEndLoc toks d@(Dec (HsFunBind _ ms))
= let (startLoc, _) = startEndLoc toks (ghead "startEndLoc:HsDeclP3" ms)
(_, endLoc) = if ms == [] then (simpPos0, simpPos0)
else startEndLoc toks (glast "startEndLoc:HsDeclP4" ms)
in (startLoc, endLoc)
startEndLoc toks t@(Dec (HsPatBind _ p rhs ds))
= let (startLoc, _) = startEndLoc toks p
(_, endLoc) = if ds ==[] then startEndLoc toks rhs
else startEndLoc toks (glast "startEndLoc:HsDeclP5" ds)
locs = srcLocs t
(startLoc1,endLoc1) = (if startLoc == simpPos0 && locs /=[] then ghead "getStartEndLoc" locs
else startLoc,
if endLoc == simpPos0 && locs /= [] then glast "getStartEndLoc" locs
else endLoc)
toks1 = gtail "startEndLoc:HsPatBind" (dropWhile (\t->tokenPos t /= endLoc1) toks)
endLoc2 = if toks1==[]
then endLoc1
else let toks2 = takeWhile (\t -> isSpecialTok t && needmore toks t) toks1
in if toks2 == [] || all (\t-> isWhiteSpace t) toks2
then endLoc1
else (tokenPos.glast "startEndLoc::HsMatchP") toks2
in (startLoc1, endLoc2)
where
isSpecialTok t = isWhiteSpace t || isCloseBracket t || isOpenBracket t || isOpenSquareBracket t
|| isCloseSquareBracket t
needmore toks t = case isCloseBracket t of
True -> let openBrackets = length $ filter isOpenBracket toks
closeBrackets = length $ filter isCloseBracket toks
in closeBrackets < openBrackets
False -> case isCloseSquareBracket t of
True -> let openSqBrackets = length $ filter isOpenSquareBracket toks
closeSqBrackets = length $ filter isCloseSquareBracket toks
in closeSqBrackets < openSqBrackets
False -> True
startEndLoc toks (Dec (HsTypeSig _ is c t))
= let (startLoc, _) = startEndLoc toks (ghead "startEndLoc:HsDeclP6" is)
(_, endLoc) = startEndLoc toks t
in (startLoc, endLoc)
startEndLoc toks decl@(Dec (HsClassDecl loc c tp funDeps ds))
= let locs = srcLocs decl
(startLoc, endLoc)
= if locs == [] then (simpPos0, simpPos0)
else (head locs, last locs)
in extendForwards toks startLoc endLoc isClass
startEndLoc toks decl@(Dec (HsInstDecl loc i c t ds))
= let locs = srcLocs decl
(startLoc, endLoc)
= if locs == [] then (simpPos0, simpPos0)
else (head locs, last locs)
in extendForwards toks startLoc endLoc isInstance
{-
startEndLoc toks (Dec (HsPrimitiveTypeDecl _ c tp))
= let (startLoc, endLoc) = startEndLoc toks tp
in extendForward toks startLoc endLoc isData
startEndLoc toks (Dec (HsPrimitiveBind _ i t))
= let (startLoc, _) = startEndLoc toks i
(_, endLoc) = stratEndLoc toks t
in extendForward toks startLoc endLoc isPrimitive
-}
---------------End of the class StartEndLoc----------------------------------------
--------------------------------------------------------------------------------------------------------
-- This function should be the interface function for fetching start and end locations of a AST phrase in the source.
getStartEndLoc::(Term t, StartEndLoc t,Printable t)=>[PosToken]->t->(SimpPos,SimpPos)
getStartEndLoc toks t
= let (startPos',endPos') = startEndLoc toks t
locs = srcLocs t
(startPos,endPos) = (if startPos' == simpPos0 && locs /=[] then ghead "getStartEndLoc" locs
else startPos',
if endPos' == simpPos0 && locs /= [] then glast "getStartEndLoc" locs
else endPos')
in (startPos, endPos)
{- THECK : myppi.
adjustLoc toks (startPos,endPos) t -- to handle syntax phrase starts/ends with [], () ...
where
adjustLoc toks (startPos,endPos) t
= let astToks = filter (not.unwantedTok) $ tokenise (Pos 0 0 1) 1 True $ (render.myppi) t
(toks1,toks2, toks3) = splitToks (startPos, endPos) toks
toks2' = filter (not.unwantedTok) toks2
(t1, t2) =(ghead "getStartEndLoc1" astToks, glast "getStartEndLoc2" astToks)
startPos'= if sameToks t1 (ghead "getStartEndLoc3" toks2')
then startPos
else tokenPos $ ghead "getStartEndLoc4" $ dropWhile (\t-> not (sameToks t t1)) (reverse toks1)
endPos' = if sameToks t2 (glast "getStartEndLoc2" toks2')
then endPos
else tokenPos $ ghead "getStartEndLoc5" $ dropWhile (\t-> not (sameToks t t2)) toks3
in (startPos', endPos')
unwantedTok t = isWhite t || isCloseBracket t || isOpenBracket t || isOpenSquareBracket t
|| isCloseSquareBracket t || isComma t
sameToks (t1, (l1, c1)) (t2, (l2, c2)) = t1 == t2 && c1 == c2
-}
-- this function has problems whegtn they encounter sth. like [.....[p]]/
extendBothSides toks startLoc endLoc forwardCondFun backwardCondFun
=let (toks1,toks2)=break (\t->tokenPos t==startLoc) toks
toks21=gtail ("extendBothSides" ++ (show (startLoc, endLoc, toks2)) ) $ dropWhile (\t->tokenPos t /=endLoc) toks2
firstLoc=case (dropWhile (not.forwardCondFun) (reverse toks1)) of
[] -> startLoc -- is this the correct default?
l -> (tokenPos.ghead "extendBothSides:lastTok") l
lastLoc =case (dropWhile (not.backwardCondFun) toks21) of
[] ->endLoc --is this a correct default?
l -> (tokenPos.ghead "extendBothSides:lastTok") l
in (firstLoc, lastLoc)
extendForwards toks startLoc endLoc forwardCondFun
=let toks1=takeWhile (\t->tokenPos t /= startLoc) toks
firstLoc=case (dropWhile (not.forwardCondFun) (reverse toks1)) of
[] ->startLoc -- is this the correct default?
l -> (tokenPos.ghead "extendForwards") l
in (firstLoc, endLoc)
extendBackwards toks startLoc endLoc backwardCondFun
= let toks1= gtail "extendBackwards" $ dropWhile (\t->tokenPos t /=endLoc) toks
lastLoc=case (dropWhile (not.backwardCondFun) toks1) of
[] ->endLoc -- is this the correct default?
l ->(tokenPos. ghead "extendBackwards") l
in (startLoc, lastLoc)
------------------Some functions for associating comments with syntax phrases.---------------------------
{- Note: We assume that a comment before t belongs to t only if there is at most one blank line between them,
and a cooment after t belongs to t only it the comment starts at the last line of t.
-}
{-Get the start&end location of syntax phrase t, then extend the end location to cover the comment/white spaces
or new line which starts in the same line as the end location-}
startEndLocIncFowComment::(Term t, Printable t,StartEndLoc t)=>[PosToken]->t->(SimpPos,SimpPos)
startEndLocIncFowComment toks t
=let (startLoc,endLoc)=getStartEndLoc toks t
toks1= gtail "startEndLocIncFowComment" $ dropWhile (\t->tokenPos t/=endLoc) toks
toks11 = let (ts1, ts2) = break hasNewLn toks1
in (ts1 ++ if ts2==[] then [] else [ghead "startEndLocInFowComment" ts2])
in if toks11/=[] && all (\t->isWhite t || endsWithNewLn t) toks11
then (startLoc, tokenPos (glast "startEndLocIncFowComment" toks11))
else (startLoc, endLoc)
{-get the start&end location of t in the token stream, then extend the end location to cover
the following '\n' if there is no other characters (except white space) between t and the '\n'
-}
startEndLocIncFowNewLn::(Term t, Printable t,StartEndLoc t)=>[PosToken]->t->(SimpPos,SimpPos)
startEndLocIncFowNewLn toks t
=let (startLoc,endLoc)=getStartEndLoc toks t
toks1 = dropWhile isWhiteSpace $ gtail "startEndLocIncFowNewLn" $ dropWhile (\t->tokenPos t /=endLoc) toks
nextTok= if toks1==[] then defaultToken else head toks1
in if isNewLn nextTok
then (startLoc, tokenPos nextTok)
else (startLoc, endLoc)
{-get the start&end loation of t in the token stream, then extend the start and end location to
cover the preceding and folllowing comments.
-}
startEndLocIncComments::(Term t, StartEndLoc t,Printable t)=>[PosToken]->t->(SimpPos,SimpPos)
startEndLocIncComments toks t
=let (startLoc,endLoc)=getStartEndLoc toks t
(toks11,toks12)= let (ts1,ts2) = break (\t->tokenPos t == startLoc) toks
(ts11, ts12) = break hasNewLn (reverse ts1)
in (reverse ts12, reverse ts11++ts2)
toks12'=takeWhile (\t->tokenPos t /=startLoc) toks12
startLoc'=
if all isWhite toks12'
then -- group the toks1 according to lines in a reverse order.
let groupedToks=reverse $ groupTokensByLine toks11
-- empty lines right before t
emptyLns=takeWhile (all (\t->isWhiteSpace t || isNewLn t )) groupedToks
lastComment=if length emptyLns <=1 -- get the comment if there is any
then takeWhile (all isWhite) $ takeWhile (any isComment) $ dropWhile
(all (\t->isWhiteSpace t || isNewLn t)) groupedToks
else [] -- no comment
toks1'=if lastComment /=[] then concat $ reverse (emptyLns ++ lastComment)
else []
in if toks1'==[]
then if toks12'/=[]
then (tokenPos (ghead "startEndLocIncComments" toks12')) --there is no comment before t
else startLoc
--there is a comment before t
else tokenPos (ghead "startEndLocIncComments" toks1')
else startLoc
-- tokens after t
toks2=gtail "startEndLocIncComments1" $ dropWhile (\t->tokenPos t/=endLoc) toks
-- toks21 are those tokens that are in the same line with the last line of t
(toks21,tok22)= let (ts11, ts12) = break hasNewLn toks2
in (ts11 ++ if ts12==[] then [] else [ghead "startEndLocIncComments" ts12],
gtail "startEndLocIncComments2" ts12)
in if toks21==[] then (startLoc',endLoc) -- no following comments.
else if all (\t->isWhite t || endsWithNewLn t) toks21 --get the following white tokens in the same
--line of the last token of t
then (startLoc', tokenPos (last toks21))
else (startLoc', endLoc)
--Create a list of white space tokens.
whiteSpacesToken::SimpPos->Int->[PosToken]
whiteSpacesToken (row,col) n
|n>0 = [(Whitespace,(Pos 0 row col,replicate n ' '))]
|otherwise = []
-------------------------------------------------------------------------------------------------
adjustOffset::Int->[PosToken]->Bool->[PosToken]
adjustOffset offset [] _ = []
adjustOffset offset toks firstLineIncluded
= let groupedToks = groupBy (\x y->tokenRow x==tokenRow y) toks --groupedToks/=[], no problem with 'head'
--if firstLineIncluded is False, the offset of the first line won't be ajusted.
in if offset>=0 then if firstLineIncluded
then concatMap (doAddWhites offset) groupedToks
else ghead "adjustOffset" groupedToks ++ concatMap (doAddWhites offset) (tail groupedToks)
else if firstLineIncluded
then concatMap (doRmWhites (-offset)) groupedToks
else ghead "adjustOffset" groupedToks ++ concatMap (doRmWhites (-offset)) (tail groupedToks)