module Language.Haskell.TokenUtils.TokenUtils
(
initTokenCacheLayout
, mkTreeFromTokens
, mkTreeFromSpanTokens
, Positioning (..)
, ReversedToks(..)
, putToksInCache
, replaceTokenInCache
, removeToksFromCache
, getTokensFromCache
, getTokensNoIntrosFromCache
, getTokensBeforeFromCache
, addTokensAfterSpanInCache
, updateTokensForSrcSpan
, replaceTokenForSrcSpan
, getSrcSpanFor
, indentDeclToks
, addToksAfterSrcSpan
, addOffsetToSpan
, reIndentToks
, basicTokenise
, tokenise
, invariant
, reverseToks
, unReverseToks
, reversedToks
, retrieveTokensInterim
, getTokensForNoIntros
, getTokensFor
, getTokensBefore
, reAlignMarked
, splitOnNewLn
, getIndentOffset
, newLnToken
, startEndLocIncComments'
, forestSpanToGhcPos
, nullForestSpan
, nullForestPos
, simpPosToForestSpan
, showTree
, showToks
, addNewSrcSpanAndToksAfter
, openZipperToSpan
, openZipperToSpanAdded
, retrievePrevLineToks
, limitPrevToks
, insertSrcSpan
, insertLenChangedInSrcSpan
, insertVersionsInSrcSpan
, removeSrcSpan
, containsStart
, containsMiddle
, containsEnd
, splitSubtree
, insertNodeAfter
, splitSubToks
, placeToksForSpan
, reAlignOneLine
, calcEndGap
, getTreeSpansAsList
, openZipperToSpanOrig
, replaceTokNoReAlign
, 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
initTokenCache :: (IsToken a) => [a] -> TokenCache a
initTokenCache toks = TK (Map.fromList [((TId 0),(mkTreeFromTokens toks))]) (TId 0)
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
-> Positioning
-> [a]
-> (TokenCache a, SimpSpan)
addTokensAfterSpanInCache tk oldSpan pos toks = (tk',newSpan)
where
forest = getTreeFromCache oldSpan tk
(forest',newSpan) = addToksAfterSrcSpan forest oldSpan pos toks
tk' = replaceTreeInCache oldSpan forest' tk
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
data Positioning = PlaceAdjacent
| PlaceAbsolute !Int !Int
| PlaceAbsCol !Int !Int !Int
| PlaceOffset !Int !Int !Int
| PlaceIndent !Int !Int !Int
deriving (Show)
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')
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)
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)
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 []
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 :: (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 (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
showTree :: (IsToken a) => Tree (Entry a) -> String
showTree = prettyshow
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) ++ ") "
++ "[" ++ 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) }
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' }
replaceTokenForSrcSpan :: (IsToken a) => Tree (Entry a) -> SimpSpan -> a -> Tree (Entry a)
replaceTokenForSrcSpan forest sspan tok = forest'
where
tl = getSpan tok
z = openZipperToSpanDeep (ss2f 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 $ 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
removeSrcSpan :: (IsToken a) => Tree (Entry a) -> ForestSpan
-> (Tree (Entry a),Tree (Entry a))
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
addNewSrcSpanAndToksAfter :: (IsToken a)
=> Tree (Entry a)
-> SimpSpan
-> SimpSpan
-> Positioning
-> [a]
-> (Tree (Entry a)
, SimpSpan )
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
limitPrevToks :: (IsToken a) => ReversedToks a -> SimpSpan -> ReversedToks a
limitPrevToks prevToks sspan = reverseToks prevToks''
where
((ForestLine _ _ _ startRow,_startCol),(ForestLine _ _ _ endRow,_)) = ss2f sspan
prevToks' = dropWhile (\t -> tokenRow t > endRow) $ unReverseToks prevToks
prevToks'' = dropWhile (\t -> tokenRow t < startRow) prevToks'
addToksAfterSrcSpan :: (IsToken a)
=> Tree (Entry a)
-> SimpSpan
-> Positioning
-> [a]
-> (Tree (Entry a), SimpSpan)
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
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
(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 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)
(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
pg = (spanStartRow tokRowPg, spanStartCol tokColPg)
calcEndGap :: (IsToken a) => Tree (Entry a) -> 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 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)
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
reIndentToks (PlaceAbsolute (tokenRow newTokStart) (tokenCol newTokStart)) prevToks toks
else
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
colOffset = 0
toks' = origStartComments ++ core ++ trail
in toks'
(startPos,endPos) = nonCommentSpan toks''
(((ForestLine _chs _trs vs _),_),(ForestLine _che _tre ve _,_)) = ss2f sspan
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
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
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
then forest
else error $ "getTokensFor:invariant failed:" ++ (show $ invariant forest)
(forest'',tree) = getSrcSpanFor forest' (ss2f sspan)
tokens = retrieveTokensInterim tree
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 . isIgnoredNonComment) tokens
tokens' = (filter (not . isIgnored) lead) ++ rest
retrievePrevLineToks :: (IsToken a) => Z.TreePos Z.Full (Entry a) -> ReversedToks a
retrievePrevLineToks z = RT res'
where
prevToks = retrieveTokensInterim $ Z.tree z
res' = reverse $ concat $ reverse (prevToks : (go z))
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
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))
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'
indentDeclToks :: (IsToken a,HasLoc t)
=> (t -> ForestSpan -> t)
-> t
-> Tree (Entry a)
-> Int
-> (t, Tree (Entry a))
indentDeclToks syncAST decl forest offset = (decl',forest'')
where
sspan = getSpan decl
(forest',tree) = getSrcSpanFor forest (ss2f sspan)
z = openZipperToSpan (ss2f 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 (ss2f $ addOffsetToSpan off sspan)
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)
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))
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'
getSrcSpanFor :: (IsToken a) => Tree (Entry a) -> ForestSpan -> (Tree (Entry a), Tree (Entry a))
getSrcSpanFor forest sspan = (forest',tree)
where
forest' = insertSrcSpan forest sspan
z = openZipperToSpan sspan $ Z.fromTree forest'
tree = Z.tree z
getSrcSpanForDeep :: (IsToken a)
=> Tree (Entry a) -> ForestSpan -> (Tree (Entry a), Tree (Entry a))
getSrcSpanForDeep forest sspan = (forest',tree)
where
forest' = insertSrcSpan forest sspan
z = openZipperToSpanDeep sspan $ Z.fromTree forest'
tree = Z.tree z
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
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 /= nullForestSpan) subTree
sspan2 = case Z.label z of
(Entry ss _ _) -> ss
(Deleted ss _ _) -> ss
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
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 :: (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)
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 (nullForestPos,sspanStart)) toks
b'' = if (null 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 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
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 (nullForestPos,sspanEnd)) toks
b'' = []
m'' = let
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))
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 :: (IsToken a)
=> Tree (Entry a) -> ForestSpan
-> ([Tree (Entry a)], [Tree (Entry a)], [Tree (Entry a)])
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)
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
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
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
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
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
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)
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
(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 :: (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
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)
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' = matchTokenPos oldTok newTok
matchTokenPos :: (IsToken a) => a -> a -> a
matchTokenPos t1 t2 = putSpan t2 (getSpan t1)
retrieveTokensInterim :: (IsToken a) => Tree (Entry a) -> [a]
retrieveTokensInterim forest = monotonicLineToks $ stripForestLines
$ 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]
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
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)
t2' = increaseSrcSpan offset' t2
reAlignMarked :: (IsToken a) => [a] -> [a]
reAlignMarked toks = concatMap alignOne $ groupTokensByLine toks
where
alignOne toksl = unmarked ++ (reAlignOneLine marked)
where
(unmarked,marked) = break isMarked toksl
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))
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))
forestSpanToGhcPos :: ForestSpan -> (SimpPos,SimpPos)
forestSpanToGhcPos ((fls,sc),(fle,ec))
= ((forestLineToGhcLine fls,sc),(forestLineToGhcLine fle,ec))
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
(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
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))
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
where
addIndent ln = if withFirstLineIndent
then replicate colOffset ' '++ ln
else ln
basicTokenise :: (IsToken a) => String -> [a]
basicTokenise str = tokenise startPos 0 False str
where
startPos = ((0,1),(0,1))