{-# OPTIONS -Wall #-} module Language.Haskell.HBB.Internal.InternalTTree ( applyIndentation, applyInsertionInfo, {- only exported for the unit-tests -} InternalTTree, InsertionInfo(..)) where import Language.Haskell.HBB.Internal.SrcSpan import Language.Haskell.HBB.Internal.TTree import Debug.Trace (trace) import SrcLoc -- [Internal TTree] -- ================ -- -- Motivation -- ---------- -- -- The internal TTree (the name has been chosen because this structure is used -- by HBB internally) is an instance of TTree which is first produced by HBB. -- The main goal of using an internal representation is because it is hard to -- calculate the indentation of different elements in the transformation-tree. -- By using a more adequate (than the one reported to the client) -- representation the task of calculating the indentation (especially for -- Displays where the client should be reported an according hint) is -- considered to be easier. type InternalTTree = TTree LineBuf RealSrcSpan InsertionInfo -- We introduce a data type called InsertionInfo. Each element in the internal -- TTree is attached such a InsertionInfo. When recursing in the TTree the -- (parental) InsertionInfos make up a stack which (in combination with some -- other factors) describes the current indentation. -- -- An information that belongs to the insertion is whether a new section in the -- source code should be started or not. All NewSection elements that are on -- the same tree-level will have the same indentation. data InsertionInfo = IncInline BufSpan -- Child should be inserted into the current parent -- BufSpan: The position the text should be inlined at | NewSection Int -- Child should open a new section. Int: -- The index (smallest first) of the new section -- Indices start from 1... deriving (Show) type RecElementOffset = Indentation type AccLevelOffset = Indentation -- The sum of the recusive element indentation of all -- previously applied elements plus the element offset of -- the parent element. -- This function converts an InternalTTree into the one that is reported to the -- client. It is a thin wrapper around applyInsertionInfo which is the -- (complex) heart of this module. applyIndentation :: (InsertionInfo,InternalTTree) -> (BufSpan ,ClientTTree) applyIndentation tree = let shouldTrace = False tree' = if shouldTrace then trace ("/*" ++ (show tree) ++ "*/") tree else tree ((bs,_),tree3) = head $ foldl (applyInsertionInfo 0 0 [] [] [] 0 1 0) [] [attachRecusiveElementOffsets tree'] in (bs,tree3) -- The ClientTTree is constructed in two phases. In the first phase -- (represented by this function) each node is attached the recursive element -- offset. This is the offset of an element after having applied all IncInline -- child elements (and their IncInline childs as well...) attachRecusiveElementOffsets :: ( InsertionInfo ,InternalTTree ) -> ((InsertionInfo,Indentation),TTree LineBuf RealSrcSpan (InsertionInfo,Indentation)) attachRecusiveElementOffsets (insInfo,TTree content childs) = let newChilds = map attachRecusiveElementOffsets childs totalChildOffset = sum [ i | ((IncInline _,i),_) <- newChilds ] offsetFromContent = elementOffset content in ((insInfo,totalChildOffset+offsetFromContent),TTree content newChilds) -- | This function turns the (internal) transformation-tree (with the recursive -- elements offsets attached) into a transformation-tree the client -- understands. This is mostly a task of making the indentation (which first is -- attached implicitely) explicit which means that each addition begins with -- enough spaces for example. -- -- The (indentation-)calculations in applyInsertionInfo are kind of complex and -- therefore 'indentation.markdown' is a concept-paper which describes some -- details with the help of some examples. applyInsertionInfo :: Indentation -- ^ Element offset of the parent element -> Indentation -- ^ The recursive element offset of the parent element -- if it is of type IncInline or 0 if it is of type -- NewSection -> [RecElementOffset] -- ^ 'Recursive element offset' of all parents -- between the the current element and the root node -> [AccLevelOffset] -- ^ The accumulated level offset stack -> [Int] -- ^ Parent elemen trailing chars stack -> Indentation -- ^ 'Effective indentation' of the parent element -> Int -- ^ Number of lines in the parent element (for NewSection insertion position) -> Int -- ^ Number of NewSection childs the parent element has (for NewSection insertion position) -> [((BufSpan ,RecElementOffset),ClientTTree )] -> ((InsertionInfo,RecElementOffset),TTree LineBuf RealSrcSpan (InsertionInfo,RecElementOffset)) -> [((BufSpan ,RecElementOffset),ClientTTree )] applyInsertionInfo parent_elemOffset parent_recElemOffset parent_recElemOffsetStack parent_accLevelOffsetStack parent_parentElemTrailingCharsStack parent_EffectiveIndentation nrOfLinesInParentElement nrOfNewSectionChildsInParent appliedNodesOnSameLvl ((currentElementsInsertionInfo,curElemRecElemOffs),(TTree _content childs)) = let samLvl_recElemOffsetStack = [ reo | ((_,reo),_) <- appliedNodesOnSameLvl ] currentAccLevelOffset = (sum samLvl_recElemOffsetStack) + parent_elemOffset recElemOffsetOfThisElement = case currentElementsInsertionInfo of (NewSection _) -> 0 {- NewSection mustn't have any influence on the indentation of the following nodes on the same level -} (IncInline _) -> curElemRecElemOffs currentElemParentElemTrailingchars = case currentElementsInsertionInfo of (NewSection _) -> 0 (IncInline (BufSpan (BufLoc _ c1) _)) -> parent_elemOffset - c1 + 1 -- The 'effective indentation' is the indentation that should be -- applied for non-first lines. The calculation of it is described -- in 'indentation.markdown'... currentEffInd = case currentElementsInsertionInfo of (NewSection _) -> (sum $ currentAccLevelOffset:parent_accLevelOffsetStack) - (sum $ currentElemParentElemTrailingchars:parent_parentElemTrailingCharsStack) (IncInline bs) -> let (BufSpan (BufLoc _ c1) (BufLoc _ _)) = bs in (c1-1) + (sum samLvl_recElemOffsetStack) + parent_EffectiveIndentation newSectionChildsIndentation = (sum $ currentAccLevelOffset:parent_accLevelOffsetStack) - (sum $ currentElemParentElemTrailingchars:parent_parentElemTrailingCharsStack) + curElemRecElemOffs --(elementOffset content) ------------------------------------------------------------------- -- TRACING ------------------------------------------------------------------- shouldTrace = case _content of (Addition ["in "]) -> False _ -> False txt = case currentElementsInsertionInfo of (NewSection n) -> "NewSection " ++ (show n) ++ " -> " ++ msgContentTxt ++ "\n" ++ restMsg (IncInline (BufSpan (BufLoc l1 c1) (BufLoc l2 c2))) -> "IncInline (" ++ ((show l1) ++ "," ++ (show c1)) ++ ") (" ++ ((show l2) ++ "," ++ (show c2)) ++ ") -> " ++ msgContentTxt ++ "\n" ++ restMsg where msgContentTxt = case _content of (Addition []) -> "Addition \"\"" (Addition ls) -> "Addition \"" ++ (head ls) ++ "\"..." (Display _) -> "Display" restMsg = unlines [" current elements recursive offset: " ++ (show curElemRecElemOffs) ," parent recursive element offset stack: " ++ (show parent_recElemOffsetStack) ," samlvl recursive element offset stack: " ++ (show samLvl_recElemOffsetStack) ," #lines in parent element: " ++ (show nrOfLinesInParentElement) ," parent eff. indentation: " ++ (show parent_EffectiveIndentation) ," calced eff. indentation: " ++ (show currentEffInd) ," parent accumulat. level offset stack: " ++ (show parent_accLevelOffsetStack) ," current level accum. level offset: " ++ (show currentAccLevelOffset) ," parent element trailing chars: " ++ (show parent_parentElemTrailingCharsStack) ," indentation of NewSection childs: " ++ (show newSectionChildsIndentation)] content = if not shouldTrace then _content else trace ("/* applyInsertionInfo with " ++ txt ++ " */") _content ------------------------------------------------------------------- -- END OF TRACING ------------------------------------------------------------------- effectiveIndStr = replicate currentEffInd ' ' newSecChilds = [ c | c@((NewSection _,_),_) <- childs ] otherChilds = [ c | c@((IncInline _,_),_) <- childs ] newSecChildsAdditionalLines = -- As described in 'indentation.markdown' a NewSections indentation -- is the sum of all accumulative level offsets between the current -- element and the root node (minus the trailing chars up to the -- root node). If we calculate the indentation string for our child -- NewSection elements, we have to consider our part as well... let childNewSecindStr = replicate newSectionChildsIndentation ' ' in case length newSecChilds of -- The first NewSection is on the same line with the previous content 0 -> [] 1 -> [] n -> replicate (n-1) childNewSecindStr nrOfLinesWithoutNewSections = case content of (Addition ad) -> length ad (Display spn) -> srcSpanEndLine spn - srcSpanStartLine spn + 1 -- This is the insertion position within the parent element. For -- elements of type IncInline the BufSpan is adapted by the parent. For -- NewSection elements the parent prepared the indentation and the -- insertion position is at the end of this indentation. insertionPosWithinParent = case currentElementsInsertionInfo of (NewSection idx) -> pointBufSpan (nrOfLinesInParentElement - (nrOfNewSectionChildsInParent - idx)) (currentEffInd + 1) (IncInline bs) -> bs -- Recursion function -- ------------------ -- This function should only be used to apply all IncInline childs -- elements at once because it sets the 'Recursive element offset' -- stack for the previous childs to []. recurseWith :: Int -- Number of lines in the parent element -> [((BufSpan ,RecElementOffset),ClientTTree )] -> [((InsertionInfo,RecElementOffset),TTree LineBuf RealSrcSpan (InsertionInfo,RecElementOffset))] -> [((BufSpan ,RecElementOffset),ClientTTree )] recurseWith nrOfLinesInParent acc ch = foldl (applyInsertionInfo (elementOffset content) (case currentElementsInsertionInfo of (NewSection _) -> 0 (IncInline _) -> curElemRecElemOffs) (case currentElementsInsertionInfo of (NewSection _) -> parent_recElemOffsetStack (IncInline _) -> curElemRecElemOffs:parent_recElemOffsetStack) (currentAccLevelOffset:parent_accLevelOffsetStack) (currentElemParentElemTrailingchars:parent_parentElemTrailingCharsStack) currentEffInd nrOfLinesInParent (length newSecChilds)) acc ch in case content of (Addition ad) -> let additionAdapted = let addIndentation :: LineBuf -> LineBuf addIndentation xs = map (\x -> effectiveIndStr ++ x) xs baseIndented = case ad of [] -> [] (x:xs) -> x:(addIndentation xs) in baseIndented ++ newSecChildsAdditionalLines moveBufSpanByEffInd :: BufSpan -> BufSpan moveBufSpanByEffInd bs = -- -- One non-first lines are prepended with spaces so we do not -- need to move things on the first line. -- let (BufSpan (BufLoc l1 c1) (BufLoc l2 c2)) = bs newC1 = case l1 of 1 -> c1 _ -> c1 + currentEffInd newC2 = case l2 of 1 -> c2 _ -> c2 + currentEffInd in (BufSpan (BufLoc l1 newC1) (BufLoc l2 newC2)) -- The childs need to be adapted because we have added spaces -- to our content and the BufSpans that are contained are -- referring to wrong positions... otherChildsMoved = [ (((IncInline (moveBufSpanByEffInd bs)),recInd),tree) | ((IncInline bs,recInd),tree ) <- otherChilds ] -- -------------------------------------- -- RECURSIVE CALLS -- -------------------------------------- newChilds = recurseWith (nrOfLinesWithoutNewSections + (length newSecChildsAdditionalLines)) [] (otherChildsMoved ++ newSecChilds) -- -------------------------------------- -- END RECURSIVE CALLS -- -------------------------------------- childWithoutRecElemOffs = map (\((bs,_),ch) -> (bs,ch)) newChilds in ((insertionPosWithinParent,recElemOffsetOfThisElement) ,TTree (Addition additionAdapted) childWithoutRecElemOffs):appliedNodesOnSameLvl (Display spn) -> let -- -------------------------------------- -- RECURSIVE CALLS -- -------------------------------------- newDisplayChilds = recurseWith (srcSpanEndLine spn - srcSpanStartLine spn + 1) [] (if length newSecChilds /= 0 then error "NewSections within displays aren't supported" else childs) -- -------------------------------------- -- END RECURSIVE CALLS -- -------------------------------------- newDisplayChildsWithoutRecElemOffs = map (\((bs,_),ch) -> (bs,ch)) newDisplayChilds clientDispOffsetHint = currentEffInd - (srcSpanStartCol spn) + 1 in ((insertionPosWithinParent,recElemOffsetOfThisElement) ,TTree (Display (spn,clientDispOffsetHint)) newDisplayChildsWithoutRecElemOffs):appliedNodesOnSameLvl -- Returns the number of characters the indentation will be higher after having -- applied the passed tree-node elementOffset :: TTreeNode LineBuf RealSrcSpan -> Indentation elementOffset (Addition []) = 0 elementOffset (Addition ad) = length $ last ad elementOffset (Display spn) = endCol - startCol where startCol = srcLocCol $ realSrcSpanStart spn endCol = srcLocCol $ realSrcSpanEnd spn