HaRe-0.7.0.0: src/Language/Haskell/Refact/Utils/TokenUtils.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
--
-- This module contains an API to manage a token stream.
--
-- This API is used internally by MonadFunctions and the other utility
-- modules, it should probably never be used directly in a refactoring.
module Language.Haskell.Refact.Utils.TokenUtils(
-- * A token stream with last tokens first, and functions to
-- manipulate it
ReversedToks(..)
, reverseToks
, unReverseToks
, reversedToks
-- *
, Entry(..)
, Positioning(..)
, initTokenCache
, getTokensFor
, getTokensBefore
, replaceTokenForSrcSpan
, updateTokensForSrcSpan
, treeStartEnd
, spanStartEnd
, insertSrcSpan
, removeSrcSpan
, getSrcSpanFor
, retrieveTokensFinal
, retrieveTokensInterim
-- , retrieveTokens
, retrieveTokens' -- temporary for debug
, addNewSrcSpanAndToksAfter
, addToksAfterSrcSpan
, addDeclToksAfterSrcSpan
-- * Token Tree Selection
, treeIdFromForestSpan
, replaceTokenInCache
, putToksInCache
, removeToksFromCache
, getTreeFromCache
, replaceTreeInCache
, syncAstToLatestCache
-- * Token marking and re-alignment
-- , tokenFileMark
-- , markToken
-- , isMarked
, reAlignMarked
-- * Utility
, posToSrcSpan
, posToSrcSpanTok
, fileNameFromTok
-- * AST tie up
, syncAST
-- * Internal, for testing
, placeToksForSpan
, limitPrevToks
, reIndentToks
, reAlignOneLine
, reAlignToks
, splitForestOnSpan
, spanContains
, containsStart, containsMiddle, containsEnd
, doSplitTree, splitSubtree, splitSubToks
, nonCommentSpan
-- , lookupSrcSpan
, invariantOk
, invariant
, mkTreeFromTokens
, mkTreeFromSpanTokens
, showForest
, showTree
, showSrcSpan
, showSrcSpanF
, ghcSpanStartEnd
, insertNodeAfter
, retrievePrevLineToks
, openZipperToNode
, openZipperToSpan
, forestSpanToSimpPos
, forestSpanToGhcPos
, ghcLineToForestLine
, forestLineToGhcLine
, forestSpanToSrcSpan
, forestPosVersionSet
, forestPosVersionNotSet
, forestSpanLenChanged
, forestSpanVersions
, forestSpanVersionSet
, forestSpanVersionNotSet
, insertForestLineInSrcSpan
, insertLenChangedInSrcSpan
, insertVersionsInSrcSpan
, srcSpanToForestSpan
, nullSpan,nullPos
, simpPosToForestSpan
, srcPosToSimpPos
, showForestSpan
, deleteGapsToks
, deleteGapsToks'
, calcEndGap
, stripForestLines
-- * Based on Data.Tree
, drawTreeEntry
, drawTokenCache
, drawTokenCacheDetailed
, drawForestEntry
, drawEntry
) where
import qualified FastString as GHC
import qualified GHC as GHC
import qualified SrcLoc as GHC
import qualified Data.Generics as SYB
import qualified GHC.SYB.Utils as SYB
import qualified Data.Foldable as F
import Language.Haskell.Refact.Utils.GhcUtils
import Language.Haskell.Refact.Utils.LocUtils
import Language.Haskell.Refact.Utils.TokenUtilsTypes
import Language.Haskell.Refact.Utils.TypeSyn
import Data.Bits
import Data.List
import Data.Tree
import qualified Data.Map as Map
import qualified Data.Tree.Zipper as Z
-- import Debug.Trace
-- debug = flip trace
-- ---------------------------------------------------------------------
{-
Structure is to be indexed by SrcSpan.
Memo-ised.
Must be recursive, so if one srcspan is requested that contains a
modified sub-src span, the modified one is returned.
When initialising, split the tokens according to the binds, including
the leading and following comments. And perhaps a preamble and
postamble.
The token start and end loc does not necessarily coincide with the
associated srcloc, due to leading / trailing comments
SrcSpans are nested in one another according to the structure of the
AST.
Store it in some kind of tree structure, memoised.
Invariants:
1. For each tree, either the rootLabel has a SrcSpan only, or the subForest /= [].
2. 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.
3. A given SrcSpan can only appear (or be included) in a single tree of the forest.
-}
{-
NOTE: To break a cyclical import, this definition is in its own file
-- TODO: turn this into a record, with named accessors
-- | An entry in the data structure for a particular srcspan.
data Entry = Entry GHC.SrcSpan -- ^The source span contained in this Node
[PosToken] -- ^The tokens for the SrcSpan if subtree is empty
deriving (Show)
-}
{-
Note : Need to
1. Re-locate tokens according to their surrounding context. i.e. match
indent of enclosing structure, add leading/trailing newlines
2. Required by 1: Sync the SrcSpans to the AST, in the context of layout
-}
{-
NOTE: Token stream has zero-length string tokens in it,
ITvocurly
ITsemi
ITvccurly
These are inserted by GHC at points where a '{', ';' or '}' belongs in
the code, were it not implied by layout.
This can perhaps be used to choose appropriate token boundaries.
-}
deriving instance Show Entry => Show (Entry)
-- ---------------------------------------------------------------------
-- |Keep track of when tokens are reversed, to avoid confusion
data ReversedToks = RT [PosToken]
deriving (Show)
reverseToks :: [PosToken] -> ReversedToks
reverseToks toks = RT $ reverse toks
unReverseToks :: ReversedToks -> [PosToken]
unReverseToks (RT toks) = reverse toks
reversedToks :: ReversedToks -> [PosToken]
reversedToks (RT toks) = toks
-- |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)
-- ---------------------------------------------------------------------
{-
-- ++AZ++ TODO: will we actually need these?
-- | Operations on the structure
data Operations = OpAdded Entry -- ^The entry that was added
| OpRemoved Entry -- ^The Entry that was removed
| OpReplaced Entry Entry -- ^The first is old, second is new Entry
-}
-- ---------------------------------------------------------------------
-- A data type for the line entries in a SrcSpan. This has the
-- following properties
--
-- 1. It can be converted to and from the underlying Int in the
-- original SrcSpan
-- 2. It allows the insertion of an arbitrary line as the start of a
-- new SrcSpan
-- 3. It has an ordering relation, which honours the inserts which
-- were made.
-- 4. It can keep track of tokens that have been removed from the main
-- AST, which can be edited outside of it and then inserted again
--
-- This is achieved by adding two fields to the SrcSpan, one to
-- indicate which AST fragment it is in, and the other to indicate its
-- insert relationship, encoded as 0 for the original, 1 for the
-- first, 2 for the second and so on.
--
-- This field is converted to and from the original line by being
-- multiplied by a very large number and added to the original.
--
-- The guaranteed max value in Haskell for an Int is 2^29 - 1.
-- This evaluates to 536,870,911,or 536.8 million.
--
-- However, as pointed out on #haskell, the GHC compiler (which this
-- implemtation explicitly targets) provides the full 32 bits (at
-- least, can be 64), so we have
-- maxBound :: Int = 2,147,483,647
--
-- Schema:max pos value is 0x7fffffff (31 bits)
-- 1 bit for LenChanged
-- 5 bits for tree : 32 values
-- 5 bits for version : 32 values
-- 20 bits for line number: 1048576 values
forestLineMask,forestVersionMask,forestTreeMask,forestLenChangedMask :: Int
forestLineMask = 0xfffff -- bottom 20 bits
forestVersionMask = 0x1f00000 -- next 5 bits
forestTreeMask = 0x3e000000 -- next 5 bits
forestLenChangedMask = 0x40000000 -- top (non-sign) bit
forestVersionShift :: Int
forestVersionShift = 20
forestTreeShift :: Int
forestTreeShift = 25
{-
This has been moved to TokenUtilsTypes
data ForestLine = ForestLine
{ flSpanLengthChanged :: Bool -- ^The length of the
-- span may have
-- changed due to
-- updated tokens.
, flTreeSelector :: Int
, flInsertVersion :: Int
, flLine :: Int
} deriving (Eq)
-}
-- | Extract an encoded ForestLine from a GHC line
ghcLineToForestLine :: Int -> ForestLine
ghcLineToForestLine l = ForestLine ch tr v l'
where
l' = l .&. forestLineMask
v = shiftR (l .&. forestVersionMask) forestVersionShift
tr = shiftR (l .&. forestTreeMask) forestTreeShift
ch = (l .&. forestLenChangedMask) /= 0
-- TODO: check that the components are in range
forestLineToGhcLine :: ForestLine -> Int
forestLineToGhcLine fl = (if (flSpanLengthChanged fl) then forestLenChangedMask else 0)
+ (shiftL (flTreeSelector fl) forestTreeShift)
+ (shiftL (flInsertVersion fl) forestVersionShift)
+ (flLine fl)
forestSpanToSrcSpan :: ForestSpan -> GHC.SrcSpan
forestSpanToSrcSpan ((fls,sc),(fle,ec)) = sspan
where
lineStart = forestLineToGhcLine fls
lineEnd = forestLineToGhcLine fle
locStart = GHC.mkSrcLoc (GHC.mkFastString "foo") lineStart sc
locEnd = GHC.mkSrcLoc (GHC.mkFastString "foo") lineEnd ec
sspan = GHC.mkSrcSpan locStart locEnd
instance Ord ForestLine where
-- Use line as the primary comparison, but break any ties with the
-- version
-- Tree is ignored, as it is only a marker on the topmost element
-- Ignore sizeChanged flag, it will only be relevant in the
-- invariant check
compare (ForestLine _sc1 _ v1 l1) (ForestLine _sc2 _ v2 l2) =
if (l1 == l2)
then compare v1 v2
else compare l1 l2
-- |Gets the version numbers
forestSpanVersions :: ForestSpan -> (Int,Int)
forestSpanVersions ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = (sv,ev)
-- |Gets the AST tree numbers
forestSpanAstVersions :: ForestSpan -> (Int,Int)
forestSpanAstVersions ((ForestLine _ trs _ _,_),(ForestLine _ tre _ _,_)) = (trs,tre)
-- |Gets the SpanLengthChanged flags
forestSpanLenChangedFlags :: ForestSpan -> (Bool,Bool)
forestSpanLenChangedFlags ((ForestLine chs _ _ _,_),(ForestLine che _ _ _,_)) = (chs,che)
-- |Checks if the version is non-zero in either position
forestSpanVersionSet :: ForestSpan -> Bool
forestSpanVersionSet ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = sv /= 0 || ev /= 0
-- |Checks if the version is zero in both positions
forestSpanVersionNotSet :: ForestSpan -> Bool
forestSpanVersionNotSet ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = sv == 0 && ev == 0
-- |Checks if the version is non-zero
forestPosVersionSet :: ForestPos -> Bool
forestPosVersionSet (ForestLine _ _ v _,_) = v /= 0
-- |Checks if the AST version is non-zero
forestPosAstVersionSet :: ForestPos -> Bool
forestPosAstVersionSet (ForestLine _ tr _ _,_) = tr /= 0
-- |Checks if the version is zero
forestPosVersionNotSet :: ForestPos -> Bool
forestPosVersionNotSet (ForestLine _ _ v _,_) = v == 0
forestSpanLenChanged :: ForestSpan -> Bool
forestSpanLenChanged (s,e) = (forestPosLenChanged s) || (forestPosLenChanged e)
forestPosLenChanged :: ForestPos -> Bool
forestPosLenChanged (ForestLine ch _ _ _,_) = ch
-- |Puts a TreeId into a forestSpan
treeIdIntoForestSpan :: TreeId -> ForestSpan -> ForestSpan
treeIdIntoForestSpan (TId sel) ((ForestLine chs _ sv sl,sc),(ForestLine che _ ev el,ec))
= ((ForestLine chs sel sv sl,sc),(ForestLine che sel ev el,ec))
-- |Strip out the version markers
forestSpanToSimpPos :: ForestSpan -> (SimpPos,SimpPos)
forestSpanToSimpPos ((ForestLine _ _ _ sr,sc),(ForestLine _ _ _ er,ec)) = ((sr,sc),(er,ec))
-- |Strip out the version markers
forestSpanToGhcPos :: ForestSpan -> (SimpPos,SimpPos)
forestSpanToGhcPos ((fls,sc),(fle,ec))
= ((forestLineToGhcLine fls,sc),(forestLineToGhcLine fle,ec))
simpPosToForestSpan :: (SimpPos,SimpPos) -> ForestSpan
simpPosToForestSpan ((sr,sc),(er,ec))
= ((ghcLineToForestLine sr,sc),(ghcLineToForestLine er,ec))
srcPosToSimpPos :: (Int,Int) -> (Int,Int)
srcPosToSimpPos (sr,c) = (l,c)
where
(ForestLine _ _ _ l) = ghcLineToForestLine sr
forestSpanStart :: ForestSpan -> ForestPos
forestSpanStart (start,_) = start
forestSpanEnd :: ForestSpan -> ForestPos
forestSpanEnd (_,end) = end
nullSpan :: ForestSpan
nullSpan = (nullPos,nullPos)
nullPos :: ForestPos
nullPos = (ForestLine False 0 0 0,0)
showForestSpan :: ForestSpan -> String
showForestSpan ((sr,sc),(er,ec))
= show ((flToNum sr,sc),(flToNum er,ec))
where
flToNum (ForestLine ch tr v l) = (if ch then 10000000000::Integer else 0)
+ ((fromIntegral tr) * 100000000::Integer)
+ ((fromIntegral v) * 1000000::Integer)
+ (fromIntegral l)
-- ---------------------------------------------------------------------
insertForestLineInSrcSpan :: ForestLine -> GHC.SrcSpan -> GHC.SrcSpan
insertForestLineInSrcSpan fl@(ForestLine ch tr v _l) (GHC.RealSrcSpan ss) = ss'
where
lineStart = forestLineToGhcLine fl
lineEnd = forestLineToGhcLine (ForestLine ch tr v (GHC.srcSpanEndLine ss))
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss)
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineEnd (GHC.srcSpanEndCol ss)
ss' = GHC.mkSrcSpan locStart locEnd
insertForestLineInSrcSpan _ _ss = error $ "insertForestLineInSrcSpan: expecting a RealSrcSpan, got:" -- ++ (showGhc ss)
-- ---------------------------------------------------------------------
insertVersionsInSrcSpan :: Int -> Int -> GHC.SrcSpan -> GHC.SrcSpan
insertVersionsInSrcSpan vs ve rss@(GHC.RealSrcSpan ss) = ss'
where
(chs,che) = forestSpanLenChangedFlags $ srcSpanToForestSpan rss
(trs,tre) = forestSpanAstVersions $ srcSpanToForestSpan rss
lineStart = forestLineToGhcLine (ForestLine chs trs vs (GHC.srcSpanStartLine ss))
lineEnd = forestLineToGhcLine (ForestLine che tre ve (GHC.srcSpanEndLine ss))
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss)
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineEnd (GHC.srcSpanEndCol ss)
ss' = GHC.mkSrcSpan locStart locEnd
insertVersionsInSrcSpan _ _ _ss = error $ "insertVersionsInSrcSpan: expecting a RealSrcSpan, got:" -- ++ (showGhc ss)
-- ---------------------------------------------------------------------
insertLenChangedInSrcSpan :: Bool -> Bool -> GHC.SrcSpan -> GHC.SrcSpan
insertLenChangedInSrcSpan chs che rss@(GHC.RealSrcSpan ss) = ss'
where
(sl,_sc) = getGhcLoc rss
(el,_ec) = getGhcLocEnd rss
sl' = if chs then sl .|. forestLenChangedMask
else sl .&. (complement forestLenChangedMask)
el' = if che then el .|. forestLenChangedMask
else el .&. (complement forestLenChangedMask)
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) sl' (GHC.srcSpanStartCol ss)
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) el' (GHC.srcSpanEndCol ss)
-- (vs,ve) = forestSpanVersions $ srcSpanToForestSpan rss
-- (trs,tre) = forestSpanAstVersions $ srcSpanToForestSpan rss
-- lineStart = forestLineToGhcLine (ForestLine chs trs vs (GHC.srcSpanStartLine ss))
-- lineEnd = forestLineToGhcLine (ForestLine che tre ve (GHC.srcSpanEndLine ss))
-- locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss)
-- locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineEnd (GHC.srcSpanEndCol ss)
ss' = GHC.mkSrcSpan locStart locEnd
insertLenChangedInSrcSpan _ _ _ss = error $ "insertVersionsInSrcSpan: expecting a RealSrcSpan, got:" -- ++ (showGhc ss)
-- ---------------------------------------------------------------------
insertVersionsInForestSpan :: Int -> Int -> ForestSpan -> ForestSpan
insertVersionsInForestSpan vsNew veNew ((ForestLine chs trs _vs ls,cs),(ForestLine che tre _ve le,ce))
= ((ForestLine chs trs vsNew ls,cs),(ForestLine che tre veNew le,ce))
-- ---------------------------------------------------------------------
srcSpanToForestSpan :: GHC.SrcSpan -> ForestSpan
srcSpanToForestSpan sspan = ((ghcLineToForestLine startRow,startCol),(ghcLineToForestLine endRow,endCol))
where
(startRow,startCol) = getGhcLoc sspan
(endRow,endCol) = getGhcLocEnd sspan
-- --------------------------------------------------------------------
forestSpanFromEntry :: Entry -> ForestSpan
forestSpanFromEntry (Entry ss _ ) = ss
forestSpanFromEntry (Deleted ss _) = ss
-- --------------------------------------------------------------------
treeIdFromForestSpan :: ForestSpan -> TreeId
treeIdFromForestSpan ((ForestLine _ tr _ _,_),(ForestLine _ _ _ _,_)) = TId tr
-- ---------------------------------------------------------------------
{-
data Module = Module
{ mTypecheckedMod :: GHC.TypecheckedModule
, mOrigTokenStream :: [PosToken] -- ^Original Token stream for the current module
, mTokenCache :: Tree Entry -- ^Any modifications to the token stream.
}
initModule :: GHC.TypecheckedModule -> [PosToken] -> Module
initModule typeChecked tokens
= Module
{ mTypecheckedMod = typeChecked
, mOrigTokenStream = tokens
, mTokenCache = mkTreeFromTokens tokens
}
-}
-- Initially work with non-monadic code, can build it into the
-- RefactGhc monad later
initTokenCache :: [PosToken] -> TokenCache
initTokenCache toks = TK (Map.fromList [((TId 0),(mkTreeFromTokens toks))]) (TId 0)
-- ---------------------------------------------------------------------
treeIdIntoTree :: TreeId -> Tree Entry -> Tree Entry
treeIdIntoTree tid (Node (Entry fs toks) subTree) = tree'
where
fs' = treeIdIntoForestSpan tid fs
tree' = Node (Entry fs' toks) subTree
-- ---------------------------------------------------------------------
stash :: TokenCache -> Tree Entry -> TokenCache
stash tk oldTree = tk'
where
(TId lastTreeId) = tkLastTreeId tk
lastTreeId' = TId (lastTreeId + 1)
oldTree' = treeIdIntoTree lastTreeId' oldTree
cache' = Map.insert lastTreeId' oldTree' (tkCache tk)
tk' = tk {tkLastTreeId = lastTreeId', tkCache = cache' }
-- ---------------------------------------------------------------------
replaceTokenInCache :: TokenCache -> GHC.SrcSpan -> PosToken -> TokenCache
replaceTokenInCache tk sspan tok = tk'
where
forest = getTreeFromCache sspan tk
forest' = replaceTokenForSrcSpan forest sspan tok
tk' = replaceTreeInCache sspan forest' tk
-- ---------------------------------------------------------------------
putToksInCache :: TokenCache -> GHC.SrcSpan -> [PosToken] -> (TokenCache,GHC.SrcSpan)
putToksInCache tk sspan toks = (tk'',newSpan)
where
forest = getTreeFromCache sspan tk
(forest',newSpan,oldTree) = updateTokensForSrcSpan forest sspan toks
tk' = replaceTreeInCache sspan forest' tk
tk'' = stash tk' oldTree
-- ---------------------------------------------------------------------
removeToksFromCache :: TokenCache -> GHC.SrcSpan -> TokenCache
removeToksFromCache tk sspan = tk''
where
forest = getTreeFromCache sspan tk
(forest',oldTree) = removeSrcSpan forest (srcSpanToForestSpan sspan)
tk' = replaceTreeInCache sspan forest' tk
tk'' = stash tk' oldTree
-- ---------------------------------------------------------------------
getTreeFromCache :: GHC.SrcSpan -> TokenCache -> Tree Entry
getTreeFromCache sspan tk = (tkCache tk) Map.! tid
where
tid = treeIdFromForestSpan $ srcSpanToForestSpan sspan
-- ---------------------------------------------------------------------
replaceTreeInCache :: GHC.SrcSpan -> Tree Entry -> TokenCache -> TokenCache
replaceTreeInCache sspan tree tk = tk'
where
tid = treeIdFromForestSpan $ srcSpanToForestSpan sspan
-- tree' = treeIdIntoTree tid tree
tree' = putTidInTree tid tree
tk' = tk {tkCache = Map.insert tid tree' (tkCache tk) }
putTidInTree :: TreeId -> Tree Entry -> Tree Entry
putTidInTree tid (Node (Deleted fs eg) []) = (Node (Deleted fs' eg) [])
where fs' = treeIdIntoForestSpan tid fs
putTidInTree tid (Node (Entry fs toks) subs) = tree'
where
subs' = map (putTidInTree tid) subs
fs' = treeIdIntoForestSpan tid fs
tree' = Node (Entry fs' toks) subs'
-- ---------------------------------------------------------------------
-- |Assuming most recent operation has stashed the old tokens, sync
-- the given AST to the most recent stash entry
syncAstToLatestCache :: (SYB.Data t) => TokenCache -> GHC.Located t -> GHC.Located t
syncAstToLatestCache tk t = t'
-- = error $ "syncAstToLatestCache:pos=" ++ (show pos)
-- = error $ "syncAstToLatestCache:fs=" ++ (show fs)
-- = error $ "syncAstToLatestCache:sspan=" ++ (show sspan)
where
mainForest = (tkCache tk) Map.! mainTid
forest@(Node (Entry fs _) _) = (tkCache tk) Map.! (tkLastTreeId tk)
pos = forestSpanToGhcPos fs
sspan = posToSrcSpan mainForest pos
(t',_) = syncAST t sspan forest
-- ---------------------------------------------------------------------
-- |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.
-- TODO: consider returning an Either. Although in reality the error
-- should never happen
getTokensFor :: Bool -> Tree Entry -> GHC.SrcSpan -> (Tree Entry,[PosToken])
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' (srcSpanToForestSpan sspan)
tokens = retrieveTokensInterim tree
-- ---------------------------------------------------------------------
-- |Get the tokens preceding a given 'SrcSpan'
getTokensBefore :: Tree Entry -> GHC.SrcSpan -> (Tree Entry,ReversedToks)
getTokensBefore forest sspan = (forest', prevToks')
where
(forest',tree@(Node (Entry _s _) _)) = getSrcSpanFor forest (srcSpanToForestSpan sspan)
z = openZipperToSpan (srcSpanToForestSpan sspan) $ Z.fromTree forest'
prevToks = case (retrievePrevLineToks z) of
RT [] -> reverseToks $ retrieveTokensInterim tree
xs -> xs
(_,rtoks) = break (\t->tokenPos t < (getGhcLoc sspan)) $ reversedToks prevToks
prevToks' = RT rtoks
-- ---------------------------------------------------------------------
-- |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
replaceTokenForSrcSpan :: Tree Entry -> GHC.SrcSpan -> PosToken -> Tree Entry
replaceTokenForSrcSpan forest sspan tok = forest'
where
(GHC.L tl _,_) = tok
-- First open to the sspan, making use of any Forestline annotations
z = openZipperToSpan (srcSpanToForestSpan sspan) $ Z.fromTree forest
-- Then drill down to the specific subtree containing the token
z' = openZipperToSpan (srcSpanToForestSpan tl) z
(tspan,toks) = case Z.tree z' of
(Node (Entry ss tks) []) -> (ss,tks)
(Node (Entry _ []) _sub) -> error $ "replaceTokenForSrcSpan: expecting tokens, found: " ++ (show $ Z.tree z')
((row,col),_) = forestSpanToSimpPos $ srcSpanToForestSpan tl
toks' = replaceTokNoReAlign toks (row,col) tok
zf = Z.setTree (Node (Entry tspan toks') []) z'
forest' = Z.toTree zf
-- forest' = forest
-- ---------------------------------------------------------------------
-- |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 :: Tree Entry -> GHC.SrcSpan -> [PosToken] -> (Tree Entry,GHC.SrcSpan,Tree Entry)
updateTokensForSrcSpan forest sspan toks = (forest'',newSpan,oldTree)
where
(forest',tree@(Node (Entry _s _) _)) = getSrcSpanFor forest (srcSpanToForestSpan sspan)
prevToks = retrieveTokensInterim tree
endComments = reverse $ takeWhile isWhiteSpace $ reverse toks
startComments = takeWhile isWhiteSpace $ toks
newTokStart = if (emptyList prevToks)
then mkZeroToken
else ghead "updateTokensForSrcSpan.1" prevToks
toks'' = if (nonEmptyList startComments || nonEmptyList 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 isWhiteSpace $ reverse prevToks
origStartComments = takeWhile isWhiteSpace $ prevToks
core = reIndentToks (PlaceAbsolute (tokenRow newTokStart) (tokenCol newTokStart)) prevToks toks
trail = if (emptyList 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 _,_)) = srcSpanToForestSpan 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 $ posToSrcSpan forest (startPos,endPos)
zf = openZipperToNode tree $ Z.fromTree forest'
zf' = Z.setTree (Node (Entry (srcSpanToForestSpan newSpan) toks'') []) zf
forest'' = Z.toTree zf'
-- forest'' = error $ "updateTokensForSrcSpan: toks''=" ++ (show toks'') -- ++AZ++
-- forest'' = error $ "updateTokensForSrcSpan: (posToSrcSpan forest (startPos,endPos))=" ++ (showGhc $ posToSrcSpan forest (startPos,endPos)) -- ++AZ++
-- forest'' = error $ "updateTokensForSrcSpan: tree=" ++ (show tree) -- ++AZ++
-- (forest'',newSpan') = addNewSrcSpanAndToksAfter forest sspan newSpan pos toks''
oldTree = tree
-- ---------------------------------------------------------------------
-- |Retrieve a path to the tree containing a ForestSpan from the forest,
-- inserting it if not already present
getSrcSpanFor :: Tree Entry -> ForestSpan -> (Tree Entry, Tree Entry)
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
-- ---------------------------------------------------------------------
-- |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 :: Tree Entry -> ForestSpan -> Tree Entry
insertSrcSpan forest sspan = forest'
where
z = openZipperToSpan sspan $ Z.fromTree forest
forest' = if treeStartEnd (Z.tree z) == sspan
then forest -- Already in, exactly
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 (emptyList $ filter (\t -> not $ isEmpty t) startToks)
then []
else [mkTreeFromTokens startToks]
tree2 = [mkTreeFromSpanTokens sspan middleToks]
tree3 = if (emptyList $ filter (\t -> not $ isEmpty t) endToks)
then []
else [mkTreeFromTokens endToks]
subTree = tree1 ++ tree2 ++ tree3
subTree' = filter (\t -> treeStartEnd t /= nullSpan) subTree
(Entry sspan2 _) = Z.label z
z' = Z.setTree (Node (Entry sspan2 []) subTree') z
forest'' = Z.toTree z'
in forest''
else
let
(before,middle,end) = doSplitTree (Z.tree z) sspan
newTree = case middle of
[x] -> x
_xs -> (Node (Entry sspan []) middle)
subTree' = before ++ [newTree] ++ end
(Entry sspan2 _) = Z.label z
z' = Z.setTree (Node (Entry sspan2 []) subTree') z
forest'' = Z.toTree z'
in
forest''
-- error $ "insertSrcSpan:(before,middle,end)=" ++ (show (before,middle,end)) -- ++AZ++
-- forest'' = error $ "insertSrcSpan:(startToks,endToks)=" ++ (show (startToks,endToks)) -- ++AZ++
-- forest'' = error $ "insertSrcSpan:(Z.toTree z')=" ++ (show (Z.toTree z')) -- ++AZ++
-- forest'' = error $ "insertSrcSpan:(startLoc,endLoc)=" ++ (show (startLoc,endLoc)) -- ++AZ++
-- forest'' = error $ "insertSrcSpan:(tokStartPos,tokEndPos,toks)=" ++ (show (tokStartPos,tokEndPos,toks)) -- ++AZ++
-- ---------------------------------------------------------------------
doSplitTree ::
Tree Entry -> ForestSpan
-> ([Tree Entry], [Tree Entry], [Tree Entry])
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))
-- ( bb,mb,[]) = doSplitTree (ghead "doSplitTree.2" xx) sspan
( [],me,ee) = doSplitTree (glast "doSplitTree.2" xx) sspan
-- ( bbb,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)
-- ---------------------------------------------------------------------
mkTreeListFromTokens :: [PosToken] -> ForestSpan -> [Tree Entry]
mkTreeListFromTokens [] _sspan = []
mkTreeListFromTokens toks sspan = res
where
(Node (Entry tspan 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 ((ls,cs),(le,ce)) == ((0,0),(0,0))
then []
else [(Node (Entry span' treeToks) sub)]
splitSubToks ::
Tree Entry
-> (ForestPos, ForestPos)
-> ([Tree Entry], [Tree Entry], [Tree Entry])
splitSubToks n@(Node (Deleted (ssStart,ssEnd) _eg) []) (sspanStart,sspanEnd) = (b',m',e')
where
egs = (0,0) -- TODO: calculate this
ege = (0,0) -- TODO: calculate this
b' = if sspanStart > ssStart
then [Node (Deleted (ssStart,ssStart) egs) []]
-- then error $ "splitSubToks:would return:b'=" ++ (show [Node (Deleted (ssStart,ssStart) egs) []]) -- ++AZ++
else []
m' = [n]
e' = if ssEnd > sspanEnd
then [Node (Deleted (sspanEnd,ssEnd) ege) []]
-- then error $ "splitSubToks:would return:e'=" ++ (show [Node (Deleted (sspanEnd,ssEnd) ege) []]) -- ++AZ++
else []
splitSubToks tree sspan = (b',m',e')
-- error $ "splitSubToks:(sspan,tree)=" ++ (show (sspan,tree))
where
(Node (Entry ss@(ssStart,ssEnd) 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 (nullPos,sspanStart)) toks
-- b'' = if (emptyList toksb) then [] else [Node (Entry (ssStart, sspanEnd) toksb) []]
b'' = if (emptyList toksb) then [] else [mkTreeFromTokens toksb] -- Need to get end from actual toks
{-
m'' = if (ssStart == sspanStart) -- Eq does not compare all flags
then mkTreeListFromTokens toksm (ssStart, ssEnd)
else mkTreeListFromTokens toksm (sspanStart,ssEnd)
-}
m'' = let
-- ssStart, ssEnd is passed in node
-- sspanStart, sspanEnd is span we are matching
(ForestLine _ch _ts _v le,ce) = sspanEnd
tl =
if (ssStart == sspanStart) -- Eq does not compare all flags
then mkTreeListFromTokens toksm (ssStart, ssEnd)
else mkTreeListFromTokens toksm (sspanStart,ssEnd)
_tl' = if emptyList tl
then []
else [Node (Entry (st,(ForestLine ch ts v le,ce)) tk) []]
where [Node (Entry (st,(ForestLine ch ts v _l,_c)) tk) []] = tl
in
-- tl'
tl
e'' = []
(True, True) -> (b'',m'',e'') -- Start and End
where
(toksb,toksm,tokse) = splitToks (forestSpanToSimpPos (ssStart,ssEnd)) toks
b'' = mkTreeListFromTokens toksb (sspanStart,ssStart)
m'' = mkTreeListFromTokens toksm (ssStart,ssEnd)
e'' = mkTreeListFromTokens tokse (ssEnd,sspanEnd)
(False,True) -> (b'',m'',e'') -- End only
where
(_,toksm,tokse) = splitToks (forestSpanToSimpPos (nullPos,sspanEnd)) toks
b'' = []
m'' = let -- If the last span is changed, make sure it stays
-- as it was
tl = mkTreeListFromTokens toksm (ssStart,sspanEnd)
tl' = if emptyList tl
then []
else [Node (Entry (st,sspanEnd) tk) []]
where [Node (Entry (st,_en) tk) []] = mkTreeListFromTokens toksm (ssStart,sspanEnd)
in
tl'
e'' = mkTreeListFromTokens tokse (sspanEnd,ssEnd)
(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 ::
Tree Entry -> ForestSpan
-> ([Tree Entry], [Tree Entry], [Tree Entry])
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)
-- ---------------------------------------------------------------------
-- | Removes a ForestSpan and its tokens from the forest.
removeSrcSpan :: Tree Entry -> ForestSpan
-> (Tree Entry,Tree Entry) -- ^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
eg = calcEndGap forest' sspan
pt = Z.tree zp
-- subTree = filter (\t -> not (treeStartEnd t == sspan)) $ subForest pt
subTree = map (\t -> if (treeStartEnd t == sspan) then (Node (Deleted sspan eg) []) else t) $ subForest pt
z' = Z.setTree (pt { subForest = subTree}) zp
forest'' = Z.toTree z'
-- forest'' = error $ "removeSrcSpan: initial tree\n" ++ (drawTreeEntry forest) -- ++AZ++
-- forest'' = error $ "removeSrcSpan: after insertSrcSpan\n" ++ (drawTreeEntry forest') -- ++AZ++
delTree = Z.tree z
-- ---------------------------------------------------------------------
-- |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 :: Tree Entry -> 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 emptyList after
then (spanRow + 2,spanCol)
else (r,c)
where
(r,c) = case ghead ("calcEndGap:after="++(show after)) after of
(Entry _ toks) -> (tokenRow t,tokenCol t)
where t = ghead "calcEndGap" toks
(Deleted ss _) -> fst $ forestSpanToSimpPos ss
gap = (tokRow - spanRow, tokCol - spanCol)
-- gap = error $ "calcEndGap: (sspan,(before,middle,after))=" ++ (show (sspan,(_before,middle,after)))
-- ---------------------------------------------------------------------
-- |Retrieve all the tokens at the leaves of the tree, in order.
-- Marked tokens are re-aligned, and gaps are closed.
retrieveTokensFinal :: Tree Entry -> [PosToken]
retrieveTokensFinal forest = stripForestLines $ monotonicLineToks $ reAlignMarked
$ deleteGapsToks $ retrieveTokens' forest
-- ---------------------------------------------------------------------
-- |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 :: Tree Entry -> [PosToken]
retrieveTokensInterim forest = stripForestLines $ monotonicLineToks {- reAlignMarked -}
$ concat $ map (\t -> F.foldl accum [] t) [forest]
where
accum :: [PosToken] -> Entry -> [PosToken]
accum acc (Entry _ []) = acc
accum acc (Entry _ toks) = acc ++ toks
accum acc (Deleted _ _) = acc
retrieveTokens' :: Tree Entry -> [Entry]
retrieveTokens' forest = mergeDeletes $ concat $ map (\t -> F.foldl accum [] t) [forest]
where
accum :: [Entry] -> Entry -> [Entry]
accum acc (Entry _ []) = acc
accum acc e@(Entry _ _toks) = acc ++ [e]
accum acc e@(Deleted _ _) = acc ++ [e]
-- |Merge adjacent Deleted entries
mergeDeletes :: [Entry] -> [Entry]
mergeDeletes [] = []
mergeDeletes [x] = [x]
mergeDeletes ((Deleted ss1 (r1,_)):(Deleted ss2 (r2,c2)):xs) = (Deleted ss o):xs
where
(start,_) = ss1
(_, end) = ss2
ss = (start,end)
o = (r1+r2,c2)
mergeDeletes (x:xs) = x:mergeDeletes xs
-- ---------------------------------------------------------------------
-- | Process the leaf nodes of a tree to remove all deleted spans
deleteGapsToks :: [Entry] -> [PosToken]
deleteGapsToks toks = goDeleteGapsToks (0,0) toks
goDeleteGapsToks :: SimpPos -> [Entry] -> [PosToken]
goDeleteGapsToks _ [] = []
goDeleteGapsToks offset [Entry _ t] = map (increaseSrcSpan offset) t
goDeleteGapsToks _ [Deleted _ _] = []
goDeleteGapsToks offset (Deleted _ _:ts) = goDeleteGapsToks offset ts
goDeleteGapsToks offset [Entry _ t,Deleted _ _] = map (increaseSrcSpan offset) t
goDeleteGapsToks offset (Entry _ t1:e@(Entry _ _):ts) = (map (increaseSrcSpan offset) t1) ++goDeleteGapsToks offset (e:ts)
goDeleteGapsToks (fr,fc) (Entry ss t1:Deleted _ eg:t2:ts)
= t1' ++ goDeleteGapsToks offset' (t2:ts)
where
-- TODO: use actual first and last toks, may be comments
-- TODO: what about deletion within a line?
(deltaR,_deltaC) = eg
(_,(sr,_sc)) = forestSpanToSimpPos ss
((dr,_dc),_) = forestSpanToSimpPos $ forestSpanFromEntry t2
offset' = if deltaR > 0
then (fr + (sr - dr) + deltaR, fc)
else (fr + (sr - dr) + deltaR, fc)
-- offset' = (fr + sr - dr + 1, fc)
t1' = map (increaseSrcSpan (fr,fc)) t1
--
-- | Process the leaf nodes of a tree to remove all deleted spans
deleteGapsToks' :: [Entry] -> [(SimpPos,String,ForestSpan,[PosToken])]
deleteGapsToks' toks = goDeleteGapsToks' (0,0) toks
goDeleteGapsToks' :: SimpPos -> [Entry] -> [(SimpPos,String,ForestSpan,[PosToken])]
goDeleteGapsToks' _ [] = [((0,0), "N",nullSpan, [])]
goDeleteGapsToks' offset [Entry ss t] = [(offset,"E1",ss,map (increaseSrcSpan offset) t)]
goDeleteGapsToks' _ [Deleted _ _] = [((0,0), "D1",nullSpan, [])]
goDeleteGapsToks' offset (Deleted _ _:ts) = (offset, "D0",nullSpan, []):goDeleteGapsToks' offset ts
goDeleteGapsToks' offset [Entry ss t,Deleted _ _] = [(offset,"[ED]",ss,map (increaseSrcSpan offset) t)]
goDeleteGapsToks' offset (Entry ss t1:e@(Entry _ _):ts) =(offset,"EE", ss, (map (increaseSrcSpan offset) t1)):goDeleteGapsToks' offset (e:ts)
goDeleteGapsToks' (fr,fc) (Entry ss t1:Deleted _ _:t2:ts)
= ((fr,fc),"ED",ss,t1') : goDeleteGapsToks' offset' (t2:ts)
where
-- TODO: use actual first and last toks, may be comments
-- TODO: what about deletion within a line?
(_,(sr,_sc)) = forestSpanToSimpPos ss
((dr,_dc),_) = forestSpanToSimpPos $ forestSpanFromEntry t2
offset' = (fr + sr - dr + 2, fc)
-- offset' = (fr + sr - dr + 1, fc)
t1' = map (increaseSrcSpan (fr,fc)) t1
--
-- ---------------------------------------------------------------------
-- |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 :: Z.TreePos Z.Full Entry -> ReversedToks
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
res' = reverse $ (concat (go z)) ++ prevToks
-- res' = (reverse prevToks) ++ (concat (go z))
-- res' = error $ "retrievePrevLineToks:res'=" ++ (show (dropWhile (\tok -> isWhiteSpace tok || tokenRow tok < endLine) res))
-- res' = error $ "retrievePrevLineToks:prevToks=" ++ (show prevToks)
-- res' = error $ "retrievePrevLineToks:prevToks=" ++ (show res)
-- res' = error $ "retrievePrevLineToks:(prevToks : (go z))=" ++ (show (prevToks : (go z)))
-- TODO: ++AZ++ what is this actually doing?
go :: Z.TreePos Z.Full Entry -> [[PosToken]]
go zz
| not (Z.isRoot zz) = toks : (go $ gfromJust "retrievePrevLineToks" (Z.parent zz))
| otherwise = [toks]
where
toks = concat $ reverse $ map retrieveTokensInterim $ Z.before zz
-- toks = concat $ map retrieveTokensInterim $ Z.before zz
-- ---------------------------------------------------------------------
stripForestLines :: [PosToken] -> [PosToken]
stripForestLines toks = map doOne toks
where
doOne (GHC.L l t,s) = (GHC.L l' t,s)
where
((ForestLine _ _ _ ls,_),(_,_)) = srcSpanToForestSpan l
l' = insertForestLineInSrcSpan (ForestLine False 0 0 ls) l
-- ---------------------------------------------------------------------
reAlignMarked :: [PosToken] -> [PosToken]
reAlignMarked toks = concatMap alignOne $ groupTokensByLine toks
where
-- alignOne toksl = unmarked ++ (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 :: [PosToken] -> [PosToken]
reAlignOneLine toks = go (0,0) toks
where
go _ [] = []
go (l,c) (t:ts) = (increaseSrcSpan (l,c) t') : (go (l,c') ts)
where
(t',dc) = adjustToken t
c' = c + dc
adjustToken tt@(_,"") = (tt,0)
adjustToken tt@(lt@(GHC.L _ t),s) = ((GHC.L newL t,s),deltac)
where
(sl,sc) = getLocatedStart lt
(el,ec) = getLocatedEnd lt
deltac = (length s) - (ec - sc)
filename = fileNameFromTok tt
newL = GHC.mkSrcSpan (GHC.mkSrcLoc filename sl sc)
(GHC.mkSrcLoc filename el (ec + deltac))
reAlignToks :: [PosToken] -> [PosToken]
reAlignToks [] = []
reAlignToks [t] = [t]
reAlignToks (tok1@(_,""):ts) = tok1 : reAlignToks ts
reAlignToks (tok1@((GHC.L l1 _t1),_s1):tok2@((GHC.L l2 t2),s2):ts)
= tok1:reAlignToks (tok2':ts)
where
((_sr1,_sc1),(er1,ec1)) = (getGhcLoc l1,getGhcLocEnd l1)
(( sr2, sc2),(er2,ec2)) = (getGhcLoc l2,getGhcLocEnd l2)
((sr,sc),(er,ec)) = if (er1 == sr2 && ec1 >= sc2)
then ((sr2,ec1+1),(er2,ec1+1 + tokenLen tok2))
else ((sr2,sc2),(er2,ec2))
fname = case l2 of
GHC.RealSrcSpan ss -> GHC.srcSpanFile ss
_ -> GHC.mkFastString "foo"
l2' = GHC.mkRealSrcSpan (GHC.mkRealSrcLoc fname sr sc)
(GHC.mkRealSrcLoc fname er ec)
tok2' = ((GHC.L (GHC.RealSrcSpan l2') t2),s2)
-- ---------------------------------------------------------------------
-- |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 ::
Tree Entry -- ^The forest to update
-> GHC.SrcSpan -- ^The new span comes after this one
-> GHC.SrcSpan -- ^Existing span for the tokens
-> Positioning
-> [PosToken] -- ^The new tokens belonging to the new SrcSpan
-> (Tree Entry -- Updated forest with the new span
, GHC.SrcSpan) -- ^Unique SrcSpan allocated in the forest to
-- identify this span in its position
addNewSrcSpanAndToksAfter forest oldSpan newSpan pos toks = (forest'',newSpan')
where
(forest',tree) = getSrcSpanFor forest (srcSpanToForestSpan oldSpan)
(ghcl,_c) = getGhcLoc newSpan
(ForestLine ch tr v l) = ghcLineToForestLine ghcl
newSpan' = insertForestLineInSrcSpan (ForestLine ch tr (v+1) l) newSpan
toks' = placeToksForSpan forest' oldSpan tree pos toks
newNode = Node (Entry (srcSpanToForestSpan newSpan') toks') []
forest'' = insertNodeAfter tree newNode forest'
-- ---------------------------------------------------------------------
placeToksForSpan ::
Tree Entry
-> GHC.SrcSpan
-> Tree Entry
-> Positioning
-> [PosToken]
-> [PosToken]
placeToksForSpan forest oldSpan tree pos toks = toks'
where
z = openZipperToSpan (srcSpanToForestSpan oldSpan) $ Z.fromTree forest
prevToks = case (retrievePrevLineToks z) of
RT [] -> reverseToks $ retrieveTokensInterim tree
xs -> xs
prevToks' = limitPrevToks prevToks oldSpan
toks' = reIndentToks pos (unReverseToks prevToks') toks
-- toks' = error $ "placeToksForSpan: prevToks'=" ++ (show prevToks')
-- toks' = error $ "placeToksForSpan: prevToks=" ++ (show prevToks)
-- ---------------------------------------------------------------------
-- |Add new tokens after the given SrcSpan, constructing a new SrcSpan
-- in the process
addToksAfterSrcSpan ::
Tree Entry -- ^TokenTree to be modified
-> GHC.SrcSpan -- ^Preceding location for new tokens
-> Positioning
-> [PosToken] -- ^New tokens to be added
-> (Tree Entry, GHC.SrcSpan) -- ^ updated TokenTree and SrcSpan location for
-- the new tokens in the TokenTree
addToksAfterSrcSpan forest oldSpan pos toks = (forest',newSpan')
where
(fwithspan,tree) = getSrcSpanFor forest (srcSpanToForestSpan oldSpan)
toks'' = placeToksForSpan fwithspan oldSpan tree pos toks
(startPos,endPos) = nonCommentSpan toks''
newSpan = posToSrcSpan forest (startPos,endPos)
(forest',newSpan') = addNewSrcSpanAndToksAfter forest oldSpan newSpan pos toks
-- ---------------------------------------------------------------------
limitPrevToks :: ReversedToks -> GHC.SrcSpan -> ReversedToks
limitPrevToks prevToks sspan = reverseToks prevToks''
where
((ForestLine _ _ _ startRow,_startCol),(ForestLine _ _ _ endRow,_)) = srcSpanToForestSpan sspan
-- 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 belonging to an AST fragment after a given SrcSpan,
-- and re-sync the AST fragment to match the new location
addDeclToksAfterSrcSpan :: (SYB.Data t) =>
Tree Entry -- ^TokenTree to be modified
-> GHC.SrcSpan -- ^Preceding location for new tokens
-> Positioning
-> [PosToken] -- ^New tokens to be added
-> GHC.Located t -- ^Declaration the tokens belong to, to be synced
-> (Tree Entry, GHC.SrcSpan,GHC.Located t) -- ^ updated TokenTree ,SrcSpan location for
-- -> (Tree Entry, GHC.SrcSpan,t) -- ^ updated TokenTree ,SrcSpan location for
-- the new tokens in the TokenTree, and
-- updated AST element
addDeclToksAfterSrcSpan forest oldSpan pos toks t = (forest'',newSpan,t')
where
(forest',newSpan) = addToksAfterSrcSpan forest oldSpan pos toks
(t',forest'') = syncAST t newSpan forest'
-- ---------------------------------------------------------------------
reIndentToks :: Positioning -> [PosToken] -> [PosToken] -> [PosToken]
reIndentToks _ _ [] = []
reIndentToks pos prevToks toks = toks''
-- = error $ "reIndentToks:(pos,prevToks)=" ++ (show (pos,prevToks)) -- ++AZ++
-- = error $ "reIndentToks:((isComment lastTok),(tokenRow lastNonCommentTok),lastTokEndLine)=" ++ (show ((isComment lastTok),(tokenRow lastNonCommentTok),lastTokEndLine))
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 isWhiteSpace prevToks
-- colStart = prevOffset
-- colStart = error $ "reIndentToks:prevToks=" ++ (show prevToks)
lineStart = (tokenRow (lastTok)) -- + 1
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 -- ++AZ++ Why +1?
toks' = addOffsetToToks (lineOffset,colOffset) toks
toks'' = if endNewlines > 0
then toks' ++ [(newLinesToken endNewlines $ glast "reIndentToks.3" toks')]
else toks'
-- ---------------------------------------------------------------------
-- |Extract the start and end position of a span, without any leading
-- or trailing comments
nonCommentSpan :: [PosToken] -> (SimpPos,SimpPos)
nonCommentSpan [] = ((0,0),(0,0))
nonCommentSpan toks = (startPos,endPos)
where
stripped = dropWhile isWhiteSpace $ toks
(startPos,endPos) = case stripped of
[] -> ((0,0),(0,0))
_ -> (tokenPos startTok,tokenPosEnd endTok)
where
startTok = ghead "nonCommentSpan.1" $ dropWhile isWhiteSpace $ toks
endTok = ghead "nonCommentSpan.2" $ dropWhile isWhiteSpace $ reverse toks
-- ---------------------------------------------------------------------
-- |Convert a simple (start,end) position to a SrcSpan belonging to
-- the file in the tree
posToSrcSpan :: Tree Entry -> (SimpPos,SimpPos) -> GHC.SrcSpan
posToSrcSpan forest ((rs,cs),(re,ce)) = sspan
where
(GHC.L l _,_) = ghead "posToSrcSpan" $ retrieveTokensInterim forest -- ++AZ++ Ouch, performance??
sspan = case l of
GHC.RealSrcSpan ss ->
let
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) rs cs
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) re ce
in
GHC.mkSrcSpan locStart locEnd
_ -> error "posToSrcSpan: invalid SrcSpan in first tok"
-- ---------------------------------------------------------------------
-- |Convert a simple (start,end) position to a SrcSpan belonging to
-- the file in the given token
posToSrcSpanTok :: PosToken -> (SimpPos,SimpPos) -> GHC.SrcSpan
posToSrcSpanTok tok ((rs,cs),(re,ce)) = sspan
where
(GHC.L l _,_) = tok
sspan = case l of
GHC.RealSrcSpan ss ->
let
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) rs cs
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) re ce
in
GHC.mkSrcSpan locStart locEnd
_ -> error "posToSrcSpan: invalid SrcSpan in first tok"
-- ---------------------------------------------------------------------
-- |Insert a new node after the designated one in the tree
insertNodeAfter
:: Tree Entry -> Tree Entry -> Tree Entry -> Tree Entry
insertNodeAfter oldNode newNode forest = forest'
where
zf = openZipperToNode oldNode $ Z.fromTree forest
-- zp = gfromJust "insertNodeAfter" $ Z.parent zf
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
:: Tree Entry
-> Z.TreePos Z.Full Entry
-> Z.TreePos Z.Full Entry
openZipperToNode (Node (Entry sspan _) _) z
= openZipperToSpan 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)
-- ---------------------------------------------------------------------
-- |Does the first span contain the second? Takes cognisance of the
-- various flags a ForestSpan can have.
-- NOTE: This function relies on the Eq instance for ForestLine
spanContains :: ForestSpan -> ForestSpan -> Bool
spanContains span1 span2 = (startPos <= nodeStart && endPos >= nodeEnd)
where
-- TODO: This looks like a no-op?
(tvs,_tve) = forestSpanVersions $ span1
(nvs,_nve) = forestSpanVersions $ span2
(startPos,endPos) = insertVersionsInForestSpan tvs tvs span1
(nodeStart,nodeEnd) = insertVersionsInForestSpan nvs nvs span2
-- ---------------------------------------------------------------------
-- |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
:: ForestSpan
-> Z.TreePos Z.Full Entry
-> Z.TreePos Z.Full Entry
openZipperToSpan 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
-- ---------------------------------------------------------------------
-- |Split a forest of trees into a (begin,middle,end) according to a
-- ForestSpan, such that no tokens are included in begin or end belonging
-- to the ForestSpan, and all of middle has some part of the ForestSpan
splitForestOnSpan :: Forest Entry -> ForestSpan
-> ([Tree Entry],[Tree Entry],[Tree Entry])
splitForestOnSpan forest sspan = (beginTrees,middleTrees,endTrees)
where
(spanStart,spanEnd) = sspan
(beginTrees,rest) = break (\t -> not $ inBeginTrees t) forest
(middleTrees,endTrees) = break (\t -> inEndTrees t) rest
inBeginTrees tree = spanStart >= treeEnd
where
(_treeStart,treeEnd) = treeStartEnd tree
inEndTrees tree = spanEnd <= treeStart
where
(treeStart,_treeEnd) = treeStartEnd tree
{-
examples
forest = [((1,1),(10,5)), ((100001,1),(10,5)), ((11,1),(14,3))]
sspan = ((10,1),(11,5))
Should bring all of them
Can we use starts only?
Or, work from the front for begin, checking starts only, and back
for end checking ends only
-}
-- ---------------------------------------------------------------------
{-
-- | Look a SrcSpan up in the forest.
-- There are three possibilities
-- 1. It is not there
-- 2. It is there, exactly
-- 3. It is not there exactly, but is a sub-element of something that
-- is there. In this case return the smallest containing element.
-- This may be a list of trees, if the desired span crosses multiple
-- trees.
lookupSrcSpan :: Forest Entry -> ForestSpan -> [Tree Entry]
lookupSrcSpan forest sspan = res
where
-- Assuming invariants hold, the forest is sorted,
-- So, move through trees until ones containing the span are
-- found.
-- If it is contained in a single tree, drill into it to find the
-- smallest set of trees containing the span
(_,middle,_) = splitForestOnSpan forest sspan
res = case middle of
[Node _ []] -> middle
[Node _ sub] -> lookupSrcSpan sub sspan
_ -> middle
-}
-- ---------------------------------------------------------------------
-- |Utility function to either return True or throw an error to report the problem
invariantOk :: Tree Entry -> 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 nullSpan 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 :: Tree Entry -> [String]
invariant forest = rsub
where
rsub = F.foldl checkOneTree [] [forest]
checkOneTree :: [String] -> Tree Entry -> [String]
checkOneTree acc tree = acc ++ r
where
r = checkNode [] tree
checkNode :: [String] -> Tree Entry -> [String]
checkNode _acc (Node (Deleted _sspan _) []) = []
checkNode _acc node@(Node (Deleted _sspan _) _sub)
= ["FAIL: deleted node with subtree: " ++ (prettyshow node)]
checkNode acc node@(Node (Entry sspan toks) sub) = acc ++ r ++ rinc ++ rsubs ++ rnull
where
r = if ( emptyList toks && nonEmptyList sub) ||
(nonEmptyList toks && emptyList sub)
then []
else ["FAIL: exactly one of toks or subforest must be empty: " ++ (prettyshow node)]
rsubs = foldl' checkNode [] sub
rinc = checkInclusion node
rnull = if (sspan == nullSpan)
then ["FAIL: null SrcSpan in tree: " ++ (prettyshow node)]
else []
-- |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@(Node (Entry _sspan _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))
then []
else ["FAIL: subForest start and end does not match entry: " ++ (prettyshow node)]
rseq = checkSequence node subs
checkSequence :: Tree Entry -> [ForestSpan] -> [String]
checkSequence _ [] = []
checkSequence _ [_x] = []
checkSequence node' ((_s1,e1):s@(s2,_e2):ss)
= r ++ checkSequence node' (s:ss)
where
-- r = if 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
-}
-- ---------------------------------------------------------------------
-- |Get the start and end position of a Tree
-- treeStartEnd :: Tree Entry -> (SimpPos,SimpPos)
-- treeStartEnd (Node (Entry sspan _) _) = (getGhcLoc sspan,getGhcLocEnd sspan)
treeStartEnd :: Tree Entry -> ForestSpan
treeStartEnd (Node (Entry sspan _ ) _) = sspan
treeStartEnd (Node (Deleted sspan _) _) = sspan
-- |Get the start and end position of a SrcSpan
-- spanStartEnd :: GHC.SrcSpan -> (SimpPos,SimpPos)
-- spanStartEnd sspan = (getGhcLoc sspan,getGhcLocEnd sspan)
spanStartEnd :: GHC.SrcSpan -> ForestSpan
spanStartEnd sspan = ((ghcLineToForestLine sr,sc),(ghcLineToForestLine er,ec))
where
((sr,sc),(er,ec)) = (getGhcLoc sspan,getGhcLocEnd sspan)
-- ---------------------------------------------------------------------
{-
-- showForest :: Forest Entry -> String
showForest forest = map (showSubTree 0) forest
where
-- showSubTree :: Int -> Tree Entry -> String
showSubTree indent tree@(Node (Entry sspan toks mp) sub)
= (take indent (repeat ' '))
++ (show (getGhcLoc sspan, getGhcLocEnd sspan)) ++ " "
++ (case toks of
[] -> showSubTree (indent+2) sub
_ -> "toks")
-}
showForest :: [Tree Entry] -> [String]
showForest forest = map showTree forest
-- ---------------------------------------------------------------------
-- |Call drawTreeEntry on the entire token cache
drawTokenCache :: TokenCache -> String
drawTokenCache tk = Map.foldlWithKey' doOne "" (tkCache tk)
where
doOne :: String -> TreeId -> Tree Entry -> String
doOne s key val = s ++ "tree " ++ (show key) ++ ":\n"
++ (drawTreeEntry val)
-- ---------------------------------------------------------------------
-- |Call drawTreeEntry on the entire token cache
drawTokenCacheDetailed :: TokenCache -> String
drawTokenCacheDetailed tk = Map.foldlWithKey' doOne "" (tkCache tk)
where
doOne :: String -> TreeId -> Tree Entry -> String
doOne s key val = s ++ "tree " ++ (show key) ++ ":\n"
++ (show val)
-- ---------------------------------------------------------------------
-- | Neat 2-dimensional drawing of a tree.
drawTreeEntry :: Tree Entry -> String
drawTreeEntry = unlines . drawEntry
-- | Neat 2-dimensional drawing of a forest.
drawForestEntry :: Forest Entry -> String
drawForestEntry = unlines . map drawTreeEntry
drawEntry :: Tree Entry -> [String]
drawEntry (Node (Deleted sspan eg ) _ ) = [(showForestSpan sspan) ++ (show eg) ++ "D"]
drawEntry (Node (Entry sspan _toks) ts0) = (showForestSpan sspan) : drawSubTrees ts0
where
drawSubTrees [] = []
drawSubTrees [t] =
"|" : shft "`- " " " (drawEntry t)
drawSubTrees (t:ts) =
"|" : shft "+- " "| " (drawEntry t) ++ drawSubTrees ts
shft first other = zipWith (++) (first : repeat other)
-- ---------------------------------------------------------------------
showTree :: Tree Entry -> String
showTree = prettyshow
-- |Represent a tree in a more concise/pretty way
prettyshow :: Tree Entry -> String
prettyshow (Node (Deleted sspan eg) [])
= "Node (Deleted " ++ (showForestSpan sspan) ++ " " ++ (show eg) ++ ")"
prettyshow (Node (Entry sspan toks) sub)
= "Node (Entry " ++ (showForestSpan sspan) ++ " "
++ (prettyToks toks) ++ ") "
++ show (map prettyshow sub)
prettyToks :: [PosToken] -> String
prettyToks [] = "[]"
prettyToks toks@[_x] = showToks toks
prettyToks toks@[_t1,_t2] = showToks toks
prettyToks toks = showToks [ghead "prettyToks" toks] ++ ".." ++ showToks [last toks]
-- ---------------------------------------------------------------------
-- |Make a tree representing a particular set of tokens
mkTreeFromTokens :: [PosToken] -> Tree Entry
mkTreeFromTokens [] = Node (Entry nullSpan []) []
mkTreeFromTokens toks = Node (Entry sspan toks) []
where
-- startLoc = tokenPos $ ghead "mkTreeFromTokens" toks
-- endLoc = tokenPosEnd $ last toks -- SrcSpans count from start of token, not end
-- sspan = GHC.RealSrcSpan $ GHC.mkRealSrcSpan startLoc endLoc
(startLoc',endLoc') = nonCommentSpan toks
sspan = simpPosToForestSpan (startLoc',endLoc')
-- ---------------------------------------------------------------------
-- |Make a tree representing a particular set of tokens
mkTreeFromSpanTokens :: ForestSpan -> [PosToken] -> Tree Entry
mkTreeFromSpanTokens sspan toks = Node (Entry sspan toks) []
-- ---------------------------------------------------------------------
ghcSpanStartEnd :: GHC.SrcSpan -> ((Int, Int), (Int, Int))
ghcSpanStartEnd sspan = (getGhcLoc sspan,getGhcLocEnd sspan)
-- ---------------------------------------------------------------------
-- |Synchronise a located AST fragment to use a newly created SrcSpan
-- in the token tree.
syncAST :: (SYB.Data t)
=> GHC.Located t -- ^The AST (or fragment)
-- => t -- ^The AST (or fragment)
-> GHC.SrcSpan -- ^The SrcSpan created in the Tree Entry
-> Tree Entry -- ^Existing token tree
-> (GHC.Located t, Tree Entry) -- ^Updated AST and tokens
-- -> (t, Tree Entry) -- ^Updated AST and tokens
-- syncAST (GHC.L _l t) sspan forest = (ast',forest')
syncAST ast@(GHC.L l _t) sspan forest = (GHC.L sspan xx,forest')
where
forest' = forest
((ForestLine _ _ _ startRow,startCol),_) = srcSpanToForestSpan l
((ForestLine _ _ _ newStartRow,newStartCol),_) = srcSpanToForestSpan sspan
(( sr, sc),( _er, _ec)) = ghcSpanStartEnd l
((nsr,nsc),(_ner,_nec)) = ghcSpanStartEnd sspan
rowOffset = nsr - sr
colOffset = nsc - sc
rowOffset' = newStartRow - startRow
colOffset' = newStartCol - startCol
-- TODO: take cognizance of the ForestLines encoded in srcspans
-- when calculating the offsets etc
syncSpan s = addOffsetToSpan (rowOffset,colOffset) s
syncSpan' s = addOffsetToSpan (rowOffset',colOffset') s
-- syncSpan s = s
(GHC.L _s xx) = everywhereStaged SYB.Renamer (
SYB.mkT hsbindlr
`SYB.extT` sig
`SYB.extT` ty
`SYB.extT` name
`SYB.extT` lhsexpr
`SYB.extT` lpat
`SYB.extT` limportdecl
) ast
hsbindlr (GHC.L s b) = (GHC.L (syncSpan s) b) :: GHC.Located (GHC.HsBindLR GHC.Name GHC.Name)
sig (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.LSig GHC.Name
ty (GHC.L s typ) = (GHC.L (syncSpan s) typ) :: (GHC.LHsType GHC.Name)
-- TODO: ++AZ++ this is horrible, ad hoc: syncSpan'
--name (GHC.L s n) = (GHC.L (syncSpan' s) n) :: GHC.Located GHC.Name
name (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.Located GHC.Name
lhsexpr (GHC.L s e) = (GHC.L (syncSpan s) e) :: GHC.LHsExpr GHC.Name
lpat (GHC.L s p) = (GHC.L (syncSpan s) p) :: GHC.LPat GHC.Name
limportdecl (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.LImportDecl GHC.Name
-- ---------------------------------------------------------------------
addOffsetToSpan :: (Int,Int) -> GHC.SrcSpan -> GHC.SrcSpan
addOffsetToSpan (lineOffset,colOffset) sspan = sspan'
where
sspan' = case sspan of
GHC.RealSrcSpan ss ->
let
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) (lineOffset + GHC.srcSpanStartLine ss) (colOffset + GHC.srcSpanStartCol ss)
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) (lineOffset + GHC.srcSpanEndLine ss) (colOffset + GHC.srcSpanEndCol ss)
in
GHC.mkSrcSpan locStart locEnd
_ -> sspan
-- ---------------------------------------------------------------------
showSrcSpan :: GHC.SrcSpan -> String
showSrcSpan sspan = show (getGhcLoc sspan, (r,c))
where
(r,c) = getGhcLocEnd sspan
showSrcSpanF :: GHC.SrcSpan -> String
showSrcSpanF sspan = show (((chs,trs,vs,ls),cs),((che,tre,ve,le),ce))
where
((ForestLine chs trs vs ls,cs),(ForestLine che tre ve le,ce)) = srcSpanToForestSpan sspan
-- chsn = if chs then 1 else 0
-- chen = if che then 1 else 0
-- ---------------------------------------------------------------------
-- EOF