libhbb-0.4.0.0: Language/Haskell/HBB/Internal/InternalTTree.hs
{-# 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