module Language.Haskell.Tools.AnnTrf.RangeToRangeTemplate (cutUpRanges, fixRanges) where
import Language.Haskell.Tools.AST
import Data.Data
import Data.List
import Data.Maybe
import Control.Reference hiding (element)
import Control.Monad.State
import SrcLoc
import Language.Haskell.Tools.AnnTrf.RangeTemplate
import FastString as GHC
import Debug.Trace
cutUpRanges :: forall node dom . SourceInfoTraversal node
=> Ann node dom NormRangeStage
-> Ann node dom RngTemplateStage
cutUpRanges n = evalState (cutUpRanges' n) [[],[]]
where cutUpRanges' :: SourceInfoTraversal node => Ann node dom NormRangeStage
-> State [[SrcSpan]] (Ann node dom RngTemplateStage)
cutUpRanges' = sourceInfoTraverseUp (SourceInfoTrf (trf cutOutElemSpan) (trf cutOutElemList) (trf cutOutElemOpt)) desc asc
desc = modify ([]:)
asc = modify tail
trf :: (Show (x NormRangeStage), Show (x RngTemplateStage), HasRange (x NormRangeStage), HasRange (x RngTemplateStage))
=> ([SrcSpan] -> x NormRangeStage -> x RngTemplateStage) -> x NormRangeStage -> State [[SrcSpan]] (x RngTemplateStage)
trf f ni = do (below : top : xs) <- get
let res = f below ni
put ([] : (top ++ [ getRange res ]) : xs)
return res
fixRanges :: SourceInfoTraversal node
=> Ann node dom RangeStage
-> Ann node dom NormRangeStage
fixRanges node = evalState (sourceInfoTraverseUp (SourceInfoTrf (trf expandToContain) (trf expandListToContain) (trf expandOptToContain)) desc asc node) [[],[]]
where
desc = modify ([]:)
asc = modify tail
trf :: (HasRange (x RangeStage), HasRange (x NormRangeStage))
=> ([SrcSpan] -> x RangeStage -> x NormRangeStage) -> x RangeStage -> State [[SrcSpan]] (x NormRangeStage)
trf f ni = do (below : top : xs) <- get
let res = f below ni
resRange = getRange res
endOfSiblings = srcSpanEnd (RealSrcSpan $ collectSpanRanges (srcSpanStart resRange) top)
correctedRange = if endOfSiblings > srcSpanStart resRange
then mkSrcSpan endOfSiblings (max endOfSiblings (srcSpanEnd resRange))
else resRange
put ([] : (top ++ [ correctedRange ]) : xs)
return $ setRange correctedRange res
expandToContain :: [SrcSpan] -> SpanInfo RangeStage -> SpanInfo NormRangeStage
expandToContain cont (NodeSpan sp) = NormNodeInfo (foldl1 combineSrcSpans $ sp : cont)
expandListToContain :: [SrcSpan] -> ListInfo RangeStage -> ListInfo NormRangeStage
expandListToContain cont (ListPos bef aft def ind sp) = NormListInfo bef aft def ind (RealSrcSpan $ collectSpanRanges sp cont)
expandOptToContain :: [SrcSpan] -> OptionalInfo RangeStage -> OptionalInfo NormRangeStage
expandOptToContain cont (OptionalPos bef aft sp) = NormOptInfo bef aft (RealSrcSpan $ collectSpanRanges sp cont)
cutOutElemSpan :: [SrcSpan] -> SpanInfo NormRangeStage -> SpanInfo RngTemplateStage
cutOutElemSpan sps (NormNodeInfo (RealSrcSpan sp))
= RangeTemplateNode sp $ foldl breakFirstHit (foldl breakFirstHit [RangeElem sp] loc) span
where (loc,span) = partition (\sp -> srcSpanStart sp == srcSpanEnd sp) sps
breakFirstHit (elem:rest) sp
= case breakUpRangeElem elem sp of
Just pieces -> pieces ++ rest
Nothing -> elem : breakFirstHit rest sp
breakFirstHit [] sp = error ("breakFirstHit: " ++ maybe "" unpackFS (srcSpanFileName_maybe sp) ++ " didn't find correct place for " ++ shortShowSpan sp ++ " in " ++ shortShowSpan sp ++ " with [" ++ concat (intersperse "," (map shortShowSpan sps)) ++ "]")
cutOutElemList :: [SrcSpan] -> ListInfo NormRangeStage -> ListInfo RngTemplateStage
cutOutElemList sps lp@(NormListInfo bef aft sep indented sp)
= let RealSrcSpan wholeRange = foldl1 combineSrcSpans $ sp : sps
in RangeTemplateList wholeRange bef aft sep indented (getSeparators wholeRange sps)
cutOutElemOpt :: [SrcSpan] -> OptionalInfo NormRangeStage -> OptionalInfo RngTemplateStage
cutOutElemOpt sps op@(NormOptInfo bef aft sp)
= let RealSrcSpan wholeRange = foldl1 combineSrcSpans $ sp : sps
in RangeTemplateOpt wholeRange bef aft
collectSpanRanges :: SrcLoc -> [SrcSpan] -> RealSrcSpan
collectSpanRanges (RealSrcLoc loc) [] = realSrcLocSpan loc
collectSpanRanges _ [] = error "collectSpanRanges: No real src loc for empty element"
collectSpanRanges _ ls = case foldl1 combineSrcSpans ls of RealSrcSpan sp -> sp
getSeparators :: RealSrcSpan -> [SrcSpan] -> [RealSrcSpan]
getSeparators sp infos@(_:_:_)
= mapMaybe getRangeElemSpan (cutOutElemSpan infos (NormNodeInfo (RealSrcSpan sp)) ^. rngTemplateNodeElems)
getSeparators sp _ = []
breakUpRangeElem :: RangeTemplateElem -> SrcSpan -> Maybe [RangeTemplateElem]
breakUpRangeElem (RangeElem outer) (RealSrcSpan inner)
| outer `containsSpan` inner
= Just $ (if (realSrcSpanStart outer) < (realSrcSpanStart inner)
then [ RangeElem (mkRealSrcSpan (realSrcSpanStart outer) (realSrcSpanStart inner)) ]
else []) ++
[ RangeChildElem ] ++
(if (realSrcSpanEnd inner) < (realSrcSpanEnd outer)
then [ RangeElem (mkRealSrcSpan (realSrcSpanEnd inner) (realSrcSpanEnd outer)) ]
else [])
breakUpRangeElem outer inner = Nothing