module Language.Haskell.Refact.Utils.TokenUtils(
initTokenCache
, initTokenCacheLayout
, mkTreeFromTokens
, mkTreeFromSpanTokens
, putToksInCache
, replaceTokenInCache
, removeToksFromCache
, getTreeFromCache
, replaceTreeInCache
, syncAstToLatestCache
, getTokensFor
, getTokensForNoIntros
, getTokensBefore
, replaceTokenForSrcSpan
, updateTokensForSrcSpan
, insertSrcSpan
, removeSrcSpan
, getSrcSpanFor
, getSrcSpanForDeep
, addNewSrcSpanAndToksAfter
, addToksAfterSrcSpan
, addDeclToksAfterSrcSpan
, syncAST
, indentDeclToks
, Positioning(..)
, retrieveTokensFinal
, adjustLinesForDeleted
, retrieveTokensInterim
, retrieveTokens'
, treeIdFromForestSpan
, reAlignMarked
, posToSrcSpan
, posToSrcSpanTok
, fileNameFromTok
, treeStartEnd
, spanStartEnd
, sf
, fs
, forestSpanFromEntry
, combineSpans
, ReversedToks(..)
, reverseToks
, unReverseToks
, reversedToks
, placeToksForSpan
, limitPrevToks
, reIndentToks
, reAlignOneLine
, reAlignToks
, splitForestOnSpan
, spanContains
, containsStart, containsMiddle, containsEnd
, doSplitTree, splitSubtree, splitSubToks
, nonCommentSpan
, invariantOk
, invariant
, showForest
, showTree
, showSrcSpan
, showSrcSpanF
, ghcSpanStartEnd
, insertNodeAfter
, retrievePrevLineToks
, getTreeSpansAsList
, openZipperToNode
, openZipperToNodeDeep
, openZipperToSpan
, openZipperToSpanDeep
, openZipperToSpanAdded
, openZipperToSpanOrig
, forestSpanToSimpPos
, forestSpanToGhcPos
, ghcLineToForestLine
, forestLineToGhcLine
, forestSpanToSrcSpan
, forestPosVersionSet
, forestPosVersionNotSet
, forestSpanLenChanged
, forestSpanVersions
, forestSpanVersionSet
, forestSpanVersionNotSet
, insertForestLineInSrcSpan
, insertLenChangedInSrcSpan
, insertVersionsInSrcSpan
, srcSpanToForestSpan
, nullSpan,nullPos
, simpPosToForestSpan
, srcPosToSimpPos
, showForestSpan
, deleteGapsToks
, calcEndGap
, stripForestLines
, drawTreeEntry
, drawTokenCache
, drawTokenCacheDetailed
, drawForestEntry
, drawEntry
, drawTreeCompact
) where
import qualified FastString as GHC
import qualified GHC as GHC
import qualified SrcLoc as GHC
import qualified Data.Generics as SYB
import qualified GHC.SYB.Utils as SYB
import qualified Data.Foldable as F
import Language.Haskell.Refact.Utils.GhcUtils
import Language.Haskell.Refact.Utils.LayoutTypes
import Language.Haskell.Refact.Utils.LocUtils
import Language.Haskell.Refact.Utils.TokenUtilsTypes
import Language.Haskell.Refact.Utils.TypeSyn
import Control.Monad.Trans.State.Lazy
import Data.Bits
import Data.List
import Data.Tree
import qualified Data.Map as Map
import qualified Data.Tree.Zipper as Z
deriving instance Show Entry
instance Ord LayoutTree where
compare (Node a _) (Node b _) = compare (forestSpanFromEntry a) (forestSpanFromEntry b)
instance Eq Entry where
(Entry fs1 lay1 toks1) == (Entry fs2 lay2 toks2)
= fs1 == fs2 && lay1 == lay2
&& (show toks1) == (show toks2)
(Deleted fs1 pg1 lay1) == (Deleted fs2 pg2 lay2)
= fs1 == fs2 && pg1 == pg2 && lay1 == lay2
(==) _ _ = False
data ReversedToks = RT [PosToken]
deriving (Show)
reverseToks :: [PosToken] -> ReversedToks
reverseToks toks = RT $ reverse toks
unReverseToks :: ReversedToks -> [PosToken]
unReverseToks (RT toks) = reverse toks
reversedToks :: ReversedToks -> [PosToken]
reversedToks (RT toks) = toks
data Positioning = PlaceAdjacent
| PlaceAbsolute !Int !Int
| PlaceAbsCol !Int !Int !Int
| PlaceOffset !Int !Int !Int
| PlaceIndent !Int !Int !Int
deriving (Show)
forestLineMask,forestVersionMask,forestTreeMask,forestLenChangedMask :: Int
forestLineMask = 0xfffff
forestVersionMask = 0x1f00000
forestTreeMask = 0x3e000000
forestLenChangedMask = 0x40000000
forestVersionShift :: Int
forestVersionShift = 20
forestTreeShift :: Int
forestTreeShift = 25
ghcLineToForestLine :: Int -> ForestLine
ghcLineToForestLine l = ForestLine ch tr v l'
where
l' = l .&. forestLineMask
v = shiftR (l .&. forestVersionMask) forestVersionShift
tr = shiftR (l .&. forestTreeMask) forestTreeShift
ch = (l .&. forestLenChangedMask) /= 0
forestLineToGhcLine :: ForestLine -> Int
forestLineToGhcLine fl = (if (flSpanLengthChanged fl) then forestLenChangedMask else 0)
+ (shiftL (flTreeSelector fl) forestTreeShift)
+ (shiftL (flInsertVersion fl) forestVersionShift)
+ (flLine fl)
forestSpanToSrcSpan :: ForestSpan -> GHC.SrcSpan
forestSpanToSrcSpan ((fls,sc),(fle,ec)) = sspan
where
lineStart = forestLineToGhcLine fls
lineEnd = forestLineToGhcLine fle
locStart = GHC.mkSrcLoc (GHC.mkFastString "foo") lineStart sc
locEnd = GHC.mkSrcLoc (GHC.mkFastString "foo") lineEnd ec
sspan = GHC.mkSrcSpan locStart locEnd
instance Ord ForestLine where
compare (ForestLine _sc1 _ v1 l1) (ForestLine _sc2 _ v2 l2) =
if (l1 == l2)
then compare v1 v2
else compare l1 l2
forestSpanVersions :: ForestSpan -> (Int,Int)
forestSpanVersions ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = (sv,ev)
forestSpanAstVersions :: ForestSpan -> (Int,Int)
forestSpanAstVersions ((ForestLine _ trs _ _,_),(ForestLine _ tre _ _,_)) = (trs,tre)
forestSpanLenChangedFlags :: ForestSpan -> (Bool,Bool)
forestSpanLenChangedFlags ((ForestLine chs _ _ _,_),(ForestLine che _ _ _,_)) = (chs,che)
forestSpanVersionSet :: ForestSpan -> Bool
forestSpanVersionSet ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = sv /= 0 || ev /= 0
forestSpanVersionNotSet :: ForestSpan -> Bool
forestSpanVersionNotSet ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = sv == 0 && ev == 0
forestPosVersionSet :: ForestPos -> Bool
forestPosVersionSet (ForestLine _ _ v _,_) = v /= 0
forestPosAstVersionSet :: ForestPos -> Bool
forestPosAstVersionSet (ForestLine _ tr _ _,_) = tr /= 0
forestPosVersionNotSet :: ForestPos -> Bool
forestPosVersionNotSet (ForestLine _ _ v _,_) = v == 0
forestSpanLenChanged :: ForestSpan -> Bool
forestSpanLenChanged (s,e) = (forestPosLenChanged s) || (forestPosLenChanged e)
forestPosLenChanged :: ForestPos -> Bool
forestPosLenChanged (ForestLine ch _ _ _,_) = ch
treeIdIntoForestSpan :: TreeId -> ForestSpan -> ForestSpan
treeIdIntoForestSpan (TId sel) ((ForestLine chs _ sv sl,sc),(ForestLine che _ ev el,ec))
= ((ForestLine chs sel sv sl,sc),(ForestLine che sel ev el,ec))
forestSpanToSimpPos :: ForestSpan -> (SimpPos,SimpPos)
forestSpanToSimpPos ((ForestLine _ _ _ sr,sc),(ForestLine _ _ _ er,ec)) = ((sr,sc),(er,ec))
forestSpanToGhcPos :: ForestSpan -> (SimpPos,SimpPos)
forestSpanToGhcPos ((fls,sc),(fle,ec))
= ((forestLineToGhcLine fls,sc),(forestLineToGhcLine fle,ec))
simpPosToForestSpan :: (SimpPos,SimpPos) -> ForestSpan
simpPosToForestSpan ((sr,sc),(er,ec))
= ((ghcLineToForestLine sr,sc),(ghcLineToForestLine er,ec))
srcPosToSimpPos :: (Int,Int) -> (Int,Int)
srcPosToSimpPos (sr,c) = (l,c)
where
(ForestLine _ _ _ l) = ghcLineToForestLine sr
forestSpanStart :: ForestSpan -> ForestPos
forestSpanStart (start,_) = start
forestSpanEnd :: ForestSpan -> ForestPos
forestSpanEnd (_,end) = end
nullSpan :: ForestSpan
nullSpan = (nullPos,nullPos)
nullPos :: ForestPos
nullPos = (ForestLine False 0 0 0,0)
showForestSpan :: ForestSpan -> String
showForestSpan ((sr,sc),(er,ec))
= show ((flToNum sr,sc),(flToNum er,ec))
where
flToNum (ForestLine ch tr v l) = (if ch then 10000000000::Integer else 0)
+ ((fromIntegral tr) * 100000000::Integer)
+ ((fromIntegral v) * 1000000::Integer)
+ (fromIntegral l)
insertForestLineInSrcSpan :: ForestLine -> GHC.SrcSpan -> GHC.SrcSpan
insertForestLineInSrcSpan fl@(ForestLine ch tr v _l) (GHC.RealSrcSpan ss) = ss'
where
lineStart = forestLineToGhcLine fl
(_,(ForestLine _ _ _ le,_)) = srcSpanToForestSpan (GHC.RealSrcSpan ss)
lineEnd = forestLineToGhcLine (ForestLine ch tr v le)
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss)
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineEnd (GHC.srcSpanEndCol ss)
ss' = GHC.mkSrcSpan locStart locEnd
insertForestLineInSrcSpan _ _ss = error $ "insertForestLineInSrcSpan: expecting a RealSrcSpan, got:"
insertVersionsInSrcSpan :: Int -> Int -> GHC.SrcSpan -> GHC.SrcSpan
insertVersionsInSrcSpan vs ve rss@(GHC.RealSrcSpan ss) = ss'
where
(chs,che) = forestSpanLenChangedFlags $ srcSpanToForestSpan rss
(trs,tre) = forestSpanAstVersions $ srcSpanToForestSpan rss
lineStart = forestLineToGhcLine (ForestLine chs trs vs (GHC.srcSpanStartLine ss))
lineEnd = forestLineToGhcLine (ForestLine che tre ve (GHC.srcSpanEndLine ss))
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss)
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineEnd (GHC.srcSpanEndCol ss)
ss' = GHC.mkSrcSpan locStart locEnd
insertVersionsInSrcSpan _ _ _ss = error $ "insertVersionsInSrcSpan: expecting a RealSrcSpan, got:"
insertLenChangedInSrcSpan :: Bool -> Bool -> GHC.SrcSpan -> GHC.SrcSpan
insertLenChangedInSrcSpan chs che rss@(GHC.RealSrcSpan ss) = ss'
where
(sl,_sc) = getGhcLoc rss
(el,_ec) = getGhcLocEnd rss
sl' = if chs then sl .|. forestLenChangedMask
else sl .&. (complement forestLenChangedMask)
el' = if che then el .|. forestLenChangedMask
else el .&. (complement forestLenChangedMask)
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) sl' (GHC.srcSpanStartCol ss)
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) el' (GHC.srcSpanEndCol ss)
ss' = GHC.mkSrcSpan locStart locEnd
insertLenChangedInSrcSpan _ _ _ss = error $ "insertVersionsInSrcSpan: expecting a RealSrcSpan, got:"
insertVersionsInForestSpan :: Int -> Int -> ForestSpan -> ForestSpan
insertVersionsInForestSpan vsNew veNew ((ForestLine chs trs _vs ls,cs),(ForestLine che tre _ve le,ce))
= ((ForestLine chs trs vsNew ls,cs),(ForestLine che tre veNew le,ce))
insertLenChangedInForestSpan :: Bool -> ForestSpan -> ForestSpan
insertLenChangedInForestSpan chNew ((ForestLine _chs trs vs ls,cs),(ForestLine _che tre ve le,ce))
= ((ForestLine chNew trs vs ls,cs),(ForestLine chNew tre ve le,ce))
srcSpanToForestSpan :: GHC.SrcSpan -> ForestSpan
srcSpanToForestSpan sspan = ((ghcLineToForestLine startRow,startCol),(ghcLineToForestLine endRow,endCol))
where
(startRow,startCol) = getGhcLoc sspan
(endRow,endCol) = getGhcLocEnd sspan
forestSpanFromEntry :: Entry -> ForestSpan
forestSpanFromEntry (Entry ss _ _) = ss
forestSpanFromEntry (Deleted ss _ _) = ss
putForestSpanInEntry :: Entry -> ForestSpan -> Entry
putForestSpanInEntry (Entry _ss lay toks) ssnew = (Entry ssnew lay toks)
putForestSpanInEntry (Deleted _ss pg eg) ssnew = (Deleted ssnew pg eg)
treeIdFromForestSpan :: ForestSpan -> TreeId
treeIdFromForestSpan ((ForestLine _ tr _ _,_),(ForestLine _ _ _ _,_)) = TId tr
initTokenCache :: [PosToken] -> TokenCache
initTokenCache toks = TK (Map.fromList [((TId 0),(mkTreeFromTokens toks))]) (TId 0)
initTokenCacheLayout :: Tree Entry -> TokenCache
initTokenCacheLayout tree = TK (Map.fromList [((TId 0),tree)]) (TId 0)
treeIdIntoTree :: TreeId -> Tree Entry -> Tree Entry
treeIdIntoTree tid (Node (Entry fspan lay toks) subTree) = tree'
where
fs' = treeIdIntoForestSpan tid fspan
tree' = Node (Entry fs' lay toks) subTree
treeIdIntoTree tid (Node (Deleted fspan pg eg) subTree) = tree'
where
fs' = treeIdIntoForestSpan tid fspan
tree' = Node (Deleted fs' pg eg) subTree
stash :: TokenCache -> Tree Entry -> TokenCache
stash tk oldTree = tk'
where
(TId lastTreeId) = tkLastTreeId tk
lastTreeId' = TId (lastTreeId + 1)
oldTree' = treeIdIntoTree lastTreeId' oldTree
cache' = Map.insert lastTreeId' oldTree' (tkCache tk)
tk' = tk {tkLastTreeId = lastTreeId', tkCache = cache' }
replaceTokenInCache :: TokenCache -> GHC.SrcSpan -> PosToken -> TokenCache
replaceTokenInCache tk sspan tok = tk'
where
forest = getTreeFromCache sspan tk
forest' = replaceTokenForSrcSpan forest sspan tok
tk' = replaceTreeInCache sspan forest' tk
putToksInCache :: TokenCache -> GHC.SrcSpan -> [PosToken] -> (TokenCache,GHC.SrcSpan)
putToksInCache tk sspan toks = (tk'',newSpan)
where
forest = getTreeFromCache sspan tk
(forest',newSpan,oldTree) = updateTokensForSrcSpan forest sspan toks
tk' = replaceTreeInCache sspan forest' tk
tk'' = stash tk' oldTree
removeToksFromCache :: TokenCache -> GHC.SrcSpan -> TokenCache
removeToksFromCache tk sspan = tk''
where
forest = getTreeFromCache sspan tk
(forest',oldTree) = removeSrcSpan forest (srcSpanToForestSpan sspan)
tk' = replaceTreeInCache sspan forest' tk
tk'' = stash tk' oldTree
getTreeFromCache :: GHC.SrcSpan -> TokenCache -> Tree Entry
getTreeFromCache sspan tk = (tkCache tk) Map.! tid
where
tid = treeIdFromForestSpan $ srcSpanToForestSpan sspan
replaceTreeInCache :: GHC.SrcSpan -> Tree Entry -> TokenCache -> TokenCache
replaceTreeInCache sspan tree tk = tk'
where
tid = treeIdFromForestSpan $ srcSpanToForestSpan sspan
tree' = putTidInTree tid tree
tk' = tk {tkCache = Map.insert tid tree' (tkCache tk) }
putTidInTree :: TreeId -> Tree Entry -> Tree Entry
putTidInTree tid (Node (Deleted fspan pg eg) subs) = (Node (Deleted fs' pg eg) subs)
where fs' = treeIdIntoForestSpan tid fspan
putTidInTree tid (Node (Entry fspan lay toks) subs) = tree'
where
subs' = map (putTidInTree tid) subs
fs' = treeIdIntoForestSpan tid fspan
tree' = Node (Entry fs' lay toks) subs'
syncAstToLatestCache :: (SYB.Data t) => TokenCache -> GHC.Located t -> GHC.Located t
syncAstToLatestCache tk t = t'
where
mainForest = (tkCache tk) Map.! mainTid
forest@(Node (Entry fspan _ _) _) = (tkCache tk) Map.! (tkLastTreeId tk)
pos = forestSpanToGhcPos fspan
sspan = posToSrcSpan mainForest pos
(t',_) = syncAST t sspan forest
getTokensFor :: Bool -> Tree Entry -> GHC.SrcSpan -> (Tree Entry,[PosToken])
getTokensFor checkInvariant forest sspan = (forest'', tokens)
where
forest' = if (not checkInvariant) || invariantOk forest
then forest
else error $ "getTokensFor:invariant failed:" ++ (show $ invariant forest)
(forest'',tree) = getSrcSpanFor forest' (srcSpanToForestSpan sspan)
tokens = retrieveTokensInterim tree
getTokensForNoIntros :: Bool -> Tree Entry -> GHC.SrcSpan -> (Tree Entry,[PosToken])
getTokensForNoIntros checkInvariant forest sspan = (forest', tokens')
where
(forest',tokens) = getTokensFor checkInvariant forest sspan
(lead,rest) = break (not . isIgnoredNonComment) tokens
tokens' = (filter (not . isIgnored) lead) ++ rest
getTokensBefore :: Tree Entry -> GHC.SrcSpan -> (Tree Entry,ReversedToks)
getTokensBefore forest sspan = (forest', prevToks')
where
(forest',tree@(Node (Entry _s _ _) _)) = getSrcSpanFor forest (srcSpanToForestSpan sspan)
z = openZipperToSpan (srcSpanToForestSpan sspan) $ Z.fromTree forest'
prevToks = case (retrievePrevLineToks z) of
RT [] -> reverseToks $ retrieveTokensInterim tree
xs -> xs
(_,rtoks) = break (\t->tokenPos t < (getGhcLoc sspan)) $ reversedToks prevToks
prevToks' = RT rtoks
replaceTokenForSrcSpan :: Tree Entry -> GHC.SrcSpan -> PosToken -> Tree Entry
replaceTokenForSrcSpan forest sspan tok = forest'
where
(GHC.L tl _,_) = tok
z = openZipperToSpanDeep (srcSpanToForestSpan sspan) $ Z.fromTree forest
z' = z
(tspan,lay,toks) = case Z.tree z' of
(Node (Entry ss ly tks) []) -> (ss,ly,tks)
(Node (Entry _ _ _nullToks) _sub) -> error $ "replaceTokenForSrcSpan:tok pos" ++ (showForestSpan $ sf sspan) ++ " expecting tokens, found: " ++ (show $ Z.tree z')
(Node (Deleted _ _ _) _sub) -> error $ "replaceTokenForSrcSpan:tok pos" ++ (showForestSpan $ sf sspan) ++ " expecting Entry, found: " ++ (show $ Z.tree z')
((row,col),_) = forestSpanToSimpPos $ srcSpanToForestSpan tl
toks' = replaceTokNoReAlign toks (row,col) tok
zf = Z.setTree (Node (Entry tspan lay toks') []) z'
forest' = Z.toTree zf
updateTokensForSrcSpan :: Tree Entry -> GHC.SrcSpan -> [PosToken] -> (Tree Entry,GHC.SrcSpan,Tree Entry)
updateTokensForSrcSpan forest sspan toks = (forest'',newSpan,oldTree)
where
(forest',tree@(Node (Entry _s _ _) _)) = getSrcSpanFor forest (srcSpanToForestSpan sspan)
prevToks = retrieveTokensInterim tree
endComments = reverse $ takeWhile isWhiteSpaceOrIgnored $ reverse toks
startComments = takeWhile isWhiteSpaceOrIgnored $ toks
newTokStart = if (emptyList prevToks)
then mkZeroToken
else ghead "updateTokensForSrcSpan.1" prevToks
toks'' = if (nonEmptyList startComments || nonEmptyList endComments)
then
reIndentToks (PlaceAbsolute (tokenRow newTokStart) (tokenCol newTokStart)) prevToks toks
else
let
origEndComments = reverse $ takeWhile isWhiteSpaceOrIgnored $ reverse prevToks
origStartComments = takeWhile isWhiteSpaceOrIgnored $ prevToks
((startRow,startCol),_) = forestSpanToGhcPos $ srcSpanToForestSpan sspan
core = reIndentToks (PlaceAbsolute startRow startCol) prevToks toks
trail = if (emptyList origEndComments)
then []
else addOffsetToToks (lineOffset,colOffset) origEndComments
where
lineOffset = 0
colOffset = 0
toks' = origStartComments ++ core ++ trail
in toks'
(startPos,endPos) = nonCommentSpan toks''
(((ForestLine _chs _trs vs _),_),(ForestLine _che _tre ve _,_)) = srcSpanToForestSpan sspan
newSpan = insertLenChangedInSrcSpan True True
$ insertVersionsInSrcSpan vs ve $ posToSrcSpan forest (startPos,endPos)
zf = openZipperToNode tree $ Z.fromTree forest'
zf' = Z.setTree (Node (Entry (srcSpanToForestSpan newSpan) NoChange toks'') []) zf
forest'' = Z.toTree zf'
oldTree = tree
getSrcSpanFor :: Tree Entry -> ForestSpan -> (Tree Entry, Tree Entry)
getSrcSpanFor forest sspan = (forest',tree)
where
forest' = insertSrcSpan forest sspan
z = openZipperToSpan sspan $ Z.fromTree forest'
tree = Z.tree z
getSrcSpanForDeep :: Tree Entry -> ForestSpan -> (Tree Entry, Tree Entry)
getSrcSpanForDeep forest sspan = (forest',tree)
where
forest' = insertSrcSpan forest sspan
z = openZipperToSpanDeep sspan $ Z.fromTree forest'
tree = Z.tree z
insertSrcSpan :: Tree Entry -> ForestSpan -> Tree Entry
insertSrcSpan forest sspan = forest'
where
z = openZipperToSpan sspan $ Z.fromTree forest
forest' = if treeStartEnd (Z.tree z) == sspan
then forest
else if (Z.isLeaf z)
then
let
(Entry _ _ toks) = Z.label z
(tokStartPos,tokEndPos) = forestSpanToSimpPos sspan
(startLoc,endLoc) = startEndLocIncComments' toks (tokStartPos,tokEndPos)
(startToks,middleToks,endToks) = splitToks (startLoc,endLoc) toks
tree1 = if (nonCommentSpan startToks == ((0,0),(0,0)))
then []
else [mkTreeFromTokens startToks]
tree2 = [mkTreeFromSpanTokens sspan middleToks]
tree3 = if (nonCommentSpan endToks == ((0,0),(0,0)))
then []
else [mkTreeFromTokens endToks]
subTree = tree1 ++ tree2 ++ tree3
subTree' = filter (\t -> treeStartEnd t /= nullSpan) subTree
(Entry sspan2 _ _) = Z.label z
z' = Z.setTree (Node (Entry sspan2 NoChange []) subTree') z
forest'' = Z.toTree z'
in forest''
else
let
(before,middle,end) = doSplitTree (Z.tree z) sspan
newTree = case middle of
[x] -> x
_xs -> (Node (Entry sspan NoChange []) middle)
subTree' = before ++ [newTree] ++ end
(Entry sspan2 _ _) = Z.label z
z' = Z.setTree (Node (Entry sspan2 NoChange []) subTree') z
forest'' = Z.toTree z'
in
forest''
doSplitTree ::
Tree Entry -> ForestSpan
-> ([Tree Entry], [Tree Entry], [Tree Entry])
doSplitTree tree@(Node (Deleted _ss _ _) []) sspan = splitSubToks tree sspan
doSplitTree tree@(Node (Entry _ss _ _toks) []) sspan = splitSubToks tree sspan
doSplitTree tree sspan = (b'',m'',e'')
where
(b1,m1,e1) = splitSubtree tree sspan
(b,m,e) = case m1 of
[] ->
error $ "doSplitTree:no middle:(tree,sspan,b1,m1,e1)=" ++ (show (tree,sspan,b1,m1,e1))
[x] ->
doSplitTree x sspan
xx ->
(b',m',e')
where
(bb,mb,_eb) = case (doSplitTree (ghead "doSplitTree.2" xx) sspan) of
(x,y,[]) -> (x,y,[])
xxx -> error $ "doSplitTree:eb populated:" ++ (show (sspan,tree,xxx))
( [],me,ee) = doSplitTree (glast "doSplitTree.2" xx) sspan
mm = tail $ init xx
b' = bb
m' = mb ++ mm ++ me
e' = ee
(b'',m'',e'') = (b1++b,m,e++e1)
mkTreeListFromTokens :: [PosToken] -> ForestSpan -> Bool -> [Tree Entry]
mkTreeListFromTokens [] _sspan _ = []
mkTreeListFromTokens toks sspan useOriginalSpan = res
where
(Node (Entry tspan NoChange treeToks) sub) = mkTreeFromTokens toks
((ForestLine chs ts vs _, _),(ForestLine che te ve _, _)) = sspan
((ForestLine _ _ _ ls,cs),(ForestLine _ _ _ le,ce)) = tspan
span' = ((ForestLine chs ts vs ls, cs),(ForestLine che te ve le, ce))
res = if nonCommentSpan toks == ((0,0),(0,0))
then []
else if useOriginalSpan
then [(Node (Entry sspan NoChange treeToks) sub)]
else [(Node (Entry span' NoChange treeToks) sub)]
splitSubToks ::
Tree Entry
-> (ForestPos, ForestPos)
-> ([Tree Entry], [Tree Entry], [Tree Entry])
splitSubToks n@(Node (Deleted (treeStart,treeEnd) _pg _eg) []) (sspanStart,sspanEnd) = (b',m',e')
where
egs = (0,0)
ege = (0,0)
pg = 0
b' = if sspanStart > treeStart
then [Node (Deleted (treeStart,treeStart) pg egs) []]
else []
m' = [n]
e' = if treeEnd > sspanEnd
then [Node (Deleted (sspanEnd,treeEnd) pg ege) []]
else []
splitSubToks tree sspan = (b',m',e')
where
(Node (Entry ss@(treeStart,treeEnd) _lay toks) []) = tree
(sspanStart,sspanEnd) = sspan
(b',m',e') = case (containsStart ss sspan,containsEnd ss sspan) of
(True, False) -> (b'',m'',e'')
where
(_,toksb,toksm) = splitToks (forestSpanToSimpPos (nullPos,sspanStart)) toks
b'' = if (emptyList toksb || nonCommentSpan toksb == ((0,0),(0,0)))
then []
else [mkTreeFromTokens toksb]
m'' = let
(ForestLine _ch _ts _v le,ce) = sspanEnd
tl =
if (treeStart == sspanStart)
then mkTreeListFromTokens toksm (treeStart, treeEnd) False
else mkTreeListFromTokens toksm (sspanStart,treeEnd) False
_tl' = if emptyList tl
then []
else [Node (Entry (st,(ForestLine ch ts v le,ce)) lay tk) []]
where [Node (Entry (st,(ForestLine ch ts v _l,_c)) lay tk) []] = tl
in
tl
e'' = []
(True, True) -> (b'',m'',e'')
where
(toksb,toksm,tokse) = splitToks (forestSpanToSimpPos (sspanStart,sspanEnd)) toks
b'' = mkTreeListFromTokens toksb (treeStart, sspanStart) False
m'' = mkTreeListFromTokens toksm (sspanStart, sspanEnd) True
e'' = mkTreeListFromTokens tokse (sspanEnd, treeEnd) False
(False,True) -> (b'',m'',e'')
where
(_,toksm,tokse) = splitToks (forestSpanToSimpPos (nullPos,sspanEnd)) toks
b'' = []
m'' = let
tl = mkTreeListFromTokens toksm (treeStart,sspanEnd) False
tl' = if emptyList tl
then []
else [Node (Entry (st,sspanEnd) lay tk) []]
where [Node (Entry (st,_en) lay tk) []] = mkTreeListFromTokens toksm (treeStart,sspanEnd) False
in
tl'
e'' = mkTreeListFromTokens tokse (sspanEnd,treeEnd) False
(False,False) -> if (containsMiddle ss sspan)
then ([],[tree],[])
else error $ "splitSubToks: error (ss,sspan)=" ++ (show (ss,sspan))
containsStart :: ForestSpan -> ForestSpan -> Bool
containsStart (nodeStart,nodeEnd) (startPos,_endPos)
= (startPos >= nodeStart && startPos <= nodeEnd)
containsMiddle :: ForestSpan -> ForestSpan -> Bool
containsMiddle (nodeStart,nodeEnd) (startPos,endPos)
= (startPos <= nodeStart) && (endPos >= nodeEnd)
containsEnd :: ForestSpan -> ForestSpan -> Bool
containsEnd (nodeStart,nodeEnd) (_startPos,endPos)
= (endPos >= nodeStart && endPos <= nodeEnd)
splitSubtree ::
Tree Entry -> ForestSpan
-> ([Tree Entry], [Tree Entry], [Tree Entry])
splitSubtree tree sspan = (before,middle,end)
where
containsStart' t = containsStart (treeStartEnd t) sspan
containsMiddle' t = containsMiddle (treeStartEnd t) sspan
containsEnd' t = containsEnd (treeStartEnd t) sspan
cond t = containsStart' t || containsMiddle' t || containsEnd' t
(Node _entry children) = tree
(before,rest) = break (\x -> cond x) children
(endr,middler) = break (\x -> cond x) $ reverse rest
(middle,end) = (reverse middler,reverse endr)
removeSrcSpan :: Tree Entry -> ForestSpan
-> (Tree Entry,Tree Entry)
removeSrcSpan forest sspan = (forest'', delTree)
where
forest' = insertSrcSpan forest sspan
z = openZipperToSpan sspan $ Z.fromTree forest'
zp = gfromJust "removeSrcSpan" $ Z.parent z
((pg,_),eg) = calcPriorAndEndGap forest' sspan
pt = Z.tree zp
subTree = map (\t -> if (treeStartEnd t == sspan) then (Node (Deleted sspan pg eg) []) else t) $ subForest pt
z' = Z.setTree (pt { subForest = subTree}) zp
forest'' = Z.toTree z'
delTree = Z.tree z
calcPriorAndEndGap :: Tree Entry -> ForestSpan -> (SimpPos,SimpPos)
calcPriorAndEndGap tree sspan = (pg,eg)
where
((spanStartRow,spanStartCol),(spanRow,spanCol)) = forestSpanToSimpPos sspan
(spanStart,spanEnd) = sspan
entries = retrieveTokens' tree
(before,rest) = span (\e -> (forestSpanStart $ forestSpanFromEntry e) < spanStart) entries
(rafter,rmiddle) = break (\e -> (forestSpanEnd $ forestSpanFromEntry e) <= spanEnd) $ reverse rest
_middle = reverse rmiddle
after = reverse rafter
(tokRow,tokCol) = if emptyList after
then (spanRow + 2,spanCol)
else (r,c)
where
(r,c) = case ghead ("calcEndGap:after="++(show after)) after of
(Entry _ _ toks) -> (tokenRow t,tokenCol t)
where t = ghead "calcEndGap" toks
(Deleted ss _ _) -> fst $ forestSpanToSimpPos ss
eg = (tokRow spanRow, tokCol spanCol)
(tokRowPg,tokColPg) = if emptyList before
then (spanStartRow 1,spanStartCol)
else (r,c)
where
(r,c) = case glast ("calcEndGap:before="++(show before)) before of
(Entry _ _ toks) -> (tokenRow t,tokenCol t)
where t = glast "calcEndGap pg" toks
(Deleted ss _ _) -> snd $ forestSpanToSimpPos ss
pg = (spanStartRow tokRowPg, spanStartCol tokColPg)
calcEndGap :: Tree Entry -> ForestSpan -> SimpPos
calcEndGap tree sspan = gap
where
(_sspanStart,(spanRow,spanCol)) = forestSpanToSimpPos sspan
(spanStart,spanEnd) = sspan
entries = retrieveTokens' tree
(_before,rest) = span (\e -> (forestSpanStart $ forestSpanFromEntry e) < spanStart) entries
(rafter,rmiddle) = break (\e -> (forestSpanEnd $ forestSpanFromEntry e) <= spanEnd) $ reverse rest
_middle = reverse rmiddle
after = reverse rafter
(tokRow,tokCol) = if emptyList after
then (spanRow + 2,spanCol)
else (r,c)
where
(r,c) = case ghead ("calcEndGap:after="++(show after)) after of
(Entry _ _ toks) -> (tokenRow t,tokenCol t)
where t = ghead "calcEndGap" toks
(Deleted ss _ _) -> fst $ forestSpanToSimpPos ss
gap = (tokRow spanRow, tokCol spanCol)
retrieveTokensFinal :: Tree Entry -> [PosToken]
retrieveTokensFinal forest = monotonicLineToks $ stripForestLines $ reAlignMarked
$ deleteGapsToks $ retrieveTokens' forest
retrieveTokensPpr :: Tree Entry -> [Ppr]
retrieveTokensPpr forest = pps'''
where
(pps,_,lastLine) = retrieveTokensPpr' ([],Original,[]) forest
pps' = pps ++ (mkPprFromLineToks lastLine)
pps'' = mergeDeletesPpr pps'
pps''' = adjustPprForDeleted pps''
retrieveTokensPpr' :: ([Ppr],PprOrigin,[PosToken]) -> Tree Entry -> ([Ppr],PprOrigin,[PosToken])
retrieveTokensPpr' acc (Node (Deleted _sspan _pg ( 0,_cd) ) _) = acc
retrieveTokensPpr' acc (Node (Deleted sspan pg (rd,_cd) ) _) = acc'
where
(ac,o,curLineToks) = acc
ll = mkPprFromLineToksSrc o curLineToks
((rs,cs),(re,_ce)) = forestSpanToSimpPos sspan
ol = re rs
acc' = (ac ++ ll ++ [PprDeleted rs cs pg ol rd],o,[])
retrieveTokensPpr' acc (Node (Entry _sspan NoChange []) subs)
= foldl' retrieveTokensPpr' acc subs
retrieveTokensPpr' acc (Node (Entry _sspan (Above so _ (r,c) eo) []) subs) = acc'
where
(ac,_o,curLineToks) = acc
(sss,o2,cl2) = foldl' retrieveTokensPpr' ([],Original,[]) subs
cl2Acc = mkPprFromLineToksSrc o2 cl2
ll = mkPprFromLineToks curLineToks
acc' = (ac ++ ll ++ [PprAbove so (r,c) eo (normaliseColumns (sss++cl2Acc))],o2,[])
retrieveTokensPpr' (acc,oi,curLineToks) (Node (Entry sspan _ toks) []) = (acc++accNew,o,curLineToks')
where
o = if (forestSpanVersionSet sspan) then Added else Original
oi' = if o == Added || oi == Added then Added else Original
toksByLine = groupTokensByLine toks
(accNew,curLineToks') = case curLineToks of
[] -> case toksByLine of
[] -> ([],[])
[x] -> ([],x)
xs -> (concatMap (mkPprFromLineToksSrc o) (init xs),last xs)
_ -> case toksByLine of
[] -> ([],[])
[x] -> if (toksOnSameLine (last curLineToks) (head x))
then ([],curLineToks ++ x)
else (mkPprFromLineToksSrc oi curLineToks,x)
(x:xs) -> if (toksOnSameLine (last curLineToks) (head x))
then ((mkPprFromLineToksSrc oi' (curLineToks++x)) ++ concatMap (mkPprFromLineToksSrc o) ( init xs),last xs)
else ((mkPprFromLineToksSrc oi curLineToks ) ++ concatMap (mkPprFromLineToksSrc o) (x:init xs),last xs)
retrieveTokensPpr' _acc n@(Node (Entry _sspan (Above _so _ (_r,_c) _eo) _toks) _subs)
= error $ "retrieveTokensPpr': Above entry with toks:" ++ (show n)
retrieveTokensPpr' _acc n@(Node (Entry _sspan (NoChange) _toks) _subs)
= error $ "retrieveTokensPpr': NoChange entry with toks:" ++ (show n)
mkPprFromLineToks :: [PosToken] -> [Ppr]
mkPprFromLineToks toks = mkPprFromLineToksSrc Original toks
mkPprFromLineToksSrc :: PprOrigin -> [PosToken] -> [Ppr]
mkPprFromLineToksSrc _ [] = []
mkPprFromLineToksSrc o toks = [PprText ro co o str]
where
ro' = tokenRow $ head toks
co' = tokenCol $ head toks
(ro,co) = srcPosToSimpPos (tokenRow $ head toks, tokenCol $ head toks)
toks' = addOffsetToToks (ro',co') toks
str = GHC.showRichTokenStream toks'
normaliseColumns :: [Ppr] -> [Ppr]
normaliseColumns [] = []
normaliseColumns ps = ps'
where
offset = case (head ps) of
PprText _r c _ _ -> c 1
PprDeleted _r c _ _ _ -> c 1
_ -> 0
ps' = map removeOffset ps
removeOffset (PprText r c o toks) = (PprText r (c offset) o toks)
removeOffset (PprDeleted r c p l e) = (PprDeleted r (c offset) p l e)
removeOffset x = x
adjustPprForDeleted :: [Ppr] -> [Ppr]
adjustPprForDeleted [] = []
adjustPprForDeleted pps = pps'
where
(_,pps') = foldl' go ((0,0),[]) pps
go :: ((Int,Int),[Ppr]) -> Ppr -> ((Int,Int),[Ppr])
go ((ro,co),acc) (PprText r c Original str) = ((ro, co),acc++[PprText (rro) (cco) Original str])
go ((ro,co),acc) (PprText r c Added str) = ((ro1,co),acc++[PprText (r ) (c ) Added str])
go ((ro,co),acc) (PprDeleted r c pg l eg)
= ((ro + (pg + l + eg) (max pg eg),co),acc++[PprDeleted r c pg l eg])
go ((ro,co),acc) (PprAbove so p1 eo subs) = ((ro',co'),acc++[PprAbove so' p1' eo' subs'])
where
so' = so
p1' = p1
eo' = eo
((ro',co'),subs') = foldl' go ((ro,co),[]) subs
mergeDeletesPpr :: [Ppr] -> [Ppr]
mergeDeletesPpr [] = []
mergeDeletesPpr ((PprDeleted r1 c1 pg1 l1 eg1):(PprDeleted _r _c pg2 l2 eg2):ps)
= (PprDeleted r1 c1 pg1 (l1 + eg1 + pg2 + l2 1) eg2) : mergeDeletesPpr ps
mergeDeletesPpr (p:ps) = p : mergeDeletesPpr ps
getPprStartRow :: Ppr -> Row
getPprStartRow (PprText r _ _ _) = r
getPprStartRow (PprDeleted r _ _ _ _) = r
getPprStartRow (PprAbove _ _ _ []) = error "getPprStartRow: PprAbove with no subs"
getPprStartRow (PprAbove _ _ _ subs) = getPprStartRow $ head subs
getPprEndRow :: Ppr -> Row
getPprEndRow (PprText r _ _ _) = r
getPprEndRow (PprDeleted r _ _ _ _) = r
getPprEndRow (PprAbove _ _ _ []) = error "getPprEndRow: PprAbove with no subs"
getPprEndRow (PprAbove _ _ _ subs) = getPprEndRow $ last subs
adjustLinesForDeleted :: Tree Entry -> Tree Entry
adjustLinesForDeleted forest = forest'
where
(_,forest') = go (0,0) forest
go :: (Int,Int) -> Tree Entry -> ((Int,Int),Tree Entry)
go (ro,co) (n@(Node (Entry _ss _lay _toks) [])) = ((ro,co),applyOffsetToTreeShallow (ro,co) n)
go (ro,co) (n@(Node (Deleted _ _ (gr,_gc)) _nullSubs)) = ((rogr,co),n)
go (ro,co) (n@(Node (Entry _ss _lay []) _subs)) = ((ro',co'),Node (Entry ss lay []) subs')
where
(Node (Entry ss lay []) subs) = applyOffsetToTreeShallow (ro,co) n
((ro',co'),subs') = foldl' go' ((ro,co),[]) subs
go (_ro,_co) (n@(Node (Entry _ss _lay _toks) _subs))
= error $ "adjustLinesForDeleted: Entry with toks and subs:" ++ (show n)
go' ((ro,co),acc) tree = ((ro',co'),acc++[tree'])
where
((ro',co'),tree') = go (ro,co) tree
applyOffsetToTreeShallow :: (Int,Int) -> Tree Entry -> Tree Entry
applyOffsetToTreeShallow (ro,co) (Node (Entry sspan lay toks) subs)
= (Node (Entry sspan' lay toks') subs')
where
sspan' = addOffsetToForestSpan (ro,co) sspan
toks' = addOffsetToToks (ro,co) toks
subs' = subs
applyOffsetToTreeShallow _ n@(Node (Deleted _ _ _) _) = n
renderPpr :: [Ppr] -> String
renderPpr ps = res
where
(_,(_,res)) = runState (go 0 ps) ((1,1),"")
go _ [] = return ()
go ci (ppt@(PprText _rt _ct _ _toks):ppa@(PprAbove so (_,_cc) eo _subs):ps') = do
renderPprText ci ppt
addOffset so
(_,c) <- getRC
renderPprAbove c ppa
(cr,_cc) <- getRC
if ps' /= []
then
case eo of
FromAlignCol (ero,eco) -> newPos (cr+ero) (ci+eco)
SameLine _ -> addOffset eo
None -> return ()
else return ()
go ci ps'
go ci (p@(PprText _rt _ct _ _toks):ps') = do
renderPprText ci p
go ci ps'
go ci ((PprDeleted _ _ _ _ _):ps') = go ci ps'
go _ pps = error $ "renderPpr: unmatched in go:" ++ (show pps)
renderPprAbove _ci (PprAbove _ _ _ []) = return ()
renderPprAbove ci (PprAbove _ _ _ subs) = go ci subs
renderPprAbove _ ppr = error $ "renderPprAbove:unexpected ppr:" ++ (show ppr)
renderPprText ci (PprText rt ct _ str) = do
newPos rt (ci + ct)
addString str
renderPprText _ ppr = error $ "renderPprText:unexpected ppr:" ++ (show ppr)
addOffset None = return ()
addOffset (SameLine co) = do
(r,c) <- getRC
newPos r (c+co)
addOffset (FromAlignCol (ro,co)) = do
(r,c) <- getRC
newPos (r+ro) (c+co)
newPos newRow newCol = do
(oldRow',oldCol) <- getRC
let oldRow = if oldRow' <= newRow then oldRow' else (newRow 1)
putRC (oldRow,oldCol)
if oldRow == newRow
then addString (take (newCol oldCol) $ repeat ' ')
else
addString ( (take (newRow oldRow) $ repeat '\n') ++
(take (newCol 1) $ repeat ' ') )
checkInvariant $ "newPos:" ++ (show (newRow,newCol))
checkInvariant str = do
return ()
getRC = do
(rc,_) <- get
return rc
putRC (r,c) = do
(_,str) <- get
put ((r,c),str)
addString [] = return ()
addString str = do
((r,c),curr) <- get
let ll = (length $ filter (=='\n') str)
let c'' = (length $ takeWhile (/='\n') $ reverse str)
let (r',c') = case ll of
0 -> (r,c + c'')
_ -> (r + ll, c'' + 1)
put ((r',c'),curr++str)
checkInvariant $ "addString" ++ show str
addDebugString str = do
((r,c),curr) <- get
put ((r,c),curr++str)
retrieveTokensInterim :: Tree Entry -> [PosToken]
retrieveTokensInterim forest = monotonicLineToks $ stripForestLines
$ concat $ map (\t -> F.foldl accum [] t) [forest]
where
accum :: [PosToken] -> Entry -> [PosToken]
accum acc (Entry _ _ []) = acc
accum acc (Entry _ _ toks) = acc ++ toks
accum acc (Deleted _ _ _) = acc
retrieveTokens' :: Tree Entry -> [Entry]
retrieveTokens' forest = mergeDeletes $ concat $ map (\t -> F.foldl accum [] t) [forest]
where
accum :: [Entry] -> Entry -> [Entry]
accum acc (Entry _ _ []) = acc
accum acc e@(Entry _ _ _toks) = acc ++ [e]
accum acc e@(Deleted _ _ _) = acc ++ [e]
mergeDeletes :: [Entry] -> [Entry]
mergeDeletes [] = []
mergeDeletes [x] = [x]
mergeDeletes ((Deleted ss1 pg1 (r1,_)):(Deleted ss2 _ (r2,c2)):xs) = (Deleted ss pg1 o):xs
where
(start,_) = ss1
(_, end) = ss2
ss = (start,end)
o = (r1+r2,c2)
mergeDeletes (x:xs) = x:mergeDeletes xs
deleteGapsToks :: [Entry] -> [PosToken]
deleteGapsToks toks = goDeleteGapsToks (0,0) toks
goDeleteGapsToks :: SimpPos -> [Entry] -> [PosToken]
goDeleteGapsToks _ [] = []
goDeleteGapsToks offset [Entry _ _ t] = map (increaseSrcSpan offset) t
goDeleteGapsToks _ [Deleted _ _ _] = []
goDeleteGapsToks offset (Deleted _ _ _:ts) = goDeleteGapsToks offset ts
goDeleteGapsToks offset [Entry _ _ t,Deleted _ _ _] = map (increaseSrcSpan offset) t
goDeleteGapsToks offset (Entry _ _ t1:e@(Entry _ _ _):ts) = (map (increaseSrcSpan offset) t1) ++goDeleteGapsToks offset (e:ts)
goDeleteGapsToks (fr,fc) (Entry ss _lay1 t1:Deleted _ _ eg:t2:ts)
= t1' ++ goDeleteGapsToks offset' (t2:ts)
where
(deltaR,_deltaC) = eg
(_,(sr,_sc)) = forestSpanToSimpPos ss
((dr,_dc),_) = forestSpanToSimpPos $ forestSpanFromEntry t2
offset' = (fr + (sr dr) + deltaR, fc)
t1' = map (increaseSrcSpan (fr,fc)) t1
retrievePrevLineToks :: Z.TreePos Z.Full Entry -> ReversedToks
retrievePrevLineToks z = RT res'
where
prevToks = retrieveTokensInterim $ Z.tree z
res' = reverse $ concat $ reverse (prevToks : (go z))
go :: Z.TreePos Z.Full Entry -> [[PosToken]]
go zz
| not (Z.isRoot zz) = toks : (go $ gfromJust "retrievePrevLineToks" (Z.parent zz))
| otherwise = [toks]
where
toks = concat $ reverse $ map retrieveTokensInterim $ Z.before zz
stripForestLines :: [PosToken] -> [PosToken]
stripForestLines toks = map doOne toks
where
doOne (GHC.L l t,s) = (GHC.L l' t,s)
where
((ForestLine _ _ _ ls,_),(_,_)) = srcSpanToForestSpan l
l' = insertForestLineInSrcSpan (ForestLine False 0 0 ls) l
reAlignMarked :: [PosToken] -> [PosToken]
reAlignMarked toks = concatMap alignOne $ groupTokensByLine toks
where
alignOne toksl = unmarked ++ (reAlignOneLine marked)
where
(unmarked,marked) = break isMarked toksl
reAlignOneLine :: [PosToken] -> [PosToken]
reAlignOneLine toks = go (0,0) toks
where
go _ [] = []
go (l,c) (t:ts) = (increaseSrcSpan (l,c) t') : (go (l,c') ts)
where
(t',dc) = adjustToken t
c' = c + dc
adjustToken tt@(_,"") = (tt,0)
adjustToken tt@(lt@(GHC.L _ t),s) = ((GHC.L newL t,s),deltac)
where
(sl,sc) = getLocatedStart lt
(el,ec) = getLocatedEnd lt
deltac = (length s) (ec sc)
filename = fileNameFromTok tt
newL = GHC.mkSrcSpan (GHC.mkSrcLoc filename sl sc)
(GHC.mkSrcLoc filename el (ec + deltac))
reAlignToks :: [PosToken] -> [PosToken]
reAlignToks [] = []
reAlignToks [t] = [t]
reAlignToks (tok1@(_,""):ts) = tok1 : reAlignToks ts
reAlignToks (tok1@((GHC.L l1 _t1),_s1):tok2@((GHC.L l2 t2),s2):ts)
= tok1:reAlignToks (tok2':ts)
where
((_sr1,_sc1),(er1,ec1)) = (getGhcLoc l1,getGhcLocEnd l1)
(( sr2, sc2),(er2,ec2)) = (getGhcLoc l2,getGhcLocEnd l2)
((sr,sc),(er,ec)) = if (er1 == sr2 && ec1 >= sc2)
then ((sr2,ec1+1),(er2,ec1+1 + tokenLen tok2))
else ((sr2,sc2),(er2,ec2))
fname = case l2 of
GHC.RealSrcSpan ss -> GHC.srcSpanFile ss
_ -> GHC.mkFastString "foo"
l2' = GHC.mkRealSrcSpan (GHC.mkRealSrcLoc fname sr sc)
(GHC.mkRealSrcLoc fname er ec)
tok2' = ((GHC.L (GHC.RealSrcSpan l2') t2),s2)
addNewSrcSpanAndToksAfter ::
Tree Entry
-> GHC.SrcSpan
-> GHC.SrcSpan
-> Positioning
-> [PosToken]
-> (Tree Entry
, GHC.SrcSpan)
addNewSrcSpanAndToksAfter forest oldSpan newSpan pos toks = (forest'',newSpan')
where
(forest',tree) = getSrcSpanForDeep forest (srcSpanToForestSpan oldSpan)
(ghcl,_c) = getGhcLoc newSpan
(ForestLine ch tr v l) = ghcLineToForestLine ghcl
newSpan' = insertForestLineInSrcSpan (ForestLine ch tr (v+1) l) newSpan
toks' = placeToksForSpan forest' oldSpan tree pos toks
newNode = Node (Entry (srcSpanToForestSpan newSpan') NoChange toks') []
forest'' = insertNodeAfter tree newNode forest'
placeToksForSpan ::
Tree Entry
-> GHC.SrcSpan
-> Tree Entry
-> Positioning
-> [PosToken]
-> [PosToken]
placeToksForSpan forest oldSpan tree pos toks = toks'
where
z = openZipperToSpanDeep (srcSpanToForestSpan oldSpan) $ Z.fromTree forest
prevToks = case (retrievePrevLineToks z) of
RT [] -> reverseToks $ retrieveTokensInterim tree
xs -> xs
prevToks' = limitPrevToks prevToks oldSpan
toks' = reIndentToks pos (unReverseToks prevToks') toks
addToksAfterSrcSpan ::
Tree Entry
-> GHC.SrcSpan
-> Positioning
-> [PosToken]
-> (Tree Entry, GHC.SrcSpan)
addToksAfterSrcSpan forest oldSpan pos toks = (forest',newSpan')
where
(fwithspan,tree) = getSrcSpanForDeep forest (srcSpanToForestSpan oldSpan)
toks'' = placeToksForSpan fwithspan oldSpan tree pos toks
(startPos,endPos) = nonCommentSpan toks''
newSpan = posToSrcSpan forest (startPos,endPos)
(forest',newSpan') = addNewSrcSpanAndToksAfter forest oldSpan newSpan pos toks
limitPrevToks :: ReversedToks -> GHC.SrcSpan -> ReversedToks
limitPrevToks prevToks sspan = reverseToks prevToks''
where
((ForestLine _ _ _ startRow,_startCol),(ForestLine _ _ _ endRow,_)) = srcSpanToForestSpan sspan
prevToks' = dropWhile (\t -> tokenRow t > endRow) $ unReverseToks prevToks
prevToks'' = dropWhile (\t -> tokenRow t < startRow) prevToks'
addDeclToksAfterSrcSpan :: (SYB.Data t) =>
Tree Entry
-> GHC.SrcSpan
-> Positioning
-> [PosToken]
-> GHC.Located t
-> (Tree Entry, GHC.SrcSpan,GHC.Located t)
addDeclToksAfterSrcSpan forest oldSpan pos toks t = (forest'',newSpan,t')
where
(forest',newSpan) = addToksAfterSrcSpan forest oldSpan pos toks
(t',forest'') = syncAST t newSpan forest'
reIndentToks :: Positioning -> [PosToken] -> [PosToken] -> [PosToken]
reIndentToks _ _ [] = []
reIndentToks pos prevToks toks = toks''
where
newTokStart = ghead "reIndentToks.1"
$ dropWhile (\tok -> isComment tok || isEmpty tok) $ toks
firstTok = ghead "reIndentToks.2" toks
lastTok = glast "reIndentToks.1" prevToks
lastNonCommentTok = ghead "reIndentToks.3"
$ dropWhile (\tok -> isComment tok || isEmpty tok) $ reverse prevToks
prevOffset = getIndentOffset prevToks (tokenPos (glast "reIndentToks.2" prevToks))
(lastTokEndLine,_) = tokenPosEnd lastTok
(lineOffset,colOffset,endNewlines) = case pos of
PlaceAdjacent -> (lineOffset',colOffset',0)
where
colStart = (tokenColEnd (lastTok)) + 1
lineStart = (tokenRow (lastTok))
lineOffset' = lineStart (tokenRow firstTok)
colOffset' = colStart (tokenCol newTokStart)
PlaceAbsolute row col -> (lineOffset', colOffset', 0)
where
lineOffset' = row (tokenRow firstTok)
colOffset' = col (tokenCol firstTok)
PlaceAbsCol rowIndent col numLines -> (lineOffset', colOffset', numLines)
where
colOffset' = col (tokenCol firstTok)
lineStart = (tokenRow (lastTok))
lineOffset' = rowIndent + lineStart (tokenRow firstTok)
PlaceOffset rowIndent colIndent numLines -> (lineOffset',colOffset',numLines)
where
colStart = tokenCol $ ghead "reIndentToks.4"
$ dropWhile isWhiteSpaceOrIgnored prevToks
lineStart = (tokenRow (lastTok))
lineOffset' = rowIndent + lineStart (tokenRow firstTok)
colOffset' = colIndent + colStart (tokenCol newTokStart)
PlaceIndent rowIndent colIndent numLines -> (lineOffset',colOffset',numLines)
where
colStart = prevOffset
lineStart = if ((isComment lastTok) && (tokenRow lastNonCommentTok /= lastTokEndLine))
then (tokenRow (lastTok)) + 1
else (tokenRow (lastTok))
lineOffset' = rowIndent + lineStart (tokenRow firstTok)
colOffset' = colIndent + colStart (tokenCol newTokStart) + 1
toks' = addOffsetToToks (lineOffset,colOffset) toks
toks'' = if endNewlines > 0
then toks' ++ [(newLinesToken (endNewlines 1) $ glast "reIndentToks.3" toks')]
else toks'
nonCommentSpan :: [PosToken] -> (SimpPos,SimpPos)
nonCommentSpan [] = ((0,0),(0,0))
nonCommentSpan toks = (startPos,endPos)
where
stripped = dropWhile isIgnoredNonComment $ toks
(startPos,endPos) = case stripped of
[] -> ((0,0),(0,0))
_ -> (tokenPos startTok,tokenPosEnd endTok)
where
startTok = ghead "nonCommentSpan.1" $ dropWhile isIgnoredNonComment $ toks
endTok = ghead "nonCommentSpan.2" $ dropWhile isIgnoredNonComment $ reverse toks
posToSrcSpan :: Tree Entry -> (SimpPos,SimpPos) -> GHC.SrcSpan
posToSrcSpan forest ((rs,cs),(re,ce)) = sspan
where
(GHC.L l _,_) = ghead "posToSrcSpan" $ retrieveTokensInterim forest
sspan = case l of
GHC.RealSrcSpan ss ->
let
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) rs cs
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) re ce
in
GHC.mkSrcSpan locStart locEnd
_ -> error "posToSrcSpan: invalid SrcSpan in first tok"
posToSrcSpanTok :: PosToken -> (SimpPos,SimpPos) -> GHC.SrcSpan
posToSrcSpanTok tok ((rs,cs),(re,ce)) = sspan
where
(GHC.L l _,_) = tok
sspan = case l of
GHC.RealSrcSpan ss ->
let
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) rs cs
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) re ce
in
GHC.mkSrcSpan locStart locEnd
_ -> error "posToSrcSpan: invalid SrcSpan in first tok"
insertNodeAfter
:: Tree Entry -> Tree Entry -> Tree Entry -> Tree Entry
insertNodeAfter oldNode newNode forest = forest'
where
zf = openZipperToNodeDeep oldNode $ Z.fromTree forest
zp = gfromJust ("insertNodeAfter:" ++ (show (oldNode,newNode,forest))) $ Z.parent zf
tp = Z.tree zp
(f,s) = break (\t -> treeStartEnd t == treeStartEnd oldNode) $ subForest tp
(f',s') = (f++[ghead "insertNodeAfter" s],tail s)
subForest' = f' ++ [newNode] ++ s'
tp' = tp { subForest = subForest' }
forest' = Z.toTree $ Z.setTree tp' zp
openZipperToNode
:: Tree Entry
-> Z.TreePos Z.Full Entry
-> Z.TreePos Z.Full Entry
openZipperToNode (Node (Entry sspan _ _) _) z
= openZipperToSpan sspan z
openZipperToNode (Node (Deleted sspan _ _) _) z
= openZipperToSpan sspan z
openZipperToNodeDeep
:: Tree Entry
-> Z.TreePos Z.Full Entry
-> Z.TreePos Z.Full Entry
openZipperToNodeDeep (Node (Entry sspan _ _) _) z
= openZipperToSpanDeep sspan z
openZipperToNodeDeep (Node (Deleted sspan _ _) _) z
= openZipperToSpanDeep sspan z
getChildrenAsZ :: Z.TreePos Z.Full a -> [Z.TreePos Z.Full a]
getChildrenAsZ z = go [] (Z.firstChild z)
where
go acc Nothing = acc
go acc (Just zz) = go (acc ++ [zz]) (Z.next zz)
spanContains :: ForestSpan -> ForestSpan -> Bool
spanContains span1 span2 = (startPos <= nodeStart && endPos >= nodeEnd)
where
(tvs,_tve) = forestSpanVersions $ span1
(nvs,_nve) = forestSpanVersions $ span2
(startPos,endPos) = insertVersionsInForestSpan tvs tvs span1
(nodeStart,nodeEnd) = insertVersionsInForestSpan nvs nvs span2
openZipperToSpan
:: ForestSpan
-> Z.TreePos Z.Full Entry
-> Z.TreePos Z.Full Entry
openZipperToSpan sspan z
| hasVersions = openZipperToSpanAdded sspan z
| otherwise = openZipperToSpanOrig sspan z
where
(vs,_ve) = forestSpanVersions sspan
hasVersions = vs /= 0
openZipperToSpanOrig
:: ForestSpan
-> Z.TreePos Z.Full Entry
-> Z.TreePos Z.Full Entry
openZipperToSpanOrig sspan z
= if (treeStartEnd (Z.tree z) == sspan) || (Z.isLeaf z)
then z
else z'
where
childrenAsZ = getChildrenAsZ z
z' = case (filter contains childrenAsZ) of
[] -> z
[x] ->
openZipperToSpan sspan x
xx -> case (filter (\zt -> (treeStartEnd $ Z.tree zt) == sspan) xx) of
[] ->
case (filter (not .forestSpanLenChanged . treeStartEnd . Z.tree) xx) of
[] -> z
[w] -> openZipperToSpan sspan w
ww ->
case (filter (\zt -> matchVersions sspan zt) ww) of
[v] -> openZipperToSpan sspan v
_ -> error $ "openZipperToSpan:can't resolve:(sspan,ww)="++(show (sspan,map (\zt -> treeStartEnd $ Z.tree zt) ww))
[y] -> openZipperToSpan sspan y
yy ->
case (filter (\zt -> (fst $ forestSpanVersions $ treeStartEnd $ Z.tree zt) == (fst $ forestSpanVersions sspan)) xx) of
[] -> error $ "openZipperToSpan:no version match:(sspan,yy)=" ++ (show (sspan,yy))
[w] -> openZipperToSpan sspan w
_ww -> error $ "openZipperToSpan:multiple version match:" ++ (show (sspan,yy))
contains zn = spanContains (treeStartEnd $ Z.tree zn) sspan
matchVersions span1 z2 = isMatch
where
span2 = treeStartEnd $ Z.tree z2
isMatch = forestSpanVersions span1 == forestSpanVersions span2
openZipperToSpanDeep
:: ForestSpan
-> Z.TreePos Z.Full Entry
-> Z.TreePos Z.Full Entry
openZipperToSpanDeep sspan z = zf
where
z' = openZipperToSpan sspan z
zf = case Z.tree z' of
(Node (Entry _ (Above _ _ _ _) _) _) ->
case getChildrenAsZ z' of
[] -> z'
[x] -> if (treeStartEnd (Z.tree x) == sspan) then x else z'
_ -> z'
_ -> z'
openZipperToSpanAdded
:: ForestSpan
-> Z.TreePos Z.Full Entry
-> Z.TreePos Z.Full Entry
openZipperToSpanAdded sspan z = zf
where
treeAsList = getTreeSpansAsList $ Z.tree z
myMatch (((ForestLine _ _ vs1 rs1),cs1),((ForestLine _ _ ve1 re1),ce1))
(((ForestLine _ _ vs2 rs2),cs2),((ForestLine _ _ ve2 re2),ce2))
= vs1 == vs2 && ve1 == ve2 && ((rs1,cs1) <= (rs2,cs2)) && ((re1,ce1) >= (re2,ce2))
tl2 = dropWhile (\(_,s) -> not (myMatch s sspan)) $ reverse treeAsList
fff acc@((cd,_cs):_) (v,sspan') = if v < cd then (v,sspan'):acc
else acc
tl3 = foldl' fff [(head tl2)] tl2
zf = foldl' (flip openZipperToSpanOrig) z $ map snd tl3
getTreeSpansAsList :: Tree Entry -> [(Int,ForestSpan)]
getTreeSpansAsList = getTreeSpansAsList' 0
getTreeSpansAsList' :: Int -> Tree Entry -> [(Int,ForestSpan)]
getTreeSpansAsList' level (Node (Deleted sspan _pg _eg ) _ ) = [(level,sspan)]
getTreeSpansAsList' level (Node (Entry sspan _lay _toks) ts0) = (level,sspan)
: (concatMap (getTreeSpansAsList' (level + 1)) ts0)
splitForestOnSpan :: Forest Entry -> ForestSpan
-> ([Tree Entry],[Tree Entry],[Tree Entry])
splitForestOnSpan forest sspan = (beginTrees,middleTrees,endTrees)
where
(spanStart,spanEnd) = sspan
(beginTrees,rest) = break (\t -> not $ inBeginTrees t) forest
(middleTrees,endTrees) = break (\t -> inEndTrees t) rest
inBeginTrees tree = spanStart >= treeEnd
where
(_treeStart,treeEnd) = treeStartEnd tree
inEndTrees tree = spanEnd <= treeStart
where
(treeStart,_treeEnd) = treeStartEnd tree
invariantOk :: Tree Entry -> Bool
invariantOk forest = ok
where
inv = invariant forest
ok = case inv of
[] -> True
_ -> error $ "Token Tree invariant fails:" ++ (intercalate "\n" inv)
invariant :: Tree Entry -> [String]
invariant forest = rsub
where
rsub = F.foldl checkOneTree [] [forest]
checkOneTree :: [String] -> Tree Entry -> [String]
checkOneTree acc tree = acc ++ r
where
r = checkNode [] tree
checkNode :: [String] -> Tree Entry -> [String]
checkNode _acc (Node (Deleted _sspan _ _) []) = []
checkNode _acc node@(Node (Deleted _sspan _ _) _sub)
= ["FAIL: deleted node with subtree: " ++ (prettyshow node)]
checkNode acc node@(Node (Entry sspan _lay toks) sub) = acc ++ r ++ rinc ++ rsubs ++ rnull
where
r = if ( emptyList toks && nonEmptyList sub) ||
(nonEmptyList toks && emptyList sub)
then []
else ["FAIL: exactly one of toks or subforest must be empty: " ++ (prettyshow node)]
rsubs = foldl' checkNode [] sub
rinc = checkInclusion node
rnull = if (sspan == nullSpan)
then ["FAIL: null SrcSpan in tree: " ++ (prettyshow node)]
else []
checkInclusion (Node _ []) = []
checkInclusion (Node (Deleted _ _ _) _) = []
checkInclusion node@(Node (Entry _sspan _lay _toks) sub) = rs ++ rseq
where
(start,end) = treeStartEnd node
subs = map treeStartEnd sub
(sstart, _) = ghead "invariant" subs
(_, send) = last subs
rs = if ((start <= sstart) &&
((end >= send) || (forestPosVersionSet send) || (forestPosAstVersionSet send)))
|| (forestPosLenChanged start)
|| (forestPosLenChanged sstart)
|| (forestPosLenChanged send)
then []
else ["FAIL: subForest start and end does not match entry: " ++ (prettyshow node)]
rseq = checkSequence node subs
checkSequence :: Tree Entry -> [ForestSpan] -> [String]
checkSequence _ [] = []
checkSequence _ [_x] = []
checkSequence node' ((_s1,e1):s@(s2,_e2):ss)
= r ++ checkSequence node' (s:ss)
where
r = if (before e1 s2) || (sizeChanged e1) || (sizeChanged s2)
then []
else ["FAIL: subForest not in order: " ++
show e1 ++ " not < " ++ show s2 ++
":" ++ prettyshow node']
before (ForestLine _chs _trs ve er,ec) (ForestLine _che _tre vs sr,sc)
= case (ve /= 0, vs /= 0) of
(False, False) -> (er,ec) <= (sr,sc)
(False, True) -> True
(True, False) -> True
(True, True) -> if vs < ve
then False
else True
sizeChanged (ForestLine ch _ _ _,_) = ch
treeStartEnd :: Tree Entry -> ForestSpan
treeStartEnd (Node (Entry sspan _ _) _) = sspan
treeStartEnd (Node (Deleted sspan _ _) _) = sspan
spanStartEnd :: GHC.SrcSpan -> ForestSpan
spanStartEnd sspan = ((ghcLineToForestLine sr,sc),(ghcLineToForestLine er,ec))
where
((sr,sc),(er,ec)) = (getGhcLoc sspan,getGhcLocEnd sspan)
showForest :: [Tree Entry] -> [String]
showForest forest = map showTree forest
drawTokenCache :: TokenCache -> String
drawTokenCache tk = Map.foldlWithKey' doOne "" (tkCache tk)
where
doOne :: String -> TreeId -> Tree Entry -> String
doOne s key val = s ++ "tree " ++ (show key) ++ ":\n"
++ (drawTreeEntry val)
drawTokenCacheDetailed :: TokenCache -> String
drawTokenCacheDetailed tk = Map.foldlWithKey' doOne "" (tkCache tk)
where
doOne :: String -> TreeId -> Tree Entry -> String
doOne s key val = s ++ "tree " ++ (show key) ++ ":\n"
++ (show val)
drawTreeEntry :: Tree Entry -> String
drawTreeEntry = unlines . drawEntry
drawForestEntry :: Forest Entry -> String
drawForestEntry = unlines . map drawTreeEntry
drawEntry :: Tree Entry -> [String]
drawEntry (Node (Deleted sspan pg eg ) _ ) = [(showForestSpan sspan) ++ (show eg) ++ "D"]
drawEntry (Node (Entry sspan lay _toks) ts0) = ((showForestSpan sspan) ++ (showLayout lay)): drawSubTrees ts0
where
drawSubTrees [] = []
drawSubTrees [t] =
"|" : shft "`- " " " (drawEntry t)
drawSubTrees (t:ts) =
"|" : shft "+- " "| " (drawEntry t) ++ drawSubTrees ts
shft first other = zipWith (++) (first : repeat other)
showLayout :: Layout -> String
showLayout NoChange = ""
showLayout (Above so p1 (r,c) eo) = "(Above "++ show so ++ " " ++ show p1 ++ " " ++ show (r,c) ++ " " ++ show eo ++ ")"
drawTreeCompact :: Tree Entry -> String
drawTreeCompact = unlines . drawTreeCompact' 0
drawTreeCompact' :: Int -> Tree Entry -> [String]
drawTreeCompact' level (Node (Deleted sspan pg eg ) _ ) = [(show level) ++ ":" ++ (showForestSpan sspan) ++ (show eg) ++ "D"]
drawTreeCompact' level (Node (Entry sspan lay _toks) ts0) = ((show level) ++ ":" ++ (showForestSpan sspan) ++ (showLayout lay))
: (concatMap (drawTreeCompact' (level + 1)) ts0)
showTree :: Tree Entry -> String
showTree = prettyshow
prettyshow :: Tree Entry -> String
prettyshow (Node (Deleted sspan pg eg) _nullSubs)
= "Node (Deleted " ++ (showForestSpan sspan) ++ " " ++ (show eg) ++ ")"
prettyshow (Node (Entry sspan _lay toks) sub)
= "Node (Entry " ++ (showForestSpan sspan) ++ " "
++ (prettyToks toks) ++ ") "
++ "[" ++ intercalate "," (map prettyshow sub) ++ "]"
prettyToks :: [PosToken] -> String
prettyToks [] = "[]"
prettyToks toks@[_x] = showToks toks
prettyToks toks@[_t1,_t2] = showToks toks
prettyToks toks = showToks [ghead "prettyToks" toks] ++ ".." ++ showToks [last toks]
mkTreeFromTokens :: [PosToken] -> Tree Entry
mkTreeFromTokens [] = Node (Entry nullSpan NoChange []) []
mkTreeFromTokens toks = Node (Entry sspan NoChange toks) []
where
(startLoc',endLoc') = nonCommentSpan toks
sspan = if (startLoc',endLoc') == ((0,0),(0,0))
then error $ "mkTreeFromTokens:null span for:" ++ (show toks)
else simpPosToForestSpan (startLoc',endLoc')
mkTreeFromSpanTokens :: ForestSpan -> [PosToken] -> Tree Entry
mkTreeFromSpanTokens sspan toks = Node (Entry sspan NoChange toks) []
ghcSpanStartEnd :: GHC.SrcSpan -> ((Int, Int), (Int, Int))
ghcSpanStartEnd sspan = (getGhcLoc sspan,getGhcLocEnd sspan)
syncAST :: (SYB.Data t)
=> GHC.Located t
-> GHC.SrcSpan
-> Tree Entry
-> (GHC.Located t, Tree Entry)
syncAST ast@(GHC.L l _t) sspan forest = (GHC.L sspan xx,forest')
where
forest' = forest
(( sr, sc),( _er, _ec)) = ghcSpanStartEnd l
((nsr,nsc),(_ner,_nec)) = ghcSpanStartEnd sspan
rowOffset = nsr sr
colOffset = nsc sc
syncSpan s = addOffsetToSpan (rowOffset,colOffset) s
(GHC.L _s xx) = everywhereStaged SYB.Renamer (
SYB.mkT hsbindlr
`SYB.extT` sig
`SYB.extT` ty
`SYB.extT` name
`SYB.extT` lhsexpr
`SYB.extT` lpat
`SYB.extT` limportdecl
`SYB.extT` lmatch
) ast
hsbindlr (GHC.L s b) = (GHC.L (syncSpan s) b) :: GHC.Located (GHC.HsBindLR GHC.Name GHC.Name)
sig (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.LSig GHC.Name
ty (GHC.L s typ) = (GHC.L (syncSpan s) typ) :: (GHC.LHsType GHC.Name)
name (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.Located GHC.Name
lhsexpr (GHC.L s e) = (GHC.L (syncSpan s) e) :: GHC.LHsExpr GHC.Name
lpat (GHC.L s p) = (GHC.L (syncSpan s) p) :: GHC.LPat GHC.Name
limportdecl (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.LImportDecl GHC.Name
lmatch (GHC.L s m) = (GHC.L (syncSpan s) m) :: GHC.LMatch GHC.Name
indentDeclToks :: (SYB.Data t)
=> GHC.Located t
-> Tree Entry
-> Int
-> (GHC.Located t, Tree Entry)
indentDeclToks decl@(GHC.L sspan _) forest offset = (decl',forest'')
where
(forest',tree) = getSrcSpanFor forest (srcSpanToForestSpan sspan)
z = openZipperToSpan (srcSpanToForestSpan sspan) $ Z.fromTree forest'
tree' = go tree
markLenChanged (Node entry subs) = (Node entry' subs)
where
sss = forestSpanFromEntry entry
sss' = insertLenChangedInForestSpan True sss
entry' = putForestSpanInEntry entry sss'
z' = Z.setTree tree' z
forest'' = case Z.parent z' of
Nothing -> Z.toTree (Z.setTree (markLenChanged $ Z.tree z' ) z' )
Just z'' -> Z.toTree (Z.setTree (markLenChanged $ Z.tree z'') z'')
(decl',_) = syncAST decl (addOffsetToSpan off sspan) tree
off = (0,offset)
go (Node (Deleted ss pg eg) sub) = (Node (Deleted (addOffsetToForestSpan off ss) pg eg) sub)
go (Node (Entry ss lay []) sub) = (Node (Entry (addOffsetToForestSpan off ss) lay []) (map go sub))
go (Node (Entry ss lay toks) []) = (Node (Entry (addOffsetToForestSpan off ss) lay (addOffsetToToks off toks)) [])
go n = error $ "indentDeclToks:strange node:" ++ (show n)
addOffsetToForestSpan :: (Int,Int) -> ForestSpan -> ForestSpan
addOffsetToForestSpan (lineOffset,colOffset) fspan = fspan'
where
((ForestLine sch str sv sl,sc),(ForestLine ech etr ev el,ec)) = fspan
fspan' = ((ForestLine sch str sv (sl+lineOffset),sc+colOffset),
(ForestLine ech etr ev (el+lineOffset),ec+colOffset))
addOffsetToSpan :: (Int,Int) -> GHC.SrcSpan -> GHC.SrcSpan
addOffsetToSpan (lineOffset,colOffset) sspan = sspan'
where
sspan' = case sspan of
GHC.RealSrcSpan ss ->
let
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) (lineOffset + GHC.srcSpanStartLine ss) (colOffset + GHC.srcSpanStartCol ss)
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) (lineOffset + GHC.srcSpanEndLine ss) (colOffset + GHC.srcSpanEndCol ss)
in
GHC.mkSrcSpan locStart locEnd
_ -> sspan
showSrcSpan :: GHC.SrcSpan -> String
showSrcSpan sspan = show (getGhcLoc sspan, (r,c))
where
(r,c) = getGhcLocEnd sspan
showSrcSpanF :: GHC.SrcSpan -> String
showSrcSpanF sspan = show (((chs,trs,vs,ls),cs),((che,tre,ve,le),ce))
where
((ForestLine chs trs vs ls,cs),(ForestLine che tre ve le,ce)) = srcSpanToForestSpan sspan
sf :: GHC.SrcSpan -> ForestSpan
sf = srcSpanToForestSpan
fs :: ForestSpan -> GHC.SrcSpan
fs = forestSpanToSrcSpan
combineSpans :: ForestSpan -> ForestSpan -> ForestSpan
combineSpans fs1 fs2 = fs'
where
[lowFs,highFs] = sort [fs1,fs2]
((ForestLine chls trls vls lls ,cls),(ForestLine _chle _trle _vle _lle,_cle)) = lowFs
((ForestLine _chhs _trhs _vhs _lhs,_chs),(ForestLine chhe trhe vhe lhe, che)) = highFs
fs' = ((ForestLine chls trls vls lls,cls),(ForestLine chhe trhe vhe lhe,che))