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 -- , 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)