module Language.Haskell.HBB.Internal.InternalTTree (
applyIndentation,
applyInsertionInfo,
InternalTTree,
InsertionInfo(..)) where
import Language.Haskell.HBB.Internal.SrcSpan
import Language.Haskell.HBB.Internal.TTree
import Debug.Trace (trace)
import SrcLoc
type InternalTTree = TTree LineBuf RealSrcSpan InsertionInfo
data InsertionInfo = IncInline BufSpan
| NewSection Int
deriving (Show)
type RecElementOffset = Indentation
type AccLevelOffset = Indentation
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)
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)
applyInsertionInfo
:: Indentation
-> Indentation
-> [RecElementOffset]
-> [AccLevelOffset]
-> [Int]
-> Indentation
-> Int
-> Int
-> [((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
(IncInline _) -> curElemRecElemOffs
currentElemParentElemTrailingchars = case currentElementsInsertionInfo of
(NewSection _) -> 0
(IncInline (BufSpan (BufLoc _ c1) _)) -> parent_elemOffset c1 + 1
currentEffInd = case currentElementsInsertionInfo of
(NewSection _) -> (sum $ currentAccLevelOffset:parent_accLevelOffsetStack)
(sum $ currentElemParentElemTrailingchars:parent_parentElemTrailingCharsStack)
(IncInline bs) ->
let (BufSpan (BufLoc _ c1) (BufLoc _ _)) = bs
in (c11) + (sum samLvl_recElemOffsetStack) + parent_EffectiveIndentation
newSectionChildsIndentation = (sum $ currentAccLevelOffset:parent_accLevelOffsetStack)
(sum $ currentElemParentElemTrailingchars:parent_parentElemTrailingCharsStack) +
curElemRecElemOffs
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
effectiveIndStr = replicate currentEffInd ' '
newSecChilds = [ c | c@((NewSection _,_),_) <- childs ]
otherChilds = [ c | c@((IncInline _,_),_) <- childs ]
newSecChildsAdditionalLines =
let childNewSecindStr = replicate newSectionChildsIndentation ' '
in case length newSecChilds of
0 -> []
1 -> []
n -> replicate (n1) childNewSecindStr
nrOfLinesWithoutNewSections = case content of
(Addition ad) -> length ad
(Display spn) -> srcSpanEndLine spn srcSpanStartLine spn + 1
insertionPosWithinParent =
case currentElementsInsertionInfo of
(NewSection idx) -> pointBufSpan
(nrOfLinesInParentElement (nrOfNewSectionChildsInParent idx))
(currentEffInd + 1)
(IncInline bs) -> bs
recurseWith
:: Int
-> [((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 =
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))
otherChildsMoved = [ (((IncInline (moveBufSpanByEffInd bs)),recInd),tree) | ((IncInline bs,recInd),tree ) <- otherChilds ]
newChilds =
recurseWith
(nrOfLinesWithoutNewSections + (length newSecChildsAdditionalLines))
[]
(otherChildsMoved ++ newSecChilds)
childWithoutRecElemOffs = map (\((bs,_),ch) -> (bs,ch)) newChilds
in ((insertionPosWithinParent,recElemOffsetOfThisElement)
,TTree (Addition additionAdapted) childWithoutRecElemOffs):appliedNodesOnSameLvl
(Display spn) ->
let
newDisplayChilds =
recurseWith
(srcSpanEndLine spn srcSpanStartLine spn + 1)
[]
(if length newSecChilds /= 0
then error "NewSections within displays aren't supported"
else childs)
newDisplayChildsWithoutRecElemOffs = map (\((bs,_),ch) -> (bs,ch)) newDisplayChilds
clientDispOffsetHint = currentEffInd (srcSpanStartCol spn) + 1
in ((insertionPosWithinParent,recElemOffsetOfThisElement)
,TTree (Display (spn,clientDispOffsetHint)) newDisplayChildsWithoutRecElemOffs):appliedNodesOnSameLvl
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