haskell-token-utils-0.0.0.4: src/Language/Haskell/TokenUtils/TokenUtils.hs
module Language.Haskell.TokenUtils.TokenUtils
(
-- * Creating
initTokenCacheLayout
, mkTreeFromTokens
, mkTreeFromSpanTokens
-- * Module type
, Positioning (..)
, ReversedToks(..)
-- * High level functions for use by clients, at TokenCache level
, putToksInCache
, replaceTokenInCache
, removeToksFromCache
, getTokensFromCache
, getTokensNoIntrosFromCache
, getTokensBeforeFromCache
, addTokensAfterSpanInCache
-- * High level functions for use by clients, at LayoutTree level
-- * Operations at 'LayoutTree' level
, updateTokensForSrcSpan
, replaceTokenForSrcSpan
, getSrcSpanFor
, indentDeclToks
, addToksAfterSrcSpan
, addOffsetToSpan
, reIndentToks
-- * Working with tokens
, basicTokenise
, tokenise
-- *
, invariant
, reverseToks
, unReverseToks
, reversedToks
, retrieveTokensInterim
, getTokensForNoIntros -- could be no longer required
, getTokensFor -- no invariant
, getTokensBefore
-- , retrieveTokensFinal
, reAlignMarked
-- *
, splitOnNewLn
, getIndentOffset
, newLnToken
, startEndLocIncComments'
, forestSpanToGhcPos
-- *
, nullForestSpan
, nullForestPos
-- * should be in utils
, simpPosToForestSpan
-- *
, showTree
, showToks
-- * Exposed for testing only
, addNewSrcSpanAndToksAfter
, openZipperToSpan
, openZipperToSpanAdded
, retrievePrevLineToks
, limitPrevToks
, insertSrcSpan
, insertLenChangedInSrcSpan
, insertVersionsInSrcSpan
, removeSrcSpan
, containsStart
, containsMiddle
, containsEnd
, splitSubtree
-- , splitForestOnSpan
, insertNodeAfter
, splitSubToks
, placeToksForSpan
, reAlignOneLine
, calcEndGap
, getTreeSpansAsList
, openZipperToSpanOrig
, replaceTokNoReAlign
-- * exported for historical tests only
, initTokenCache
, getTreeFromCache
, replaceTreeInCache
, matchTokenPos
) where
import Control.Exception
import Data.Bits
import Data.List
import Data.Tree
import Language.Haskell.TokenUtils.Types
import Language.Haskell.TokenUtils.Utils
import qualified Data.Foldable as F
import qualified Data.Map as Map
import qualified Data.Tree.Zipper as Z
-- =====================================================================
-- TokenCache operations
{-# DEPRECATED initTokenCache "residual from tests" #-}
-- |Initialise a `TokenCache` from tokens only. Does not generate a
-- layout-aware tree due to missing AST
initTokenCache :: (IsToken a) => [a] -> TokenCache a
initTokenCache toks = TK (Map.fromList [((TId 0),(mkTreeFromTokens toks))]) (TId 0)
-- ---------------------------------------------------------------------
-- |The primary data structure is the 'TokenCache'. This holds the
-- evolving forest of modified 'LayoutTree's. Each concrete
-- implementation should provide a function to generate a 'LayoutTree'
-- from its specific AST and tokens.
initTokenCacheLayout :: (IsToken a) => Tree (Entry a) -> TokenCache a
initTokenCacheLayout tree = TK (Map.fromList [((TId 0),tree)]) (TId 0)
-- ---------------------------------------------------------------------
putToksInCache :: (IsToken a) => TokenCache a -> SimpSpan -> [a] -> (TokenCache a,SimpSpan)
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
-- ---------------------------------------------------------------------
replaceTokenInCache :: (IsToken a) => TokenCache a -> SimpSpan -> a -> TokenCache a
replaceTokenInCache tk sspan tok = tk'
where
forest = getTreeFromCache sspan tk
forest' = replaceTokenForSrcSpan forest sspan tok
tk' = replaceTreeInCache sspan forest' tk
-- ---------------------------------------------------------------------
removeToksFromCache :: (IsToken a) => TokenCache a -> SimpSpan -> TokenCache a
removeToksFromCache tk sspan = tk''
where
forest = getTreeFromCache sspan tk
(forest',oldTree) = removeSrcSpan forest (ss2f sspan)
tk' = replaceTreeInCache sspan forest' tk
tk'' = stash tk' oldTree
-- ---------------------------------------------------------------------
getTokensFromCache :: (IsToken a) => Bool -> TokenCache a -> SimpSpan -> (TokenCache a,[a])
getTokensFromCache checkInvariant tk sspan = (tk',tokens)
where
forest = getTreeFromCache sspan tk
(forest',tokens) = getTokensFor checkInvariant forest sspan
tk' = replaceTreeInCache sspan forest' tk
-- ---------------------------------------------------------------------
getTokensNoIntrosFromCache :: (IsToken a) => Bool -> TokenCache a -> SimpSpan -> (TokenCache a,[a])
getTokensNoIntrosFromCache checkInvariant tk sspan = (tk',tokens)
where
forest = getTreeFromCache sspan tk
(forest',tokens) = getTokensForNoIntros checkInvariant forest sspan
tk' = replaceTreeInCache sspan forest' tk
-- ---------------------------------------------------------------------
getTokensBeforeFromCache :: (IsToken a) => TokenCache a -> SimpSpan -> (TokenCache a,ReversedToks a)
getTokensBeforeFromCache tk sspan = (tk',tokens)
where
forest = getTreeFromCache sspan tk
(forest',tokens) = getTokensBefore forest sspan
tk' = replaceTreeInCache sspan forest' tk
-- ---------------------------------------------------------------------
addTokensAfterSpanInCache :: (IsToken a)
=> TokenCache a
-> SimpSpan -- ^Preceding location for new tokens
-> Positioning
-> [a] -- ^New tokens to be added
-> (TokenCache a, SimpSpan) -- ^ updated TokenCache and SrcSpan location for
-- the new tokens in the TokenTree
addTokensAfterSpanInCache tk oldSpan pos toks = (tk',newSpan)
where
forest = getTreeFromCache oldSpan tk
(forest',newSpan) = addToksAfterSrcSpan forest oldSpan pos toks
tk' = replaceTreeInCache oldSpan forest' tk
-- =====================================================================
-- LayoutTree operations
-- =====================================================================
-- ---------------------------------------------------------------------
-- |Keep track of when tokens are reversed, to avoid confusion
data ReversedToks a = RT [a]
deriving (Show)
reverseToks :: (IsToken a) => [a] -> ReversedToks a
reverseToks toks = RT $ reverse toks
unReverseToks :: (IsToken a) => ReversedToks a -> [a]
unReverseToks (RT toks) = reverse toks
reversedToks :: (IsToken a) => ReversedToks a -> [a]
reversedToks (RT toks) = toks
-- |How new SrcSpans should be inserted in the Token tree, relative to
-- the prior span
data Positioning = PlaceAdjacent -- ^Only a single space between the
-- end of the prior span and the new one
| PlaceAbsolute !Int !Int -- ^Start at the specified
-- line and col
| PlaceAbsCol !Int !Int !Int -- ^Line offset and
-- absolute Col. Mainly
-- for forcing start at
-- left margin, number
-- of lines to add at
-- the end
| PlaceOffset !Int !Int !Int -- ^Line and Col offset for
-- start, num lines to add at the end
-- relative to the indent level of the prior span
| PlaceIndent !Int !Int !Int -- ^Line and Col offset for
-- start, num lines to add at the end
-- relative to the indent level of the prior line
deriving (Show)
-- ---------------------------------------------------------------------
-- |Make a tree representing a particular set of tokens
mkTreeFromTokens :: (IsToken a) => [a] -> Tree (Entry a)
mkTreeFromTokens [] = Node (Entry nullForestSpan 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')
-- ---------------------------------------------------------------------
-- |Make a tree representing a particular set of tokens
mkTreeFromSpanTokens :: (IsToken a) => ForestSpan -> [a] -> Tree (Entry a)
mkTreeFromSpanTokens sspan toks = Node (Entry sspan NoChange toks) []
-- ---------------------------------------------------------------------
forestSpanStart :: ForestSpan -> ForestPos
forestSpanStart (start,_) = start
forestSpanEnd :: ForestSpan -> ForestPos
forestSpanEnd (_,end) = end
nullForestSpan :: ForestSpan
nullForestSpan = (nullForestPos,nullForestPos)
nullForestPos :: ForestPos
nullForestPos = (ForestLine False 0 0 0,0)
-- ---------------------------------------------------------------------
{-
simpPosToForestSpan :: (SimpPos,SimpPos) -> ForestSpan
simpPosToForestSpan ((sr,sc),(er,ec))
= ((ghcLineToForestLine sr,sc),(ghcLineToForestLine er,ec))
-}
-- ---------------------------------------------------------------------
-- |Utility function to either return True or throw an error to report the problem
invariantOk :: (IsToken a) => Tree (Entry a) -> Bool
invariantOk forest = ok
where
inv = invariant forest
ok = case inv of
[] -> True
_ -> error $ "Token Tree invariant fails:" ++ (intercalate "\n" inv)
-- ---------------------------------------------------------------------
-- |Check the invariant for the token cache. Returns list of any errors found.
-- Invariants:
-- 1. For each tree, either the rootLabel has a SrcSpan only, or the subForest /= [].
-- 2a. The trees making up the subForest of a given node fully include the parent SrcSpan.
-- i.e. the leaves contain all the tokens for a given SrcSpan.
-- 2b. The subForest is in SrcSpan order
-- 3. A given SrcSpan can only appear (or be included) in a single tree of the forest.
-- 4. The parent link for all sub-trees does exist, and actually points to the parent.
-- 5. There are no nullForestSpan entries in the tree
-- NOTE: the tokens may extend before or after the SrcSpan, due to comments only
-- NOTE2: this will have to be revisited when edits to the tokens are made
invariant :: (IsToken a) => Tree (Entry a) -> [String]
invariant forest = rsub
where
rsub = F.foldl checkOneTree [] [forest]
checkOneTree :: (IsToken a) => [String] -> Tree (Entry a) -> [String]
checkOneTree acc tree = acc ++ r
where
r = checkNode [] tree
checkNode :: (IsToken a) => [String] -> Tree (Entry a) -> [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 ( null toks && not (null sub)) ||
(not (null toks) && null 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 == nullForestSpan)
then ["FAIL: null SrcSpan in tree: " ++ (prettyshow node)]
else []
-- |Check invariant 2, assuming 1 ok
-- NOTE: check that the subtree spans do not go outside the node
-- span, they do not need to completely fill it, because some may
-- have been removed during manipulation
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
-- Do not count any custom added srcspans at the end for this
-- test
-- TODO: is this a reasonable approach?
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)]
-- else ["FAIL: subForest start and end does not match entry: " ++ (show node)]
rseq = checkSequence node subs
checkSequence :: (IsToken a) => Tree (Entry a) -> [ForestSpan] -> [String]
checkSequence _ [] = []
checkSequence _ [_x] = []
checkSequence node' ((_s1,e1):s@(s2,_e2):ss)
= r ++ checkSequence node' (s:ss)
where
-- r = if e1 <= s2
r = if (before e1 s2) || (sizeChanged e1) {- ++AZ++ -} || (sizeChanged s2)
then []
else ["FAIL: subForest not in order: " ++
show e1 ++ " not < " ++ show s2 ++
":" ++ prettyshow node']
-- |Compare end of one span with beginning of another
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) -- e.g. (10,3) <= (11,5)
(False, True) -> True -- e.g. (10,3) <= (100011,5)
(True, False) -> True -- e.g. (100010,3) <= (11,5)
(True, True) -> if vs < ve -- both have version, lowest wins
then False
else True
sizeChanged (ForestLine ch _ _ _,_) = ch
{-
cs ce
True _ -> True
False _ -> before
-}
-- ---------------------------------------------------------------------
showTree :: (IsToken a) => Tree (Entry a) -> String
showTree = prettyshow
-- |Represent a tree in a more concise/pretty way
prettyshow :: (IsToken a) => Tree (Entry a) -> 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) ++ ") "
-- ++ show (map prettyshow sub)
++ "[" ++ intercalate "," (map prettyshow sub) ++ "]"
prettyToks :: (IsToken a) => [a] -> String
prettyToks [] = "[]"
prettyToks toks@[_x] = showToks toks
prettyToks toks@[_t1,_t2] = showToks toks
prettyToks toks = showToks [ghead "prettyToks" toks] ++ ".." ++ showToks [last toks]
showToks :: (IsToken a) => [a] -> String
showToks toks = show $ map doOne toks
where
doOne tok = (s,e,tokenToString tok)
where (s,e) = getSpan tok
-- ---------------------------------------------------------------------
getTreeFromCache :: (IsToken a) => SimpSpan -> TokenCache a -> Tree (Entry a)
getTreeFromCache sspan tk = (tkCache tk) Map.! tid
where
tid = treeIdFromForestSpan $ ss2f sspan
-- ---------------------------------------------------------------------
replaceTreeInCache :: (IsToken a) => SimpSpan -> Tree (Entry a) -> TokenCache a -> TokenCache a
replaceTreeInCache sspan tree tk = tk'
where
tid = treeIdFromForestSpan $ ss2f sspan
tree' = putTidInTree tid tree
tk' = tk {tkCache = Map.insert tid tree' (tkCache tk) }
-- ---------------------------------------------------------------------
-- TODO: get rid of one of the following 2, it is a duplicate
putTidInTree :: (IsToken a) => TreeId -> Tree (Entry a) -> Tree (Entry a)
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'
treeIdIntoTree :: (IsToken a) => TreeId -> Tree (Entry a) -> Tree (Entry a)
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 :: (IsToken a) => TokenCache a -> Tree (Entry a) -> TokenCache a
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' }
-- ---------------------------------------------------------------------
-- |Replace a single token in a token tree, without changing the
-- structure of the tree
-- NOTE: the GHC.SrcSpan may have been used to select the appropriate
-- forest in the first place, and is required to select the correct
-- span in the tree, due to the ForestLine annotations that may be present
-- TODO: work at the token level, not the sspan level
-- TODO: Use start of token span only, with length 1.
replaceTokenForSrcSpan :: (IsToken a) => Tree (Entry a) -> SimpSpan -> a -> Tree (Entry a)
replaceTokenForSrcSpan forest sspan tok = forest'
where
-- (GHC.L tl _,_) = tok
tl = getSpan tok
-- First open to the sspan, making use of any Forestline annotations
z = openZipperToSpanDeep (ss2f sspan) $ Z.fromTree forest
-- Then drill down to the specific subtree containing the token
-- z' = openZipperToSpan (srcSpanToForestSpan tl) z
z' = z -- No, pass in original token span as sspan.
-- Note: with LayoutTree, the full tree matching the AST has been
-- built, still need to drill down to the nearest enclosing span
(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 $ ss2f sspan) ++ " expecting tokens, found: " ++ (show $ Z.tree z')
(Node (Deleted _ _ _) _sub) -> error $ "replaceTokenForSrcSpan:tok pos" ++ (showForestSpan $ ss2f sspan) ++ " expecting Entry, found: " ++ (show $ Z.tree z')
((row,col),_) = tl
toks' = replaceTokNoReAlign toks (row,col) tok
zf = Z.setTree (Node (Entry tspan lay toks') []) z'
forest' = Z.toTree zf
-- ---------------------------------------------------------------------
-- | Removes a ForestSpan and its tokens from the forest.
removeSrcSpan :: (IsToken a) => Tree (Entry a) -> ForestSpan
-> (Tree (Entry a),Tree (Entry a)) -- ^Updated forest, removed span
removeSrcSpan forest sspan = (forest'', delTree)
where
forest' = insertSrcSpan forest sspan -- Make sure span is actually
-- in the tree
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
-- forest'' = error $ "removeSrcSpan: forest'=" ++ drawTreeCompact forest'
-- ---------------------------------------------------------------------
-- |Add a new SrcSpan and Tokens after a given one in the token stream
-- and forest. This will be given a unique SrcSpan in return, which
-- specifically indexes into the forest.
addNewSrcSpanAndToksAfter :: (IsToken a)
=> Tree (Entry a) -- ^The forest to update
-> SimpSpan -- ^The new span comes after this one
-> SimpSpan -- ^Existing span for the tokens
-> Positioning
-> [a] -- ^The new tokens belonging to the new SrcSpan
-> (Tree (Entry a) -- Updated forest with the new span
, SimpSpan ) -- ^Unique SrcSpan allocated in the forest to
-- identify this span in its position
addNewSrcSpanAndToksAfter forest oldSpan newSpan pos toks = (forest'',newSpan')
where
(forest',tree) = getSrcSpanForDeep forest (ss2f oldSpan)
(ghcl,_c) = getStartLoc newSpan
(ForestLine ch tr v l) = ghcLineToForestLine ghcl
newSpan' = insertForestLineInSpan (ForestLine ch tr (v+1) l) newSpan
toks' = placeToksForSpan forest' oldSpan tree pos toks
newNode = Node (Entry (ss2f newSpan') NoChange toks') []
forest'' = insertNodeAfter tree newNode forest'
-- ---------------------------------------------------------------------
placeToksForSpan :: (IsToken a)
=> Tree (Entry a)
-> SimpSpan
-> Tree (Entry a)
-> Positioning
-> [a]
-> [a]
placeToksForSpan forest oldSpan tree pos toks = toks'
where
z = openZipperToSpanDeep (ss2f 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
-- toks' = error $ "placeToksForSpan: prevToks'=" ++ (show prevToks')
-- toks' = error $ "placeToksForSpan: prevToks=" ++ (show prevToks)
-- ---------------------------------------------------------------------
limitPrevToks :: (IsToken a) => ReversedToks a -> SimpSpan -> ReversedToks a
limitPrevToks prevToks sspan = reverseToks prevToks''
where
((ForestLine _ _ _ startRow,_startCol),(ForestLine _ _ _ endRow,_)) = ss2f sspan
-- Make sure the toks do not extend past where we are
prevToks' = dropWhile (\t -> tokenRow t > endRow) $ unReverseToks prevToks
-- Only use the toks for the given oldspan
-- prevToks'' = dropWhile (\t -> tokenPos t < (startRow,startCol)) prevToks'
prevToks'' = dropWhile (\t -> tokenRow t < startRow) prevToks'
-- ---------------------------------------------------------------------
-- |Add new tokens after the given SrcSpan, constructing a new SrcSpan
-- in the process
addToksAfterSrcSpan :: (IsToken a)
=> Tree (Entry a) -- ^TokenTree to be modified
-> SimpSpan -- ^Preceding location for new tokens
-> Positioning
-> [a] -- ^New tokens to be added
-> (Tree (Entry a), SimpSpan) -- ^ updated TokenTree and SrcSpan location for
-- the new tokens in the TokenTree
addToksAfterSrcSpan forest oldSpan pos toks = (forest',newSpan')
where
(fwithspan,tree) = getSrcSpanForDeep forest (ss2f oldSpan)
toks'' = placeToksForSpan fwithspan oldSpan tree pos toks
(startPos,endPos) = nonCommentSpan toks''
newSpan = (startPos,endPos)
(forest',newSpan') = addNewSrcSpanAndToksAfter forest oldSpan newSpan pos toks
-- ---------------------------------------------------------------------
-- |For a span about to be deleted, calculate the gap between the end
-- of the span being deleted and the start of the next one, at a token
-- level.
calcPriorAndEndGap :: (IsToken a) => Tree (Entry a) -> ForestSpan -> (SimpPos,SimpPos)
calcPriorAndEndGap tree sspan = (pg,eg)
where
((spanStartRow,spanStartCol),(spanRow,spanCol)) = forestSpanToSimpPos sspan
(spanStart,spanEnd) = sspan
entries = retrieveTokens' tree
-- NOTE: the entries are the fringe of the tree, the sspan in
-- question may be represented by several entries
(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
-- last element of before should be the sspan we care about, first
-- of after is the one we are looking for.
-- NOTE: `after` may contain zero or more Deleted segments in the
-- front. These get merged later in mergeDeletes
(tokRow,tokCol) = if null 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)
-- eg = error $ "calcEndGap: (sspan,(before,middle,after))=" ++ (show (sspan,(_before,middle,after)))
(tokRowPg,tokColPg) = if null 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
-- TODO: what about comments before the span? spanStartRow may be off
pg = (spanStartRow - tokRowPg, spanStartCol - tokColPg)
-- ---------------------------------------------------------------------
-- TODO: delete this, superseded by calcPriorAndEndGap
-- |For a span about to be deleted, calculate the gap between the end
-- of the span being deleted and the start of the next one, at a token
-- level.
calcEndGap :: (IsToken a) => Tree (Entry a) -> ForestSpan -> SimpPos
calcEndGap tree sspan = gap
where
(_sspanStart,(spanRow,spanCol)) = forestSpanToSimpPos sspan
(spanStart,spanEnd) = sspan
entries = retrieveTokens' tree
-- NOTE: the entries are the fringe of the tree, the sspan in
-- question may be represented by several entries
(_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
-- last element of before should be the sspan we care about, first
-- of after is the one we are looking for.
-- NOTE: `after` may contain zero or more Deleted segments in the
-- front. These get merged later in mergeDeletes
(tokRow,tokCol) = if null 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)
-- gap = error $ "calcEndGap: (sspan,(before,middle,after))=" ++ (show (sspan,(_before,middle,after)))
-- ---------------------------------------------------------------------
-- |Replace the tokens for a given SrcSpan with new ones. The SrcSpan
-- will be inserted into the tree if it is not already there.
-- If the SrcSpan changes size, replace the SrcSpan with a new one
-- (marked), and return it, as well as the old one
-- TODO: What about trailing comments? Preserve or replace?
updateTokensForSrcSpan :: (IsToken a)
=> Tree (Entry a) -> SimpSpan -> [a] -> (Tree (Entry a),SimpSpan,Tree (Entry a))
updateTokensForSrcSpan forest sspan toks = (forest'',newSpan,oldTree)
where
(forest',tree@(Node (Entry _s _ _) _)) = getSrcSpanFor forest (ss2f sspan)
prevToks = retrieveTokensInterim tree
endComments = reverse $ takeWhile isWhiteSpaceOrIgnored $ reverse toks
startComments = takeWhile isWhiteSpaceOrIgnored $ toks
newTokStart = if (null prevToks)
then mkZeroToken
else ghead "updateTokensForSrcSpan.1" prevToks
toks'' = if (not (null startComments) || not (null endComments))
then -- toks have comments, discard originals
reIndentToks (PlaceAbsolute (tokenRow newTokStart) (tokenCol newTokStart)) prevToks toks
else -- Must reuse any pre-existing start or end comments, and
-- resync the tokens across all three.
let
origEndComments = reverse $ takeWhile isWhiteSpaceOrIgnored $ reverse prevToks
origStartComments = takeWhile isWhiteSpaceOrIgnored $ prevToks
((startRow,startCol),_) = forestSpanToGhcPos $ ss2f sspan
core = reIndentToks (PlaceAbsolute startRow startCol) prevToks toks
trail = if (null origEndComments)
then []
else addOffsetToToks (lineOffset,colOffset) origEndComments
where
lineOffset = 0 -- tokenRow (head origEndComments) - tokenRow (head origEndComments)
colOffset = 0 -- tokenCol (head origEndComments)
toks' = origStartComments ++ core ++ trail
in toks'
(startPos,endPos) = nonCommentSpan toks''
-- if the original sspan had a ForestLine version, preserve it
(((ForestLine _chs _trs vs _),_),(ForestLine _che _tre ve _,_)) = ss2f sspan
-- Note: adding one to end version, so invariant won't fail
-- newSpan = insertVersionsInSrcSpan vs ve $ posToSrcSpan forest (startPos,endPos)
newSpan = insertLenChangedInSrcSpan True True
$ insertVersionsInSrcSpan vs ve $ (startPos,endPos)
zf = openZipperToNode tree $ Z.fromTree forest'
zf' = Z.setTree (Node (Entry (ss2f newSpan) NoChange toks'') []) zf
forest'' = Z.toTree zf'
oldTree = tree
-- ---------------------------------------------------------------------
-- |Get the tokens preceding a given 'SrcSpan'
getTokensBefore :: (IsToken a) => Tree (Entry a) -> SimpSpan -> (Tree (Entry a),ReversedToks a)
getTokensBefore forest sspan = (forest', prevToks')
where
(forest',tree@(Node (Entry _s _ _) _)) = getSrcSpanFor forest (ss2f sspan)
z = openZipperToSpan (ss2f sspan) $ Z.fromTree forest'
prevToks = case (retrievePrevLineToks z) of
RT [] -> reverseToks $ retrieveTokensInterim tree
xs -> xs
(_,rtoks) = break (\t->tokenPos t < (getStartLoc sspan)) $ reversedToks prevToks
prevToks' = RT rtoks
-- ---------------------------------------------------------------------
-- |Get the (possible cached) tokens for a given source span, and
-- cache their being fetched.
-- NOTE: The SrcSpan may be one introduced by HaRe, rather than GHC.
getTokensFor :: (IsToken a) => Bool -> Tree (Entry a) -> SimpSpan -> (Tree (Entry a),[a])
getTokensFor checkInvariant forest sspan = (forest'', tokens)
where
forest' = if (not checkInvariant) || invariantOk forest
-- short circuit eval
then forest
else error $ "getTokensFor:invariant failed:" ++ (show $ invariant forest)
(forest'',tree) = getSrcSpanFor forest' (ss2f sspan)
tokens = retrieveTokensInterim tree
-- ---------------------------------------------------------------------
-- |Get the (possible cached) tokens for a given source span, and
-- cache their being fetched.
-- NOTE: The SrcSpan may be one introduced by HaRe, rather than GHC.
getTokensForNoIntros :: (IsToken a) => Bool -> Tree (Entry a) -> SimpSpan -> (Tree (Entry a),[a])
getTokensForNoIntros checkInvariant forest sspan = (forest', tokens')
where
(forest',tokens) = getTokensFor checkInvariant forest sspan
-- (lead,rest) = break (not . isWhiteSpaceOrIgnored) tokens
(lead,rest) = break (not . isIgnoredNonComment) tokens
tokens' = (filter (not . isIgnored) lead) ++ rest
-- ---------------------------------------------------------------------
-- |Starting from a point in the zipper, retrieve all tokens backwards
-- until the line changes for a non-comment/non-empty token or
-- beginning of file.
retrievePrevLineToks :: (IsToken a) => Z.TreePos Z.Full (Entry a) -> ReversedToks a
retrievePrevLineToks z = RT res' -- error $ "retrievePrevLineToks:done notWhite=" ++ (show (done notWhite)) -- ++AZ++
where
-- Assuming the zipper has been opened to the span we care about,
-- we will start with the tokens in the current tree, and work
-- back.
-- prevToks = retrieveTokens $ Z.tree z
prevToks = retrieveTokensInterim $ Z.tree z
-- Next one is the usual one
-- res' = reverse $ (concat (go z)) ++ prevToks
res' = reverse $ concat $ reverse (prevToks : (go z))
-- TODO: ++AZ++ what is this actually doing?
go :: (IsToken a) => Z.TreePos Z.Full (Entry a) -> [[a]]
go zz
| not (Z.isRoot zz) = toks : (go $ gfromJust "retrievePrevLineToks" (Z.parent zz))
| otherwise = [toks]
where
toks = concat $ reverse $ map retrieveTokensInterim $ Z.before zz
-- ---------------------------------------------------------------------
-- |Place the new tokens so that they are positioned correctly
-- relative to the previous tokens
reIndentToks :: (IsToken a) => Positioning -> [a] -> [a] -> [a]
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)) -- + 1
lineOffset' = rowIndent + lineStart - (tokenRow firstTok)
PlaceOffset rowIndent colIndent numLines -> (lineOffset',colOffset',numLines)
where
-- TODO: Should this not be prevOffset?
colStart = tokenCol $ ghead "reIndentToks.4"
$ dropWhile isWhiteSpaceOrIgnored prevToks
lineStart = (tokenRow (lastTok)) -- + 1
lineOffset' = rowIndent + lineStart - (tokenRow firstTok)
colOffset' = colIndent + colStart - (tokenCol newTokStart)
-- colOffset' = error $ "reIndentToks:placeOffset lineOffset=" ++ show lineOffset
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 -- ++AZ++ Why +1?
toks' = addOffsetToToks (lineOffset,colOffset) toks
toks'' = if endNewlines > 0
then toks' ++ [(newLinesToken (endNewlines - 1) $ glast "reIndentToks.3" toks')]
else toks'
-- ---------------------------------------------------------------------
-- | indent the tree and tokens by the given offset, and sync the AST
-- to the tree too.
indentDeclToks :: (IsToken a,HasLoc t) --(SYB.Data t)
=> (t -> ForestSpan -> t)
-> t -- ^The AST (or fragment)
-> Tree (Entry a) -- ^Existing token tree
-> Int -- ^ (signed) number of columns to indent/dedent
-> (t, Tree (Entry a)) -- ^Updated AST and tokens
indentDeclToks syncAST decl forest offset = (decl',forest'')
where
-- sspan = posToSpan (getLoc decl,getLocEnd decl)
sspan = getSpan decl
-- make sure the span is in the forest
(forest',tree) = getSrcSpanFor forest (ss2f sspan)
z = openZipperToSpan (ss2f sspan) $ Z.fromTree forest'
tree' = go tree
-- The invariant will fail if we do not propagate this change
-- upward. But it needs to sync with the AST, which we do not have
-- the upward version of.
-- Instead, set the lengthChanged flag, in the parent.
-- sss = forestSpanFromEntry entry
-- sss' = insertLenChangedInForestSpan True sss
-- tree'' = Node (putForestSpanInEntry entry sss') subs
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'' = Z.toTree (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
decl' = syncAST decl (ss2f $ addOffsetToSpan off sspan)
off = (0,offset)
-- Pretty sure this could be a fold of some kind
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)
-- ---------------------------------------------------------------------
addOffsetToSpan :: (Int,Int) -> SimpSpan -> SimpSpan
addOffsetToSpan (lineOffset,colOffset) sspan = sspan'
where
((sl,sc),(el,ec)) = sspan
sspan' = ((sl+lineOffset,sc+colOffset),(el+lineOffset,ec+colOffset))
-- ---------------------------------------------------------------------
-- |Open a zipper so that its focus has the given SrcSpan in its
-- subtree, or the location where the SrcSpan should go, if it is not
-- in the tree.
-- In the case of an 'Above' layout with the same SrcSpan below,
-- return that instead
openZipperToSpanDeep
:: (IsToken a)
=> ForestSpan
-> Z.TreePos Z.Full (Entry a)
-> Z.TreePos Z.Full (Entry a)
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'
-- ---------------------------------------------------------------------
-- |Retrieve a path to the tree containing a ForestSpan from the forest,
-- inserting it if not already present
getSrcSpanFor :: (IsToken a) => Tree (Entry a) -> ForestSpan -> (Tree (Entry a), Tree (Entry a))
getSrcSpanFor forest sspan = (forest',tree)
where
forest' = insertSrcSpan forest sspan -- Will NO-OP if already
-- there
z = openZipperToSpan sspan $ Z.fromTree forest'
tree = Z.tree z
-- ---------------------------------------------------------------------
-- |Retrieve a path to the tree containing a ForestSpan from the forest,
-- inserting it if not already present.
-- In the case where there is a nested series of spans as in an
-- 'Above' layout, return the deepest one
getSrcSpanForDeep :: (IsToken a)
=> Tree (Entry a) -> ForestSpan -> (Tree (Entry a), Tree (Entry a))
getSrcSpanForDeep forest sspan = (forest',tree)
where
forest' = insertSrcSpan forest sspan -- Will NO-OP if already
-- there
z = openZipperToSpanDeep sspan $ Z.fromTree forest'
tree = Z.tree z
-- ---------------------------------------------------------------------
-- |Insert a ForestSpan into the forest, if it is not there already.
-- Assumes the forest was populated with the tokens containing the
-- ForestSpan already
insertSrcSpan :: (IsToken a) => Tree (Entry a) -> ForestSpan -> Tree (Entry a)
insertSrcSpan forest sspan = forest'
where
z = openZipperToSpan sspan $ Z.fromTree forest
forest' = if treeStartEnd (Z.tree z) == sspan
then forest -- Already in, exactly
-- else error $ "insertSrcSpan:span not in tree " ++ show sspan
else if (Z.isLeaf z)
then -- TODO: This should be in splitSubToks
let
-- If we are at a leaf, retrieve the toks
(Entry _ _ toks) = Z.label z
(tokStartPos,tokEndPos) = forestSpanToSimpPos sspan
-- Tokens here, must introduce sub-spans with split, taking
-- cognizance of start and end comments
-- TODO: does startEndLocIncComments' give the same boundary
-- if approached from one side as the other?
(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 /= nullForestSpan) subTree
-- (Entry sspan2 _ _) = Z.label z
sspan2 = case Z.label z of
(Entry ss _ _) -> ss
(Deleted ss _ _) -> ss
-- z' = Z.setTree (Node (Entry sspan2 NoChange []) subTree') z
z' = case Z.label z of
(Entry _ _ _) -> Z.setTree (Node (Entry sspan2 NoChange []) subTree') z
(Deleted _ _ _) -> Z.setTree (Node (Entry sspan2 NoChange []) subTreeD) z
where
(tb,tm,te) = splitSubToks (Z.tree z) sspan
subTreeD = tb ++ tm ++ te
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 :: (IsToken a)
=> Tree (Entry a) -> ForestSpan
-> ([Tree (Entry a)], [Tree (Entry a)], [Tree (Entry a)])
doSplitTree tree@(Node (Deleted _ss _ _) []) sspan = splitSubToks tree sspan -- ++AZ+ What is correct?
doSplitTree tree@(Node (Entry _ss _ _toks) []) sspan = splitSubToks tree sspan
doSplitTree tree sspan = (b'',m'',e'')
-- error $ "doSplitTree:(sspan,tree,(b1,m1,e1))=" ++ (show (sspan,tree,(b1,m1,e1)))
where
(b1,m1,e1) = splitSubtree tree sspan
(b,m,e) = case m1 of
[] -> -- NOTE: This may have happened through a span being
-- deleted from the tree
-- Hence, correct solution is to kick it up a level and
-- rebuild using tokens etc
error $ "doSplitTree:no middle:(tree,sspan,b1,m1,e1)=" ++ (show (tree,sspan,b1,m1,e1))
[x] -> -- only one tree
doSplitTree x sspan
xx -> -- more than one tree
(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 -- xx = (head xx) ++ mm ++ (last xx)
b' = bb
m' = mb ++ mm ++ me
e' = ee
(b'',m'',e'') = (b1++b,m,e++e1)
-- ---------------------------------------------------------------------
-- TODO: The Bool is horrible
mkTreeListFromTokens :: (IsToken a) => [a] -> ForestSpan -> Bool -> [Tree (Entry a)]
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 :: (IsToken a)
=> Tree (Entry a)
-> (ForestPos, ForestPos)
-> ([Tree (Entry a)], [Tree (Entry a)], [Tree (Entry a)])
splitSubToks n@(Node (Deleted (treeStart,treeEnd) _pg _eg) []) (sspanStart,sspanEnd) = (b',m',e')
where
egs = (0,0) -- TODO: calculate this
ege = (0,0) -- TODO: calculate this
pg = 0 -- TODO: calculate this
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')
-- error $ "splitSubToks:(sspan,tree)=" ++ (show (sspan,tree))
where
(Node (Entry ss@(treeStart,treeEnd) _lay toks) []) = tree
(sspanStart,sspanEnd) = sspan
-- TODO: ignoring comment boundaries to start
-- There are three possibilities
-- 1. The span starts only in these tokens
-- 2. The span starts and ends in these tokens
-- 3. The span ends only in these tokens
(b',m',e') = case (containsStart ss sspan,containsEnd ss sspan) of
(True, False) -> (b'',m'',e'') -- Start only
-- error $ "splitSubToks:StartOnly:(sspan,tree,(b'',m''))=" ++ (show (sspan,tree,(b'',m'')))
where
(_,toksb,toksm) = splitToks (forestSpanToSimpPos (nullForestPos,sspanStart)) toks
-- b'' = if (emptyList toksb) then [] else [Node (Entry (treeStart, sspanEnd) toksb) []]
b'' = if (null toksb || nonCommentSpan toksb == ((0,0),(0,0)))
then []
else [mkTreeFromTokens toksb] -- Need to get end from actual toks
m'' = let
(ForestLine _ch _ts _v le,ce) = sspanEnd
tl =
if (treeStart == sspanStart) -- Eq does not compare all flags
then mkTreeListFromTokens toksm (treeStart, treeEnd) False
else mkTreeListFromTokens toksm (sspanStart,treeEnd) False
_tl' = if null 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'
tl
e'' = []
(True, True) -> (b'',m'',e'') -- Start and End
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'') -- End only
where
(_,toksm,tokse) = splitToks (forestSpanToSimpPos (nullForestPos,sspanEnd)) toks
b'' = []
m'' = let -- If the last span is changed, make sure it stays
-- as it was
tl = mkTreeListFromTokens toksm (treeStart,sspanEnd) False
tl' = if null 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))
-- ---------------------------------------------------------------------
-- |True if the start of the second param lies in the span of the first
containsStart :: ForestSpan -> ForestSpan -> Bool
containsStart (nodeStart,nodeEnd) (startPos,_endPos)
= (startPos >= nodeStart && startPos <= nodeEnd)
-- |True if the start of the second param lies before the first, and
-- ends after or on the second
containsMiddle :: ForestSpan -> ForestSpan -> Bool
containsMiddle (nodeStart,nodeEnd) (startPos,endPos)
= (startPos <= nodeStart) && (endPos >= nodeEnd)
-- |True if the end of the second param lies in the span of the first
containsEnd :: ForestSpan -> ForestSpan -> Bool
containsEnd (nodeStart,nodeEnd) (_startPos,endPos)
= (endPos >= nodeStart && endPos <= nodeEnd)
-- ---------------------------------------------------------------------
-- |Split a given tree into a possibly empty part that lies before the
-- srcspan, the part that is wholly included in the srcspan and the
-- part the lies outside of it at the end.
splitSubtree :: (IsToken a)
=> Tree (Entry a) -> ForestSpan
-> ([Tree (Entry a)], [Tree (Entry a)], [Tree (Entry a)])
splitSubtree tree sspan = (before,middle,end)
-- error $ "splitSubtree:(sspan,tree,middle',end')=" ++ (show (sspan,tree,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)
-- ---------------------------------------------------------------------
-- |Open a zipper so that its focus has the given SrcSpan in its
-- subtree, or the location where the SrcSpan should go, if it is not
-- in the tree
openZipperToSpan ::
(IsToken a)
=> ForestSpan
-> Z.TreePos Z.Full (Entry a)
-> Z.TreePos Z.Full (Entry a)
openZipperToSpan sspan z
| hasVersions = openZipperToSpanAdded sspan z
| otherwise = openZipperToSpanOrig sspan z
where
(vs,_ve) = forestSpanVersions sspan
hasVersions = vs /= 0
-- ---------------------------------------------------------------------
-- |Open a zipper so that its focus has the given SrcSpan in its
-- subtree, or the location where the SrcSpan should go, if it is not
-- in the tree
openZipperToSpanOrig ::
(IsToken a)
=> ForestSpan
-> Z.TreePos Z.Full (Entry a)
-> Z.TreePos Z.Full (Entry a)
openZipperToSpanOrig sspan z
= if (treeStartEnd (Z.tree z) == sspan) || (Z.isLeaf z)
then z
else z'
where
-- go through all of the children to find the one that
-- either is what we are looking for, or contains it
-- childrenAsZ = go [] (Z.firstChild z)
childrenAsZ = getChildrenAsZ z
z' = case (filter contains childrenAsZ) of
[] -> z -- Not directly in a subtree, this is as good as
-- it gets
[x] -> -- exactly one, drill down
openZipperToSpan sspan x
xx -> case (filter (\zt -> (treeStartEnd $ Z.tree zt) == sspan) xx) of
[] -> -- more than one matches, see if we can get
-- rid of the ones that have been lengthened
case (filter (not .forestSpanLenChanged . treeStartEnd . Z.tree) xx) of
[] -> z -- we tried...
[w] -> openZipperToSpan sspan w
-- ww -> error $ "openZipperToSpan:can't resolve:(sspan,ww)="++(show (sspan,ww))
ww -> -- more than one candidate, break
-- the tie on version match
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 -> -- Multiple, check if we can separate out by
-- version
case (filter (\zt -> (fst $ forestSpanVersions $ treeStartEnd $ Z.tree zt) == (fst $ forestSpanVersions sspan)) xx) of
-- [] -> z
[] -> error $ "openZipperToSpan:no version match:(sspan,yy)=" ++ (show (sspan,yy)) -- ++AZ++
[w] -> openZipperToSpan sspan w
_ww -> error $ "openZipperToSpan:multiple version match:" ++ (show (sspan,yy)) -- ++AZ++
contains zn = spanContains (treeStartEnd $ Z.tree zn) sspan
matchVersions span1 z2 = isMatch
where
span2 = treeStartEnd $ Z.tree z2
isMatch = forestSpanVersions span1 == forestSpanVersions span2
-- ---------------------------------------------------------------------
-- |Open a zipper to a SrcSpan that has been added in the tree, and
-- thus does not necessarily fall in the logical hierarchy of the tree
openZipperToSpanAdded ::
(IsToken a)
=> ForestSpan
-> Z.TreePos Z.Full (Entry a)
-> Z.TreePos Z.Full (Entry a)
openZipperToSpanAdded sspan z = zf
where
treeAsList = getTreeSpansAsList $ Z.tree z
-- True if first span contains the second
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 [] _ = []
fff acc@((cd,_cs):_) (v,sspan') = if v < cd then (v,sspan'):acc
else acc
tl3 = foldl' fff [(head tl2)] tl2
-- tl3 now contains the chain of ForestSpans to open in order in the zipper
zf = foldl' (flip openZipperToSpanOrig) z $ map snd tl3
-- ---------------------------------------------------------------------
getTreeSpansAsList :: (IsToken a) => Tree (Entry a) -> [(Int,ForestSpan)]
getTreeSpansAsList = getTreeSpansAsList' 0
getTreeSpansAsList' :: (IsToken a) => Int -> Tree (Entry a) -> [(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)
-- ---------------------------------------------------------------------
-- |Insert a new node after the designated one in the tree
insertNodeAfter :: (IsToken a)
=> Tree (Entry a) -> Tree (Entry a) -> Tree (Entry a) -> Tree (Entry a)
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
-- now go through the children of the parent tree, and find the
-- right spot for the new node
(f,s) = break (\t -> treeStartEnd t == treeStartEnd oldNode) $ subForest tp
(f',s') = (f++[ghead "insertNodeAfter" s],tail s) -- break does not include the found point
subForest' = f' ++ [newNode] ++ s'
tp' = tp { subForest = subForest' }
forest' = Z.toTree $ Z.setTree tp' zp
-- ---------------------------------------------------------------------
-- |Open a zipper so that its focus is the given node
-- NOTE: the node must already be in the tree
openZipperToNode :: (IsToken a)
=> Tree (Entry a)
-> Z.TreePos Z.Full (Entry a)
-> Z.TreePos Z.Full (Entry a)
openZipperToNode (Node (Entry sspan _ _) _) z
= openZipperToSpan sspan z
openZipperToNode (Node (Deleted sspan _ _) _) z
= openZipperToSpan sspan z
-- |Open a zipper so that its focus is the given node
-- NOTE: the node must already be in the tree
openZipperToNodeDeep :: (IsToken a)
=> Tree (Entry a)
-> Z.TreePos Z.Full (Entry a)
-> Z.TreePos Z.Full (Entry a)
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)
-- ---------------------------------------------------------------------
-- |Replace a single token in the token stream by a new token, without
-- adjusting the layout.
-- Note1: does not re-align, else other later replacements may fail.
-- Note2: must keep original end col, to know what the inter-token gap
-- was when re-aligning
replaceTokNoReAlign:: (IsToken a) => [a] -> SimpPos -> a -> [a]
replaceTokNoReAlign toks pos newTok =
toks1 ++ [newTok'] ++ toksRest
where
(toks1,toks2) = break (\t -> tokenPos t >= pos && tokenLen t > 0) toks
toksRest = if (null toks2) then [] else (gtail "replaceTokNoReAlign" toks2)
oldTok = if (null toks2) then newTok else (ghead "replaceTokNoReAlign" toks2)
-- newTok' = markToken $ matchTokenPos oldTok newTok
newTok' = matchTokenPos oldTok newTok
-- ---------------------------------------------------------------------
-- |Transfer the location information from the first param to the second
matchTokenPos :: (IsToken a) => a -> a -> a
matchTokenPos t1 t2 = putSpan t2 (getSpan t1)
{-
-- |Transfer the location information from the first param to the second
matchTokenPos :: PosToken -> PosToken -> PosToken
matchTokenPos (GHC.L l _,_) (GHC.L _ t,s) = (GHC.L l t,s)
-}
-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
-- |Retrieve all the tokens at the leaves of the tree, in order. No
-- adjustments are made to address gaps or re-alignment of the tokens
retrieveTokensInterim :: (IsToken a) => Tree (Entry a) -> [a]
retrieveTokensInterim forest = monotonicLineToks $ stripForestLines {- reAlignMarked -}
$ concat $ map (\t -> F.foldl accum [] t) [forest]
where
accum :: [a] -> (Entry a) -> [a]
accum acc (Entry _ _ []) = acc
accum acc (Entry _ _ toks) = acc ++ toks
accum acc (Deleted _ _ _) = acc
retrieveTokens' :: (IsToken a) => Tree (Entry a) -> [Entry a]
retrieveTokens' forest = mergeDeletes $ concat $ map (\t -> F.foldl accum [] t) [forest]
where
accum :: [Entry a] -> Entry a -> [Entry a]
accum acc (Entry _ _ []) = acc
accum acc e@(Entry _ _ _toks) = acc ++ [e]
accum acc e@(Deleted _ _ _) = acc ++ [e]
-- |Merge adjacent Deleted entries
mergeDeletes :: (IsToken a) => [Entry a] -> [Entry a]
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
-- ---------------------------------------------------------------------
-- | sort out line numbering so that they are always monotonically
-- increasing.
monotonicLineToks :: (IsToken a) => [a] -> [a]
monotonicLineToks toks = goMonotonicLineToks (0,0) toks
goMonotonicLineToks :: (IsToken a) => SimpPos -> [a] -> [a]
goMonotonicLineToks _ [] = []
goMonotonicLineToks _ [t] = [t]
goMonotonicLineToks (orow,ocol) (t1:t2:ts)
= t1:goMonotonicLineToks offset' (t2':ts)
where
offset' = if (tokenRow t1 - orow) > (tokenRow t2)
then (orow + (tokenRow t1) - tokenRow t2 + 1, ocol)
else (orow,ocol)
-- t1' = increaseSrcSpan (orow,ocol) t1
t2' = increaseSrcSpan offset' t2
-- ---------------------------------------------------------------------
{- No longer used
-- |Retrieve all the tokens at the leaves of the tree, in order.
-- Marked tokens are re-aligned, and gaps are closed.
retrieveTokensFinal :: (IsToken a) => Tree (Entry a) -> [a]
retrieveTokensFinal forest = monotonicLineToks $ stripForestLines $ reAlignMarked
$ deleteGapsToks $ retrieveTokens' forest
-}
-- ---------------------------------------------------------------------
reAlignMarked :: (IsToken a) => [a] -> [a]
reAlignMarked toks = concatMap alignOne $ groupTokensByLine toks
where
-- alignOne toksl = unmarked ++ (reAlignToks marked)
alignOne toksl = unmarked ++ (reAlignOneLine marked)
where
(unmarked,marked) = break isMarked toksl
-- ---------------------------------------------------------------------
-- | Some tokens are marked if they belong to identifiers which have
-- been renamed. When the renaming takes place, no layout adjustment
-- is done. This function adjusts the spacing for the rest of the line
-- to match as far as possible the original spacing, except for the
-- name change.
reAlignOneLine :: (IsToken a) => [a] -> [a]
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
| tokenLen tt == 0 = (tt,0)
| otherwise = (tt',deltac)
where
((sl,sc),(el,ec)) = getSpan tt
deltac = (tokenLen tt) - (ec - sc)
newPos = ((sl,sc),(el,ec+deltac))
tt' = putSpan tt newPos
-- ---------------------------------------------------------------------
applyOffsetToTreeShallow :: (IsToken a) => (Int,Int) -> Tree (Entry a) -> Tree (Entry a)
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
-- ---------------------------------------------------------------------
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))
-- ---------------------------------------------------------------------
stripForestLines :: (IsToken a) => [a] -> [a]
stripForestLines toks = map doOne toks
where
doOne tok = tok'
where
l = getSpan tok
tok' = putSpan tok l'
((ForestLine _ _ _ ls,_),(_,_)) = ss2f l
l' = insertForestLineInSpan (ForestLine False 0 0 ls) l
-- ---------------------------------------------------------------------
insertVersionsInSrcSpan :: Int -> Int -> SimpSpan -> SimpSpan
insertVersionsInSrcSpan vs ve ss = ss'
where
((sl,sc),(el,ec)) = ss
(chs,che) = forestSpanLenChangedFlags $ ss2f ss
(trs,tre) = forestSpanAstVersions $ ss2f ss
lineStart = forestLineToGhcLine (ForestLine chs trs vs sl)
lineEnd = forestLineToGhcLine (ForestLine che tre ve el)
ss' = ((lineStart,sc),(lineEnd,ec))
-- ---------------------------------------------------------------------
insertLenChangedInSrcSpan :: Bool -> Bool -> SimpSpan -> SimpSpan
insertLenChangedInSrcSpan chs che ss = ss'
where
((sl,sc),(el,ec)) = ss
sl' = if chs then sl .|. forestLenChangedMask
else sl .&. (complement forestLenChangedMask)
el' = if che then el .|. forestLenChangedMask
else el .&. (complement forestLenChangedMask)
ss' = ((sl',sc),(el',ec))
-- ---------------------------------------------------------------------
-- | Replace any ForestLine flags already in a SrcSpan with the given ones
insertForestLineInSpan :: ForestLine -> SimpSpan -> SimpSpan
insertForestLineInSpan fl@(ForestLine ch tr v _l) ss = ss'
where
lineStart = forestLineToGhcLine fl
((_,cs),(ForestLine _ _ _ le,ce)) = ss2f ss
lineEnd = forestLineToGhcLine (ForestLine ch tr v le)
ss' = ((lineStart,cs),(lineEnd,ce))
-- ---------------------------------------------------------------------
-- |Strip out the version markers
forestSpanToGhcPos :: ForestSpan -> (SimpPos,SimpPos)
forestSpanToGhcPos ((fls,sc),(fle,ec))
= ((forestLineToGhcLine fls,sc),(forestLineToGhcLine fle,ec))
-- ---------------------------------------------------------------------
-- | Get the indent of the line before, taking into account in-line
-- 'where', 'let', 'in' and 'do' tokens
getIndentOffset :: (IsToken a) => [a] -> SimpPos -> Int
getIndentOffset [] _pos = 1
getIndentOffset _toks (0,0) = 1
getIndentOffset toks pos
= let (ts1, ts2) = break (\t->tokenPos t >= pos) toks
in if (null ts2)
then error "haskell-token-utils error: position does not exist in the token stream!"
else let (sl,_) = splitOnNewLn $ reverse ts1
-- sl is the reversed tokens of the previous line
(sls,_) = break isWhereOrLet $ filter (\t -> tokenLen t > 0) sl
firstTok = (glast "getIndentOffset" sls)
in if startLayout firstTok
then if (length sls > 1)
then tokenOffset (last $ init sls)
else 4 + tokenOffset firstTok
else tokenOffset firstTok
where
tokenOffset t = (tokenCol t) - 1
startLayout tok = isDo tok || isIn tok || isLet tok || isWhere tok
-- ---------------------------------------------------------------------
splitOnNewLn :: (IsToken a) => [a] -> ([a],[a])
splitOnNewLn toks = go [] toks
-- ++AZ++ : TODO: is this simpler? : (toks1,toks2)=break (\x' -> tokenRow x /= tokenRow x') rtoks
where
go [] [] = ([],[])
go ss [] = (ss,[])
go [] xs = go [head xs] (tail xs)
go ss xs
| onSameLn (glast "splitOnNewLn" ss) (head xs) = go (ss ++ [head xs]) (tail xs)
| otherwise = (ss,xs)
-- ---------------------------------------------------------------------
onSameLn :: (IsToken a) => a -> a -> Bool
onSameLn t1 t2 = r1 == r2
where
((r1,_),_) = getSpan t1
((r2,_),_) = getSpan t2
-- ---------------------------------------------------------------------
newLnToken :: (IsToken a) => a -> a
newLnToken tok = newLinesToken 1 tok
-- ---------------------------------------------------------------------
newLinesToken :: (IsToken a) => Int -> a -> a
newLinesToken jump tok = tok'
where
((sl,_),_) = getSpan tok
nl = sl + jump
tok' = putSpan mkZeroToken ((nl,1),(nl,1))
-- ---------------------------------------------------------------------
-- | Convert a string into a set of Haskell tokens, following the
-- given position, with each line indented by a given column offset if
-- required
-- TODO: replace 'colOffset withFirstLineIndent' with a Maybe Int ++AZ++
tokenise :: (IsToken a) => SimpSpan -> Int -> Bool -> String -> [a]
tokenise _ _ _ [] = []
tokenise startPos colOffset withFirstLineIndent str
= let str' = case lines str of
(ln:[]) -> addIndent ln ++ if glast "tokenise" str=='\n' then "\n" else ""
(ln:lns)-> addIndent ln ++ "\n" ++ concatMap (\n->replicate colOffset ' '++n++"\n") lns
[] -> []
str'' = if glast "tokenise" str' == '\n' && glast "tokenise" str /= '\n'
then genericTake (length str' -1) str'
else str'
toks = lexStringToTokens startPos str''
in toks
-- in error $ "tokenise:" ++ (showToks $ head toks)
where
addIndent ln = if withFirstLineIndent
then replicate colOffset ' '++ ln
else ln
-- ---------------------------------------------------------------------
-- |Convert a string into a set of Haskell tokens. It has default
-- position and offset, since it will be stitched into place in TokenUtils
basicTokenise :: (IsToken a) => String -> [a]
basicTokenise str = tokenise startPos 0 False str
where
-- startPos = (GHC.mkRealSrcLoc tokenFileMark 0 1)
startPos = ((0,1),(0,1))
-- ---------------------------------------------------------------------