{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# 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( -- * Creating initTokenCache , initTokenCacheLayout , mkTreeFromTokens , mkTreeFromSpanTokens -- * Operations at 'TokenCache' level , putToksInCache , putDeclToksInCache , replaceTokenInCache , removeToksFromCache , getTreeFromCache , replaceTreeInCache , syncAstToLatestCache -- * Operations at 'Tree' 'Entry' level , getTokensFor , getTokensForNoIntros , getTokensBefore , replaceTokenForSrcSpan , updateTokensForSrcSpan , insertSrcSpan , removeSrcSpan , getSrcSpanFor , getSrcSpanForDeep , addNewSrcSpanAndToksAfter , addToksAfterSrcSpan , addDeclToksAfterSrcSpan , syncAST , indentDeclToks , Positioning(..) -- * Retrieving tokens , retrieveTokensFinal -- , retrieveTokensPpr -- , renderPpr , adjustLinesForDeleted , retrieveTokensInterim , retrieveTokens' -- temporary for debug -- * Token Tree Selection , treeIdFromForestSpan -- * Token marking and re-alignment , reAlignMarked -- * Utility , posToSrcSpan , posToSrcSpanTok , fileNameFromTok , treeStartEnd , spanStartEnd , sf , fs , forestSpanFromEntry , combineSpans -- * A token stream with last tokens first, and functions to manipulate it , ReversedToks(..) , reverseToks , unReverseToks , reversedToks -- * Internal, for testing , placeToksForSpan , limitPrevToks , reIndentToks , reAlignOneLine , reAlignToks , splitForestOnSpan , spanContains , containsStart, containsMiddle, containsEnd , doSplitTree, splitSubtree, splitSubToks , nonCommentSpan -- , lookupSrcSpan , invariantOk , invariant , showForest , showTree , showSrcSpan , showSrcSpanF , ghcSpanStartEnd , insertNodeAfter , retrievePrevLineToks , getTreeSpansAsList , openZipperToNode , openZipperToNodeDeep , openZipperToSpan , openZipperToSpanDeep , openZipperToSpanAdded , openZipperToSpanOrig , forestSpanToSimpPos , forestSpanToGhcPos , ghcLineToForestLine , stripForestLineFromGhc , 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 , drawTreeCompact ) where import qualified FastString as GHC import qualified GHC as GHC import qualified SrcLoc as GHC import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB import qualified Data.Foldable as F import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.LayoutTypes import Language.Haskell.Refact.Utils.LocUtils import Language.Haskell.Refact.Utils.TokenUtilsTypes import Language.Haskell.Refact.Utils.TypeSyn import 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 instance Ord LayoutTree where compare (Node a _) (Node b _) = compare (forestSpanFromEntry a) (forestSpanFromEntry b) instance Eq Entry where (Entry fs1 lay1 toks1) == (Entry fs2 lay2 toks2) = fs1 == fs2 && lay1 == lay2 && (show toks1) == (show toks2) (Deleted fs1 pg1 lay1) == (Deleted fs2 pg2 lay2) = fs1 == fs2 && pg1 == pg2 && lay1 == lay2 (==) _ _ = False -- --------------------------------------------------------------------- -- |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) -- --------------------------------------------------------------------- -- | Replace any ForestLine flags already in a SrcSpan with the given ones insertForestLineInSrcSpan :: ForestLine -> GHC.SrcSpan -> GHC.SrcSpan insertForestLineInSrcSpan fl@(ForestLine ch tr v _l) (GHC.RealSrcSpan ss) = ss' where lineStart = forestLineToGhcLine fl (_,(ForestLine _ _ _ le,_)) = srcSpanToForestSpan (GHC.RealSrcSpan ss) lineEnd = forestLineToGhcLine (ForestLine ch tr v le) locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss) locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineEnd (GHC.srcSpanEndCol ss) ss' = GHC.mkSrcSpan locStart locEnd insertForestLineInSrcSpan _ _ss = error $ "insertForestLineInSrcSpan: expecting a RealSrcSpan, got:" -- ++ (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)) -- --------------------------------------------------------------------- insertLenChangedInForestSpan :: Bool -> ForestSpan -> ForestSpan insertLenChangedInForestSpan chNew ((ForestLine _chs trs vs ls,cs),(ForestLine _che tre ve le,ce)) = ((ForestLine chNew trs vs ls,cs),(ForestLine chNew tre ve le,ce)) -- --------------------------------------------------------------------- srcSpanToForestSpan :: GHC.SrcSpan -> ForestSpan srcSpanToForestSpan sspan = ((ghcLineToForestLine startRow,startCol),(ghcLineToForestLine endRow,endCol)) where (startRow,startCol) = getGhcLoc sspan (endRow,endCol) = getGhcLocEnd sspan -- -------------------------------------------------------------------- forestSpanFromEntry :: Entry -> ForestSpan forestSpanFromEntry (Entry ss _ _) = ss forestSpanFromEntry (Deleted ss _ _) = ss putForestSpanInEntry :: Entry -> ForestSpan -> Entry putForestSpanInEntry (Entry _ss lay toks) ssnew = (Entry ssnew lay toks) putForestSpanInEntry (Deleted _ss pg eg) ssnew = (Deleted ssnew pg eg) -- -------------------------------------------------------------------- treeIdFromForestSpan :: ForestSpan -> TreeId treeIdFromForestSpan ((ForestLine _ tr _ _,_),(ForestLine _ _ _ _,_)) = TId tr -- --------------------------------------------------------------------- {- 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) initTokenCacheLayout :: Tree Entry -> TokenCache initTokenCacheLayout tree = TK (Map.fromList [((TId 0),tree)]) (TId 0) -- --------------------------------------------------------------------- treeIdIntoTree :: TreeId -> Tree Entry -> Tree Entry treeIdIntoTree tid (Node (Entry fspan lay toks) subTree) = tree' where fs' = treeIdIntoForestSpan tid fspan tree' = Node (Entry fs' lay toks) subTree treeIdIntoTree tid (Node (Deleted fspan pg eg) subTree) = tree' where fs' = treeIdIntoForestSpan tid fspan tree' = Node (Deleted fs' pg eg) subTree -- --------------------------------------------------------------------- stash :: TokenCache -> Tree Entry -> TokenCache stash tk oldTree = tk' where (TId lastTreeId) = tkLastTreeId tk lastTreeId' = TId (lastTreeId + 1) oldTree' = treeIdIntoTree lastTreeId' oldTree cache' = Map.insert lastTreeId' oldTree' (tkCache tk) tk' = tk {tkLastTreeId = lastTreeId', tkCache = cache' } -- --------------------------------------------------------------------- replaceTokenInCache :: TokenCache -> GHC.SrcSpan -> PosToken -> TokenCache replaceTokenInCache tk sspan tok = tk' where forest = getTreeFromCache sspan tk forest' = replaceTokenForSrcSpan forest sspan tok tk' = replaceTreeInCache sspan forest' tk -- --------------------------------------------------------------------- putToksInCache :: TokenCache -> GHC.SrcSpan -> [PosToken] -> (TokenCache,GHC.SrcSpan) putToksInCache tk sspan toks = (tk'',newSpan) where forest = getTreeFromCache sspan tk (forest',newSpan,oldTree) = updateTokensForSrcSpan forest sspan toks tk' = replaceTreeInCache sspan forest' tk tk'' = stash tk' oldTree -- --------------------------------------------------------------------- putDeclToksInCache :: (SYB.Data t) => TokenCache -> GHC.SrcSpan -> [PosToken] -> GHC.Located t -> (TokenCache,GHC.SrcSpan,GHC.Located t) putDeclToksInCache tk sspan toks t = (tk'',newSpan,t') where forest = getTreeFromCache sspan tk (forest',newSpan,oldTree) = updateTokensForSrcSpan forest sspan toks (t',forest'') = syncAST t newSpan forest' 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 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' -- --------------------------------------------------------------------- -- |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 fspan _ _) _) = (tkCache tk) Map.! (tkLastTreeId tk) pos = forestSpanToGhcPos fspan 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. 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 (possible cached) tokens for a given source span, and -- cache their being fetched. -- NOTE: The SrcSpan may be one introduced by HaRe, rather than GHC. getTokensForNoIntros :: Bool -> Tree Entry -> GHC.SrcSpan -> (Tree Entry,[PosToken]) getTokensForNoIntros checkInvariant forest sspan = (forest', tokens') where (forest',tokens) = getTokensFor checkInvariant forest sspan -- (lead,rest) = break (not . isWhiteSpaceOrIgnored) tokens (lead,rest) = break (not . isIgnoredNonComment) tokens tokens' = (filter (not . isIgnored) lead) ++ rest -- --------------------------------------------------------------------- -- |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 -- TODO: work at the token level, not the sspan level -- TODO: Use start of token span only, with length 1. 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 = openZipperToSpanDeep (srcSpanToForestSpan sspan) $ Z.fromTree forest -- Then drill down to the specific subtree containing the token -- z' = openZipperToSpan (srcSpanToForestSpan tl) z z' = z -- No, pass in original token span as sspan. -- Note: with LayoutTree, the full tree matching the AST has been -- built, still need to drill down to the nearest enclosing span (tspan,lay,toks) = case Z.tree z' of (Node (Entry ss ly tks) []) -> (ss,ly,tks) (Node (Entry _ _ _nullToks) _sub) -> error $ "replaceTokenForSrcSpan:tok pos" ++ (showForestSpan $ sf sspan) ++ " expecting tokens, found: " ++ (show $ Z.tree z') (Node (Deleted _ _ _) _sub) -> error $ "replaceTokenForSrcSpan:tok pos" ++ (showForestSpan $ sf sspan) ++ " expecting Entry, found: " ++ (show $ Z.tree z') ((row,col),_) = forestSpanToSimpPos $ srcSpanToForestSpan tl toks' = replaceTokNoReAlign toks (row,col) tok zf = Z.setTree (Node (Entry tspan lay toks') []) z' forest' = Z.toTree zf -- 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 endComments = reverse $ takeWhile isWhiteSpaceOrIgnored $ reverse toks startComments = takeWhile isWhiteSpaceOrIgnored $ toks newTokStart = if (emptyList prevToks) then mkZeroToken else ghead "updateTokensForSrcSpan.1" prevToks toks'' = if (nonEmptyList startComments || nonEmptyList endComments) then -- 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 origEndComments = reverse $ takeWhile isWhiteSpaceOrIgnored $ reverse prevToks origStartComments = takeWhile isWhiteSpaceOrIgnored $ prevToks -- core = reIndentToks (PlaceAbsolute (tokenRow newTokStart) (tokenCol newTokStart)) prevToks toks ((startRow,startCol),_) = forestSpanToGhcPos $ srcSpanToForestSpan sspan core = reIndentToks (PlaceAbsolute startRow startCol) prevToks toks trail = if (emptyList origEndComments) then [] else addOffsetToToks (lineOffset,colOffset) origEndComments where lineOffset = 0 -- 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) NoChange 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 -- --------------------------------------------------------------------- -- |Retrieve a path to the tree containing a ForestSpan from the forest, -- inserting it if not already present. -- In the case where there is a nested series of spans as in an -- 'Above' layout, return the deepest one getSrcSpanForDeep :: Tree Entry -> ForestSpan -> (Tree Entry, Tree Entry) getSrcSpanForDeep forest sspan = (forest',tree) where forest' = insertSrcSpan forest sspan -- Will NO-OP if already -- there z = openZipperToSpanDeep sspan $ Z.fromTree forest' tree = Z.tree z -- --------------------------------------------------------------------- -- |Insert a ForestSpan into the forest, if it is not there already. -- Assumes the forest was populated with the tokens containing the -- ForestSpan already insertSrcSpan :: 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 error $ "insertSrcSpan:span not in tree " ++ show sspan else if (Z.isLeaf z) then -- TODO: This should be in splitSubToks let -- If we are at a leaf, retrieve the toks (Entry _ _ toks) = Z.label z (tokStartPos,tokEndPos) = forestSpanToSimpPos sspan -- Tokens here, must introduce sub-spans with split, taking -- cognizance of start and end comments -- TODO: does startEndLocIncComments' give the same boundary -- if approached from one side as the other? (startLoc,endLoc) = startEndLocIncComments' toks (tokStartPos,tokEndPos) (startToks,middleToks,endToks) = splitToks (startLoc,endLoc) toks -- tree1 = if (emptyList $ filter (\t -> not $ isEmpty t) startToks) tree1 = if (nonCommentSpan startToks == ((0,0),(0,0))) then [] else [mkTreeFromTokens startToks] tree2 = [mkTreeFromSpanTokens sspan middleToks] -- tree3 = if (emptyList $ filter (\t -> not $ isEmpty t) endToks) tree3 = if (nonCommentSpan endToks == ((0,0),(0,0))) then [] else [mkTreeFromTokens endToks] subTree = tree1 ++ tree2 ++ tree3 subTree' = filter (\t -> treeStartEnd t /= nullSpan) subTree (Entry sspan2 _ _) = Z.label z z' = Z.setTree (Node (Entry sspan2 NoChange []) subTree') z forest'' = Z.toTree z' in forest'' else let (before,middle,end) = doSplitTree (Z.tree z) sspan newTree = case middle of [x] -> x _xs -> (Node (Entry sspan NoChange []) middle) subTree' = before ++ [newTree] ++ end (Entry sspan2 _ _) = Z.label z z' = Z.setTree (Node (Entry sspan2 NoChange []) subTree') z forest'' = Z.toTree z' in forest'' -- 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) -- --------------------------------------------------------------------- -- TODO: The Bool is horrible mkTreeListFromTokens :: [PosToken] -> ForestSpan -> Bool -> [Tree Entry] mkTreeListFromTokens [] _sspan _ = [] mkTreeListFromTokens toks sspan useOriginalSpan = res where (Node (Entry tspan NoChange treeToks) sub) = mkTreeFromTokens toks ((ForestLine chs ts vs _, _),(ForestLine che te ve _, _)) = sspan ((ForestLine _ _ _ ls,cs),(ForestLine _ _ _ le,ce)) = tspan span' = ((ForestLine chs ts vs ls, cs),(ForestLine che te ve le, ce)) res = if nonCommentSpan toks == ((0,0),(0,0)) then [] else if useOriginalSpan then [(Node (Entry sspan NoChange treeToks) sub)] else [(Node (Entry span' NoChange treeToks) sub)] -- --------------------------------------------------------------------- splitSubToks :: Tree Entry -> (ForestPos, ForestPos) -> ([Tree Entry], [Tree Entry], [Tree Entry]) splitSubToks n@(Node (Deleted (treeStart,treeEnd) _pg _eg) []) (sspanStart,sspanEnd) = (b',m',e') where egs = (0,0) -- TODO: calculate this ege = (0,0) -- TODO: calculate this pg = 0 -- TODO: calculate this b' = if sspanStart > treeStart then [Node (Deleted (treeStart,treeStart) pg egs) []] else [] m' = [n] e' = if treeEnd > sspanEnd then [Node (Deleted (sspanEnd,treeEnd) pg ege) []] else [] splitSubToks tree sspan = (b',m',e') -- error $ "splitSubToks:(sspan,tree)=" ++ (show (sspan,tree)) where (Node (Entry ss@(treeStart,treeEnd) _lay toks) []) = tree (sspanStart,sspanEnd) = sspan -- TODO: ignoring comment boundaries to start -- There are three possibilities -- 1. The span starts only in these tokens -- 2. The span starts and ends in these tokens -- 3. The span ends only in these tokens (b',m',e') = case (containsStart ss sspan,containsEnd ss sspan) of (True, False) -> (b'',m'',e'') -- Start only -- error $ "splitSubToks:StartOnly:(sspan,tree,(b'',m''))=" ++ (show (sspan,tree,(b'',m''))) where (_,toksb,toksm) = splitToks (forestSpanToSimpPos (nullPos,sspanStart)) toks -- b'' = if (emptyList toksb) then [] else [Node (Entry (treeStart, sspanEnd) toksb) []] b'' = if (emptyList toksb || nonCommentSpan toksb == ((0,0),(0,0))) then [] else [mkTreeFromTokens toksb] -- Need to get end from actual toks m'' = let (ForestLine _ch _ts _v le,ce) = sspanEnd tl = if (treeStart == sspanStart) -- Eq does not compare all flags then mkTreeListFromTokens toksm (treeStart, treeEnd) False else mkTreeListFromTokens toksm (sspanStart,treeEnd) False _tl' = if emptyList tl then [] else [Node (Entry (st,(ForestLine ch ts v le,ce)) lay tk) []] where [Node (Entry (st,(ForestLine ch ts v _l,_c)) lay tk) []] = tl in -- tl' tl e'' = [] (True, True) -> (b'',m'',e'') -- Start and End where -- (toksb,toksm,tokse) = splitToks (forestSpanToSimpPos (treeStart,treeEnd)) toks (toksb,toksm,tokse) = splitToks (forestSpanToSimpPos (sspanStart,sspanEnd)) toks b'' = mkTreeListFromTokens toksb (treeStart, sspanStart) False m'' = mkTreeListFromTokens toksm (sspanStart, sspanEnd) True e'' = mkTreeListFromTokens tokse (sspanEnd, treeEnd) False (False,True) -> (b'',m'',e'') -- End only where (_,toksm,tokse) = splitToks (forestSpanToSimpPos (nullPos,sspanEnd)) toks b'' = [] m'' = let -- If the last span is changed, make sure it stays -- as it was tl = mkTreeListFromTokens toksm (treeStart,sspanEnd) False tl' = if emptyList tl then [] else [Node (Entry (st,sspanEnd) lay tk) []] where [Node (Entry (st,_en) lay tk) []] = mkTreeListFromTokens toksm (treeStart,sspanEnd) False in tl' e'' = mkTreeListFromTokens tokse (sspanEnd,treeEnd) False (False,False) -> if (containsMiddle ss sspan) then ([],[tree],[]) else error $ "splitSubToks: error (ss,sspan)=" ++ (show (ss,sspan)) -- --------------------------------------------------------------------- -- |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 {- pg = error $ "removeSrcSpan: need calcPriorGap" eg = calcEndGap forest' sspan -} ((pg,_),eg) = calcPriorAndEndGap 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 pg 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. calcPriorAndEndGap :: Tree Entry -> ForestSpan -> (SimpPos,SimpPos) calcPriorAndEndGap tree sspan = (pg,eg) where ((spanStartRow,spanStartCol),(spanRow,spanCol)) = forestSpanToSimpPos sspan (spanStart,spanEnd) = sspan entries = retrieveTokens' tree -- NOTE: the entries are the fringe of the tree, the sspan in -- question may be represented by several entries (before,rest) = span (\e -> (forestSpanStart $ forestSpanFromEntry e) < spanStart) entries (rafter,rmiddle) = break (\e -> (forestSpanEnd $ forestSpanFromEntry e) <= spanEnd) $ reverse rest _middle = reverse rmiddle after = reverse rafter -- last element of before should be the sspan we care about, first -- of after is the one we are looking for. -- NOTE: `after` may contain zero or more Deleted segments in the -- front. These get merged later in mergeDeletes (tokRow,tokCol) = if emptyList after then (spanRow + 2,spanCol) else (r,c) where (r,c) = case ghead ("calcEndGap:after="++(show after)) after of (Entry _ _ toks) -> (tokenRow t,tokenCol t) where t = ghead "calcEndGap" toks (Deleted ss _ _) -> fst $ forestSpanToSimpPos ss eg = (tokRow - spanRow, tokCol - spanCol) -- eg = error $ "calcEndGap: (sspan,(before,middle,after))=" ++ (show (sspan,(_before,middle,after))) (tokRowPg,tokColPg) = if emptyList before then (spanStartRow - 1,spanStartCol) else (r,c) where (r,c) = case glast ("calcEndGap:before="++(show before)) before of (Entry _ _ toks) -> (tokenRow t,tokenCol t) where t = glast "calcEndGap pg" toks (Deleted ss _ _) -> snd $ forestSpanToSimpPos ss -- TODO: what about comments before the span? spanStartRow may be off pg = (spanStartRow - tokRowPg, spanStartCol - tokColPg) -- pg = error $ "calcPriorAndEndGap : (tokRowPg,tokColPg):" ++ (show $ ((tokRowPg,tokColPg),(spanStartRow,spanStartCol))) -- pg = error $ "calcPriorAndEndGap : (head before):" ++ (show $ last before) -- --------------------------------------------------------------------- -- TODO: delete this, superseded by calcPriorAndEndGap -- |For a span about to be deleted, calculate the gap between the end -- of the span being deleted and the start of the next one, at a token -- level. calcEndGap :: 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 = monotonicLineToks $ stripForestLines $ reAlignMarked $ deleteGapsToks $ retrieveTokens' forest -- --------------------------------------------------------------------- {- -- |Retrieve the tokens in a ppr format, so they can be rendered retrieveTokensPpr :: Tree Entry -> [Ppr] retrieveTokensPpr forest = pps''' where -- forest' = adjustLinesForDeleted forest (pps,_,lastLine) = retrieveTokensPpr' ([],Original,[]) forest pps' = pps ++ (mkPprFromLineToks lastLine) pps'' = mergeDeletesPpr pps' pps''' = adjustPprForDeleted pps'' retrieveTokensPpr' :: ([Ppr],PprOrigin,[PosToken]) -> Tree Entry -> ([Ppr],PprOrigin,[PosToken]) retrieveTokensPpr' acc (Node (Deleted _sspan _pg ( 0,_cd) ) _) = acc retrieveTokensPpr' acc (Node (Deleted sspan pg (rd,_cd) ) _) = acc' where (ac,o,curLineToks) = acc ll = mkPprFromLineToksSrc o curLineToks ((rs,cs),(re,_ce)) = forestSpanToSimpPos sspan ol = re - rs acc' = (ac ++ ll ++ [PprDeleted rs cs pg ol rd],o,[]) retrieveTokensPpr' acc (Node (Entry _sspan NoChange []) subs) = foldl' retrieveTokensPpr' acc subs retrieveTokensPpr' acc (Node (Entry _sspan (Above so _ (r,c) eo) []) subs) = acc' where (ac,_o,curLineToks) = acc (sss,o2,cl2) = foldl' retrieveTokensPpr' ([],Original,[]) subs cl2Acc = mkPprFromLineToksSrc o2 cl2 ll = mkPprFromLineToks curLineToks acc' = (ac ++ ll ++ [PprAbove so (r,c) eo (normaliseColumns (sss++cl2Acc))],o2,[]) retrieveTokensPpr' (acc,oi,curLineToks) (Node (Entry sspan _ toks) []) = (acc++accNew,o,curLineToks') where o = if (forestSpanVersionSet sspan) then Added else Original oi' = if o == Added || oi == Added then Added else Original toksByLine = groupTokensByLine toks (accNew,curLineToks') = case curLineToks of [] -> case toksByLine of [] -> ([],[]) [x] -> ([],x) xs -> (concatMap (mkPprFromLineToksSrc o) (init xs),last xs) _ -> case toksByLine of [] -> ([],[]) [x] -> if (toksOnSameLine (last curLineToks) (head x)) then ([],curLineToks ++ x) else (mkPprFromLineToksSrc oi curLineToks,x) (x:xs) -> if (toksOnSameLine (last curLineToks) (head x)) then ((mkPprFromLineToksSrc oi' (curLineToks++x)) ++ concatMap (mkPprFromLineToksSrc o) ( init xs),last xs) else ((mkPprFromLineToksSrc oi curLineToks ) ++ concatMap (mkPprFromLineToksSrc o) (x:init xs),last xs) -- Keep -Wall happy retrieveTokensPpr' _acc n@(Node (Entry _sspan (Above _so _ (_r,_c) _eo) _toks) _subs) = error $ "retrieveTokensPpr': Above entry with toks:" ++ (show n) -- retrieveTokensPpr' _acc n@(Node (Entry _sspan (Offset _r _c) _toks) _subs) -- = error $ "retrieveTokensPpr': Offset entry with toks:" ++ (show n) retrieveTokensPpr' _acc n@(Node (Entry _sspan (NoChange) _toks) _subs) = error $ "retrieveTokensPpr': NoChange entry with toks:" ++ (show n) -} {- mkPprFromLineToks :: [PosToken] -> [Ppr] mkPprFromLineToks toks = mkPprFromLineToksSrc Original toks mkPprFromLineToksSrc :: PprOrigin -> [PosToken] -> [Ppr] mkPprFromLineToksSrc _ [] = [] mkPprFromLineToksSrc o toks = [PprText ro co o str] where ro' = tokenRow $ head toks co' = tokenCol $ head toks (ro,co) = srcPosToSimpPos (tokenRow $ head toks, tokenCol $ head toks) toks' = addOffsetToToks (-ro',-co') toks str = GHC.showRichTokenStream toks' -- | The PprAbove construct needs all the starting columns to be reset to zero normaliseColumns :: [Ppr] -> [Ppr] normaliseColumns [] = [] normaliseColumns ps = ps' where offset = case (head ps) of PprText _r c _ _ -> c - 1 PprDeleted _r c _ _ _ -> c - 1 _ -> 0 ps' = map removeOffset ps removeOffset (PprText r c o toks) = (PprText r (c - offset) o toks) removeOffset (PprDeleted r c p l e) = (PprDeleted r (c - offset) p l e) removeOffset x = x -} -- --------------------------------------------------------------------- {- adjustPprForDeleted :: [Ppr] -> [Ppr] adjustPprForDeleted [] = [] adjustPprForDeleted pps = pps' where (_,pps') = foldl' go ((0,0),[]) pps go :: ((Int,Int),[Ppr]) -> Ppr -> ((Int,Int),[Ppr]) go ((ro,co),acc) (PprText r c Original str) = ((ro, co),acc++[PprText (r-ro) (c-co) Original str]) go ((ro,co),acc) (PprText r c Added str) = ((ro-1,co),acc++[PprText (r ) (c ) Added str]) -- go ((ro,co),acc) (PprDeleted r c rd) = ((ro - rd,co),acc) go ((ro,co),acc) (PprDeleted r c pg l eg) = ((ro + (pg + l + eg) - (max pg eg),co),acc++[PprDeleted r c pg l eg]) -- NOTE: see below for derivation of the above calc go ((ro,co),acc) (PprAbove so p1 eo subs) = ((ro',co'),acc++[PprAbove so' p1' eo' subs']) where so' = so p1' = p1 eo' = eo ((ro',co'),subs') = foldl' go ((ro,co),[]) subs -} {- Case 1 Code is ---- 3:data D = A | B String | C 4: 5:ff :: Int -> Int << Int 6:ff y = y + zz << Int 5: 6:ff y = y + zz << [Ppr] mergeDeletesPpr [] = [] mergeDeletesPpr ((PprDeleted r1 c1 pg1 l1 eg1):(PprDeleted _r _c pg2 l2 eg2):ps) = (PprDeleted r1 c1 pg1 (l1 + eg1 + pg2 + l2 - 1) eg2) : mergeDeletesPpr ps -} {- The total gap taken up by each delete is pg+l+eg. We have pg1 + l1 + eg1 + pg2 + l2 + eg2 The combined span has pg1 + (l1 + eg1 + pg2 + l2) + eg2 Why do we need the (-1)? TBD pg1 : fb - sr eg1 : dr - lb l1 : lb - fb sum: (fb - sr) + (dr - lb) + (lb - fb) = -sr + dr -- fb and lb cancels out = dr - sr so we have (dr1 - sr1) + (dr2 - sr2) bu, dr1 == sr2 so (dr1 - sr1 + dr2 - dr1) or dr2 - sr1 -} {- mergeDeletesPpr (p:ps) = p : mergeDeletesPpr ps -} -- --------------------------------------------------------------------- {- getPprStartRow :: Ppr -> Row getPprStartRow (PprText r _ _ _) = r getPprStartRow (PprDeleted r _ _ _ _) = r getPprStartRow (PprAbove _ _ _ []) = error "getPprStartRow: PprAbove with no subs" getPprStartRow (PprAbove _ _ _ subs) = getPprStartRow $ head subs getPprEndRow :: Ppr -> Row getPprEndRow (PprText r _ _ _) = r getPprEndRow (PprDeleted r _ _ _ _) = r getPprEndRow (PprAbove _ _ _ []) = error "getPprEndRow: PprAbove with no subs" getPprEndRow (PprAbove _ _ _ subs) = getPprEndRow $ last subs -} -- --------------------------------------------------------------------- -- TODO: deprecated, doing this at the Ppr level now adjustLinesForDeleted :: Tree Entry -> Tree Entry adjustLinesForDeleted forest = forest' where (_,forest') = go (0,0) forest go :: (Int,Int) -> Tree Entry -> ((Int,Int),Tree Entry) go (ro,co) (n@(Node (Entry _ss _lay _toks) [])) = ((ro,co),applyOffsetToTreeShallow (ro,co) n) go (ro,co) (n@(Node (Deleted _ _ (gr,_gc)) _nullSubs)) = ((ro-gr,co),n) go (ro,co) (n@(Node (Entry _ss _lay []) _subs)) = ((ro',co'),Node (Entry ss lay []) subs') where (Node (Entry ss lay []) subs) = applyOffsetToTreeShallow (ro,co) n ((ro',co'),subs') = foldl' go' ((ro,co),[]) subs go (_ro,_co) (n@(Node (Entry _ss _lay _toks) _subs)) = error $ "adjustLinesForDeleted: Entry with toks and subs:" ++ (show n) go' ((ro,co),acc) tree = ((ro',co'),acc++[tree']) where ((ro',co'),tree') = go (ro,co) tree -- --------------------------------------------------------------------- applyOffsetToTreeShallow :: (Int,Int) -> Tree Entry -> Tree Entry applyOffsetToTreeShallow (ro,co) (Node (Entry sspan lay toks) subs) = (Node (Entry sspan' lay toks') subs') where sspan' = addOffsetToForestSpan (ro,co) sspan toks' = addOffsetToToks (ro,co) toks subs' = subs applyOffsetToTreeShallow _ n@(Node (Deleted _ _ _) _) = n -- --------------------------------------------------------------------- {- renderPpr :: [Ppr] -> String renderPpr ps = res where (_,(_,res)) = runState (go 0 ps) ((1,1),"") go _ [] = return () go ci (ppt@(PprText _rt _ct _ _toks):ppa@(PprAbove so (_,_cc) eo _subs):ps') = do renderPprText ci ppt addOffset so (_,c) <- getRC renderPprAbove c ppa (cr,_cc) <- getRC -- addOffset eo if ps' /= [] then case eo of FromAlignCol (ero,eco) -> newPos (cr+ero) (ci+eco) SameLine _ -> addOffset eo None -> return () else return () -- (r',c') <- getRC -- addDebugString $ "(eo:" ++ show (ci,(r',c')) ++ ")" -- ++AZ++ debug go ci ps' go ci (p@(PprText _rt _ct _ _toks):ps') = do renderPprText ci p go ci ps' go ci ((PprDeleted _ _ _ _ _):ps') = go ci ps' go _ pps = error $ "renderPpr: unmatched in go:" ++ (show pps) ------------------------------------ renderPprAbove _ci (PprAbove _ _ _ []) = return () renderPprAbove ci (PprAbove _ _ _ subs) = go ci subs renderPprAbove _ ppr = error $ "renderPprAbove:unexpected ppr:" ++ (show ppr) ------------------------------------ -- renderPprText :: Col -> Ppr -> String renderPprText ci (PprText rt ct _ str) = do -- (r',c') <- getRC -- addDebugString $ "(op" ++ (show (ci,(r',c'),(rt,ct))) ++ ")" -- ++AZ++ for debugging newPos rt (ci + ct) -- (r,c) <- getRC -- addDebugString $ "(np:" ++ (show (r,c)) ++ ")" -- ++AZ++ for debugging addString str -- addDebugString $ "(fp:" ++ (show (r,c)) ++ ")" -- ++AZ++ for debugging renderPprText _ ppr = error $ "renderPprText:unexpected ppr:" ++ (show ppr) ------------------------------------ addOffset None = return () addOffset (SameLine co) = do (r,c) <- getRC newPos r (c+co) addOffset (FromAlignCol (ro,co)) = do (r,c) <- getRC newPos (r+ro) (c+co) newPos newRow newCol = do (oldRow',oldCol) <- getRC -- Allow for out of order additions that result from additions -- to the tree. Will break the invariant. let oldRow = if oldRow' <= newRow then oldRow' else (newRow - 1) putRC (oldRow,oldCol) if oldRow == newRow then addString (take (newCol - oldCol) $ repeat ' ') else addString ( (take (newRow - oldRow) $ repeat '\n') ++ (take (newCol - 1) $ repeat ' ') ) checkInvariant $ "newPos:" ++ (show (newRow,newCol)) -- Check invariant -- 1. r == number of '\n' + 1 -- 2. c == number of chars in last line. -- We assume the c val refers to positions between characters -- of output. checkInvariant str = do {- ((r,c),cur) <- get let ll = 1 + (length $ filter (=='\n') cur) let lc = 1 + (length $ takeWhile (/='\n') $ reverse cur) if r /= ll then error $ "renderPpr.newPos: r /= ll :" ++ (show (r,ll,cur,str)) else return () if c /= lc then error $ "renderPpr.newPos: c /= lc :" ++ (show (c,lc,cur,str)) else return () -} return () -- State operations ---------------- getRC = do (rc,_) <- get return rc putRC (r,c) = do (_,str) <- get put ((r,c),str) addString [] = return () addString str = do ((r,c),curr) <- get let ll = (length $ filter (=='\n') str) let c'' = (length $ takeWhile (/='\n') $ reverse str) let (r',c') = case ll of 0 -> (r,c + c'') _ -> (r + ll, c'' + 1) put ((r',c'),curr++str) checkInvariant $ "addString" ++ show str addDebugString str = do ((r,c),curr) <- get put ((r,c),curr++str) -} -- --------------------------------------------------------------------- -- |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 = monotonicLineToks $ stripForestLines {- 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 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 -- --------------------------------------------------------------------- -- | 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 _lay1 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' = (fr + (sr - dr) + deltaR, 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 -- Next one is the usual one -- res' = reverse $ (concat (go z)) ++ prevToks res' = reverse $ concat $ reverse (prevToks : (go z)) -- 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))) -- res' = error $ "retrievePrevLineToks:(prevToks : (go z))=" ++ (show $ concat $ reverse (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 -- --------------------------------------------------------------------- stripForestLineFromGhc :: GHC.SrcSpan -> GHC.SrcSpan stripForestLineFromGhc l = l' 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) = getSrcSpanForDeep forest (srcSpanToForestSpan oldSpan) (ghcl,_c) = getGhcLoc newSpan (ForestLine ch tr v l) = ghcLineToForestLine ghcl newSpan' = insertForestLineInSrcSpan (ForestLine ch tr (v+1) l) newSpan toks' = placeToksForSpan forest' oldSpan tree pos toks newNode = Node (Entry (srcSpanToForestSpan newSpan') NoChange toks') [] forest'' = insertNodeAfter tree newNode forest' -- --------------------------------------------------------------------- placeToksForSpan :: Tree Entry -> GHC.SrcSpan -> Tree Entry -> Positioning -> [PosToken] -> [PosToken] placeToksForSpan forest oldSpan tree pos toks = toks' where z = openZipperToSpanDeep (srcSpanToForestSpan oldSpan) $ Z.fromTree forest prevToks = case (retrievePrevLineToks z) of RT [] -> reverseToks $ retrieveTokensInterim tree xs -> xs prevToks' = limitPrevToks prevToks oldSpan toks' = reIndentToks pos (unReverseToks prevToks') toks -- 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) = getSrcSpanForDeep forest (srcSpanToForestSpan oldSpan) toks'' = placeToksForSpan fwithspan oldSpan tree pos toks (startPos,endPos) = nonCommentSpan toks'' newSpan = posToSrcSpan forest (startPos,endPos) (forest',newSpan') = addNewSrcSpanAndToksAfter forest oldSpan newSpan pos toks -- --------------------------------------------------------------------- limitPrevToks :: ReversedToks -> GHC.SrcSpan -> ReversedToks limitPrevToks prevToks sspan = reverseToks prevToks'' where ((ForestLine _ _ _ startRow,_startCol),(ForestLine _ _ _ endRow,_)) = srcSpanToForestSpan sspan -- 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 isWhiteSpaceOrIgnored prevToks -- colStart = prevOffset -- colStart = error $ "reIndentToks:prevToks=" ++ (show prevToks) lineStart = (tokenRow (lastTok)) -- + 1 -- lineStart = error $ "reIndentToks:PlaceOffset:lastTok=" ++ show lastTok -- lineStart = error $ "reIndentToks:PlaceOffset:firstTok=" ++ show firstTok lineOffset' = rowIndent + lineStart - (tokenRow firstTok) colOffset' = colIndent + colStart - (tokenCol newTokStart) -- colOffset' = error $ "reIndentToks:placeOffset lineOffset=" ++ show lineOffset PlaceIndent rowIndent colIndent numLines -> (lineOffset',colOffset',numLines) where colStart = prevOffset lineStart = if ((isComment lastTok) && (tokenRow lastNonCommentTok /= lastTokEndLine)) then (tokenRow (lastTok)) + 1 else (tokenRow (lastTok)) lineOffset' = rowIndent + lineStart - (tokenRow firstTok) colOffset' = colIndent + colStart - (tokenCol newTokStart) + 1 -- ++AZ++ Why +1? toks' = addOffsetToToks (lineOffset,colOffset) toks toks'' = if endNewlines > 0 -- then toks' ++ [(newLinesToken endNewlines $ glast "reIndentToks.3" toks')] then toks' ++ [(newLinesToken (endNewlines - 1) $ 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 isIgnoredNonComment $ toks (startPos,endPos) = case stripped of [] -> ((0,0),(0,0)) _ -> (tokenPos startTok,tokenPosEnd endTok) where startTok = ghead "nonCommentSpan.1" $ dropWhile isIgnoredNonComment $ toks endTok = ghead "nonCommentSpan.2" $ dropWhile isIgnoredNonComment $ reverse toks -- --------------------------------------------------------------------- -- |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 = openZipperToNodeDeep oldNode $ Z.fromTree forest zp = gfromJust ("insertNodeAfter:" ++ (show (oldNode,newNode,forest))) $ Z.parent zf tp = Z.tree zp -- now go through the children of the parent tree, and find the -- right spot for the new node (f,s) = break (\t -> treeStartEnd t == treeStartEnd oldNode) $ subForest tp (f',s') = (f++[ghead "insertNodeAfter" s],tail s) -- break does not include the found point subForest' = f' ++ [newNode] ++ s' tp' = tp { subForest = subForest' } forest' = Z.toTree $ Z.setTree tp' zp -- --------------------------------------------------------------------- -- |Open a zipper so that its focus is the given node -- NOTE: the node must already be in the tree openZipperToNode :: Tree Entry -> Z.TreePos Z.Full Entry -> Z.TreePos Z.Full Entry openZipperToNode (Node (Entry sspan _ _) _) z = openZipperToSpan sspan z openZipperToNode (Node (Deleted sspan _ _) _) z = openZipperToSpan sspan z -- |Open a zipper so that its focus is the given node -- NOTE: the node must already be in the tree openZipperToNodeDeep :: Tree Entry -> Z.TreePos Z.Full Entry -> Z.TreePos Z.Full Entry openZipperToNodeDeep (Node (Entry sspan _ _) _) z = openZipperToSpanDeep sspan z openZipperToNodeDeep (Node (Deleted sspan _ _) _) z = openZipperToSpanDeep sspan z getChildrenAsZ :: Z.TreePos Z.Full a -> [Z.TreePos Z.Full a] getChildrenAsZ z = go [] (Z.firstChild z) where go acc Nothing = acc go acc (Just zz) = go (acc ++ [zz]) (Z.next zz) -- --------------------------------------------------------------------- -- |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 | hasVersions = openZipperToSpanAdded sspan z | otherwise = openZipperToSpanOrig sspan z where (vs,_ve) = forestSpanVersions sspan hasVersions = vs /= 0 -- --------------------------------------------------------------------- -- |Open a zipper so that its focus has the given SrcSpan in its -- subtree, or the location where the SrcSpan should go, if it is not -- in the tree openZipperToSpanOrig :: ForestSpan -> Z.TreePos Z.Full Entry -> Z.TreePos Z.Full Entry openZipperToSpanOrig sspan z = if (treeStartEnd (Z.tree z) == sspan) || (Z.isLeaf z) then z else z' where -- go through all of the children to find the one that -- either is what we are looking for, or contains it -- childrenAsZ = go [] (Z.firstChild z) childrenAsZ = getChildrenAsZ z z' = case (filter contains childrenAsZ) of [] -> z -- Not directly in a subtree, this is as good as -- it gets [x] -> -- exactly one, drill down openZipperToSpan sspan x xx -> case (filter (\zt -> (treeStartEnd $ Z.tree zt) == sspan) xx) of [] -> -- more than one matches, see if we can get -- rid of the ones that have been lengthened case (filter (not .forestSpanLenChanged . treeStartEnd . Z.tree) xx) of [] -> z -- we tried... [w] -> openZipperToSpan sspan w -- ww -> error $ "openZipperToSpan:can't resolve:(sspan,ww)="++(show (sspan,ww)) ww -> -- more than one candidate, break -- the tie on version match case (filter (\zt -> matchVersions sspan zt) ww) of [v] -> openZipperToSpan sspan v _ -> error $ "openZipperToSpan:can't resolve:(sspan,ww)="++(show (sspan,map (\zt -> treeStartEnd $ Z.tree zt) ww)) [y] -> openZipperToSpan sspan y yy -> -- Multiple, check if we can separate out by -- version case (filter (\zt -> (fst $ forestSpanVersions $ treeStartEnd $ Z.tree zt) == (fst $ forestSpanVersions sspan)) xx) of -- [] -> z [] -> error $ "openZipperToSpan:no version match:(sspan,yy)=" ++ (show (sspan,yy)) -- ++AZ++ [w] -> openZipperToSpan sspan w _ww -> error $ "openZipperToSpan:multiple version match:" ++ (show (sspan,yy)) -- ++AZ++ contains zn = spanContains (treeStartEnd $ Z.tree zn) sspan matchVersions span1 z2 = isMatch where span2 = treeStartEnd $ Z.tree z2 isMatch = forestSpanVersions span1 == forestSpanVersions span2 -- --------------------------------------------------------------------- -- |Open a zipper so that its focus has the given SrcSpan in its -- subtree, or the location where the SrcSpan should go, if it is not -- in the tree. -- In the case of an 'Above' layout with the same SrcSpan below, -- return that instead openZipperToSpanDeep :: ForestSpan -> Z.TreePos Z.Full Entry -> Z.TreePos Z.Full Entry openZipperToSpanDeep sspan z = zf where z' = openZipperToSpan sspan z zf = case Z.tree z' of (Node (Entry _ (Above _ _ _ _) _) _) -> case getChildrenAsZ z' of [] -> z' [x] -> if (treeStartEnd (Z.tree x) == sspan) then x else z' _ -> z' _ -> z' -- --------------------------------------------------------------------- -- |Open a zipper to a SrcSpan that has been added in the tree, and -- thus does not necessarily fall in the logical hierarchy of the tree openZipperToSpanAdded :: ForestSpan -> Z.TreePos Z.Full Entry -> Z.TreePos Z.Full Entry openZipperToSpanAdded sspan z = zf where treeAsList = getTreeSpansAsList $ Z.tree z -- True if first span contains the second myMatch (((ForestLine _ _ vs1 rs1),cs1),((ForestLine _ _ ve1 re1),ce1)) (((ForestLine _ _ vs2 rs2),cs2),((ForestLine _ _ ve2 re2),ce2)) = vs1 == vs2 && ve1 == ve2 && ((rs1,cs1) <= (rs2,cs2)) && ((re1,ce1) >= (re2,ce2)) tl2 = dropWhile (\(_,s) -> not (myMatch s sspan)) $ reverse treeAsList fff [] _ = [] fff acc@((cd,_cs):_) (v,sspan') = if v < cd then (v,sspan'):acc else acc tl3 = foldl' fff [(head tl2)] tl2 -- tl3 now contains the chain of ForestSpans to open in order in the zipper zf = foldl' (flip openZipperToSpanOrig) z $ map snd tl3 -- --------------------------------------------------------------------- getTreeSpansAsList :: Tree Entry -> [(Int,ForestSpan)] getTreeSpansAsList = getTreeSpansAsList' 0 getTreeSpansAsList' :: Int -> Tree Entry -> [(Int,ForestSpan)] getTreeSpansAsList' level (Node (Deleted sspan _pg _eg ) _ ) = [(level,sspan)] getTreeSpansAsList' level (Node (Entry sspan _lay _toks) ts0) = (level,sspan) : (concatMap (getTreeSpansAsList' (level + 1)) ts0) -- --------------------------------------------------------------------- -- |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 _lay toks) sub) = acc ++ r ++ rinc ++ rsubs ++ rnull where r = if ( emptyList toks && nonEmptyList sub) || (nonEmptyList toks && emptyList sub) then [] else ["FAIL: exactly one of toks or subforest must be empty: " ++ (prettyshow node)] rsubs = foldl' checkNode [] sub rinc = checkInclusion node rnull = if (sspan == nullSpan) then ["FAIL: null SrcSpan in tree: " ++ (prettyshow node)] else [] -- |Check invariant 2, assuming 1 ok -- NOTE: check that the subtree spans do not go outside the node -- span, they do not need to completely fill it, because some may -- have been removed during manipulation checkInclusion (Node _ []) = [] checkInclusion (Node (Deleted _ _ _) _) = [] checkInclusion node@(Node (Entry _sspan _lay _toks) sub) = rs ++ rseq where (start,end) = treeStartEnd node subs = map treeStartEnd sub (sstart, _) = ghead "invariant" subs (_, send) = last subs -- Do not count any custom added srcspans at the end for this -- test -- TODO: is this a reasonable approach? rs = if ((start <= sstart) && ((end >= send) || (forestPosVersionSet send) || (forestPosAstVersionSet send))) || (forestPosLenChanged start) || (forestPosLenChanged sstart) || (forestPosLenChanged send) then [] else ["FAIL: subForest start and end does not match entry: " ++ (prettyshow node)] -- else ["FAIL: subForest start and end does not match entry: " ++ (show node)] rseq = checkSequence node subs checkSequence :: 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 _pg eg ) _ ) = [(showForestSpan sspan) ++ (show eg) ++ "D"] drawEntry (Node (Entry sspan lay _toks) ts0) = ((showForestSpan sspan) ++ (showLayout lay)): drawSubTrees ts0 where drawSubTrees [] = [] drawSubTrees [t] = "|" : shft "`- " " " (drawEntry t) drawSubTrees (t:ts) = "|" : shft "+- " "| " (drawEntry t) ++ drawSubTrees ts shft first other = zipWith (++) (first : repeat other) showLayout :: Layout -> String showLayout NoChange = "" showLayout (Above so p1 (r,c) eo) = "(Above "++ show so ++ " " ++ show p1 ++ " " ++ show (r,c) ++ " " ++ show eo ++ ")" -- showLayout (Offset r c) = "(Offset " ++ show r ++ " " ++ show c ++ ")" -- --------------------------------------------------------------------- drawTreeCompact :: Tree Entry -> String drawTreeCompact = unlines . drawTreeCompact' 0 drawTreeCompact' :: Int -> Tree Entry -> [String] drawTreeCompact' level (Node (Deleted sspan _pg eg ) _ ) = [(show level) ++ ":" ++ (showForestSpan sspan) ++ (show eg) ++ "D"] drawTreeCompact' level (Node (Entry sspan lay _toks) ts0) = ((show level) ++ ":" ++ (showForestSpan sspan) ++ (showLayout lay)) : (concatMap (drawTreeCompact' (level + 1)) ts0) -- --------------------------------------------------------------------- showTree :: Tree Entry -> String showTree = prettyshow -- |Represent a tree in a more concise/pretty way prettyshow :: Tree Entry -> String prettyshow (Node (Deleted sspan _pg eg) _nullSubs) = "Node (Deleted " ++ (showForestSpan sspan) ++ " " ++ (show eg) ++ ")" prettyshow (Node (Entry sspan _lay toks) sub) = "Node (Entry " ++ (showForestSpan sspan) ++ " " ++ (prettyToks toks) ++ ") " -- ++ show (map prettyshow sub) ++ "[" ++ intercalate "," (map prettyshow sub) ++ "]" prettyToks :: [PosToken] -> String prettyToks [] = "[]" prettyToks toks@[_x] = showToks toks prettyToks toks@[_t1,_t2] = showToks toks prettyToks toks = showToks [ghead "prettyToks" toks] ++ ".." ++ showToks [last toks] -- --------------------------------------------------------------------- -- |Make a tree representing a particular set of tokens mkTreeFromTokens :: [PosToken] -> Tree Entry mkTreeFromTokens [] = Node (Entry nullSpan NoChange []) [] mkTreeFromTokens toks = Node (Entry sspan NoChange toks) [] where (startLoc',endLoc') = nonCommentSpan toks sspan = if (startLoc',endLoc') == ((0,0),(0,0)) then error $ "mkTreeFromTokens:null span for:" ++ (show toks) else simpPosToForestSpan (startLoc',endLoc') -- --------------------------------------------------------------------- -- |Make a tree representing a particular set of tokens mkTreeFromSpanTokens :: ForestSpan -> [PosToken] -> Tree Entry mkTreeFromSpanTokens sspan toks = Node (Entry sspan NoChange toks) [] -- --------------------------------------------------------------------- ghcSpanStartEnd :: GHC.SrcSpan -> ((Int, Int), (Int, Int)) ghcSpanStartEnd sspan = (getGhcLoc sspan,getGhcLocEnd sspan) -- --------------------------------------------------------------------- -- |Synchronise a located AST fragment to use a newly created SrcSpan -- in the token tree. -- TODO: Should this indent the tokens as well? syncAST :: (SYB.Data t) => GHC.Located 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 syncAST ast@(GHC.L l _t) sspan forest = (GHC.L sspan xx,forest') where forest' = forest (( sr, sc),( _er, _ec)) = ghcSpanStartEnd l ((nsr,nsc),(_ner,_nec)) = ghcSpanStartEnd sspan rowOffset = nsr - sr colOffset = nsc - sc -- TODO: take cognizance of the ForestLines encoded in srcspans -- when calculating the offsets etc syncSpan s = addOffsetToSpan (rowOffset,colOffset) s (GHC.L _s xx) = everywhereStaged SYB.Renamer ( SYB.mkT hsbindlr `SYB.extT` sig `SYB.extT` ty `SYB.extT` name `SYB.extT` lhsexpr `SYB.extT` lpat `SYB.extT` limportdecl `SYB.extT` lmatch ) ast hsbindlr (GHC.L s b) = (GHC.L (syncSpan s) b) :: GHC.Located (GHC.HsBindLR GHC.Name GHC.Name) sig (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.LSig GHC.Name ty (GHC.L s typ) = (GHC.L (syncSpan s) typ) :: (GHC.LHsType GHC.Name) name (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.Located GHC.Name lhsexpr (GHC.L s e) = (GHC.L (syncSpan s) e) :: GHC.LHsExpr GHC.Name lpat (GHC.L s p) = (GHC.L (syncSpan s) p) :: GHC.LPat GHC.Name limportdecl (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.LImportDecl GHC.Name lmatch (GHC.L s m) = (GHC.L (syncSpan s) m) :: GHC.LMatch GHC.Name -- --------------------------------------------------------------------- -- | indent the tree and tokens by the given offset, and sync the AST -- to the tree too. indentDeclToks :: (SYB.Data t) => GHC.Located t -- ^The AST (or fragment) -> Tree Entry -- ^Existing token tree -> Int -- ^ (signed) number of columns to indent/dedent -> (GHC.Located t, Tree Entry) -- ^Updated AST and tokens indentDeclToks decl@(GHC.L sspan _) forest offset = (decl',forest'') where -- make sure the span is in the forest (forest',tree) = getSrcSpanFor forest (srcSpanToForestSpan sspan) z = openZipperToSpan (srcSpanToForestSpan sspan) $ Z.fromTree forest' tree' = go tree -- The invariant will fail if we do not propagate this change -- upward. But it needs to sync with the AST, which we do not have -- the upward version of. -- Instead, set the lengthChanged flag, in the parent. -- sss = forestSpanFromEntry entry -- sss' = insertLenChangedInForestSpan True sss -- tree'' = Node (putForestSpanInEntry entry sss') subs markLenChanged (Node entry subs) = (Node entry' subs) where sss = forestSpanFromEntry entry sss' = insertLenChangedInForestSpan True sss entry' = putForestSpanInEntry entry sss' z' = Z.setTree tree' z -- forest'' = Z.toTree (Z.setTree tree'' z) forest'' = case Z.parent z' of Nothing -> Z.toTree (Z.setTree (markLenChanged $ Z.tree z' ) z' ) Just z'' -> Z.toTree (Z.setTree (markLenChanged $ Z.tree z'') z'') (decl',_) = syncAST decl (addOffsetToSpan off sspan) tree off = (0,offset) -- Pretty sure this could be a fold of some kind go (Node (Deleted ss pg eg) sub) = (Node (Deleted (addOffsetToForestSpan off ss) pg eg) sub) go (Node (Entry ss lay []) sub) = (Node (Entry (addOffsetToForestSpan off ss) lay []) (map go sub)) go (Node (Entry ss lay toks) []) = (Node (Entry (addOffsetToForestSpan off ss) lay (addOffsetToToks off toks)) []) go n = error $ "indentDeclToks:strange node:" ++ (show n) -- --------------------------------------------------------------------- addOffsetToForestSpan :: (Int,Int) -> ForestSpan -> ForestSpan addOffsetToForestSpan (lineOffset,colOffset) fspan = fspan' where ((ForestLine sch str sv sl,sc),(ForestLine ech etr ev el,ec)) = fspan fspan' = ((ForestLine sch str sv (sl+lineOffset),sc+colOffset), (ForestLine ech etr ev (el+lineOffset),ec+colOffset)) -- --------------------------------------------------------------------- addOffsetToSpan :: (Int,Int) -> GHC.SrcSpan -> GHC.SrcSpan addOffsetToSpan (lineOffset,colOffset) sspan = sspan' where sspan' = case sspan of GHC.RealSrcSpan ss -> let locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) (lineOffset + GHC.srcSpanStartLine ss) (colOffset + GHC.srcSpanStartCol ss) locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) (lineOffset + GHC.srcSpanEndLine ss) (colOffset + GHC.srcSpanEndCol ss) in GHC.mkSrcSpan locStart locEnd _ -> sspan -- --------------------------------------------------------------------- showSrcSpan :: GHC.SrcSpan -> String showSrcSpan sspan = show (getGhcLoc sspan, (r,c)) where (r,c) = getGhcLocEnd sspan showSrcSpanF :: GHC.SrcSpan -> String showSrcSpanF sspan = show (((chs,trs,vs,ls),cs),((che,tre,ve,le),ce)) where ((ForestLine chs trs vs ls,cs),(ForestLine che tre ve le,ce)) = srcSpanToForestSpan sspan -- chsn = if chs then 1 else 0 -- chen = if che then 1 else 0 -- --------------------------------------------------------------------- sf :: GHC.SrcSpan -> ForestSpan sf = srcSpanToForestSpan fs :: ForestSpan -> GHC.SrcSpan fs = forestSpanToSrcSpan -- | ForestSpan version of GHC combineSrcSpans combineSpans :: ForestSpan -> ForestSpan -> ForestSpan combineSpans fs1 fs2 = fs' where [lowFs,highFs] = sort [fs1,fs2] ((ForestLine chls trls vls lls ,cls),(ForestLine _chle _trle _vle _lle,_cle)) = lowFs ((ForestLine _chhs _trhs _vhs _lhs,_chs),(ForestLine chhe trhe vhe lhe, che)) = highFs fs' = ((ForestLine chls trls vls lls,cls),(ForestLine chhe trhe vhe lhe,che)) {- -- | Combines two 'SrcSpan' into one that spans at least all the characters -- within both spans. Assumes the "file" part is the same in both inputs combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful combineSrcSpans l (UnhelpfulSpan _) = l combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2) = RealSrcSpan (combineRealSrcSpans span1 span2) -- | Combines two 'SrcSpan' into one that spans at least all the characters -- within both spans. Assumes the "file" part is the same in both inputs combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan combineRealSrcSpans span1 span2 = if line_start == line_end then if col_start == col_end then SrcSpanPoint file line_start col_start else SrcSpanOneLine file line_start col_start col_end else SrcSpanMultiLine file line_start col_start line_end col_end where (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) (srcSpanStartLine span2, srcSpanStartCol span2) (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) (srcSpanEndLine span2, srcSpanEndCol span2) file = srcSpanFile span1 -} -- EOF