{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.Tools.PrettyPrint.Prepare.RangeToRangeTemplate (cutUpRanges, fixRanges, BreakUpProblem(..)) where
import Language.Haskell.Tools.AST
import Control.Exception (Exception, throw)
import Control.Monad.State
import Control.Reference ((^.))
import Data.List
import Data.Maybe (Maybe(..), mapMaybe)
import FastString as GHC (unpackFS)
import SrcLoc
import Language.Haskell.Tools.PrettyPrint.Prepare.RangeTemplate
cutUpRanges :: forall node dom . SourceInfoTraversal node
=> Ann node dom NormRangeStage
-> Ann node dom RngTemplateStage
cutUpRanges n = evalState (cutUpRanges' n) [[],[]]
where cutUpRanges' :: 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 :: 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
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 [] inner = throw $ BreakUpProblem sp inner sps
cutOutElemSpan _ (NormNodeInfo (UnhelpfulSpan {}))
= trfProblem "cutOutElemSpan: no real span"
data BreakUpProblem = BreakUpProblem { bupOuter :: RealSrcSpan
, bupInner :: SrcSpan
, bupSiblings :: [SrcSpan]
}
instance Show BreakUpProblem where
show (BreakUpProblem _ (RealSrcSpan inner) _)
= unpackFS (srcSpanFile inner) ++ ": didn't find correct place for AST element at " ++ shortShowSpan (RealSrcSpan inner)
show (BreakUpProblem outer _ _)
= unpackFS (srcSpanFile outer) ++ ": didn't find correct place for AST element in " ++ shortShowSpan (RealSrcSpan outer)
instance Exception BreakUpProblem
cutOutElemList :: [SrcSpan] -> ListInfo NormRangeStage -> ListInfo RngTemplateStage
cutOutElemList sps (NormListInfo bef aft sep indented sp)
= let RealSrcSpan wholeRange = foldl1 combineSrcSpans $ sp : sps
in RangeTemplateList wholeRange bef aft sep indented (getSeparators wholeRange sps)
getSeparators :: RealSrcSpan -> [SrcSpan] -> [RealSrcSpan]
getSeparators sp infos@(_:_:_)
= mapMaybe getRangeElemSpan (cutOutElemSpan infos (NormNodeInfo (RealSrcSpan sp)) ^. rngTemplateNodeElems)
getSeparators _ _ = []
cutOutElemOpt :: [SrcSpan] -> OptionalInfo NormRangeStage -> OptionalInfo RngTemplateStage
cutOutElemOpt sps (NormOptInfo bef aft sp)
= let RealSrcSpan wholeRange = foldl1 combineSrcSpans $ sp : sps
in RangeTemplateOpt wholeRange bef aft
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 _ _ = Nothing
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 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 (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 (checkSpans cont $ foldl1 combineSrcSpans $ sp : cont)
expandListToContain :: [SrcSpan] -> ListInfo RangeStage -> ListInfo NormRangeStage
expandListToContain cont (ListPos bef aft def ind sp)
= NormListInfo bef aft def ind (checkSpans cont $ collectSpanRanges sp cont)
expandOptToContain :: [SrcSpan] -> OptionalInfo RangeStage -> OptionalInfo NormRangeStage
expandOptToContain cont (OptionalPos bef aft sp)
= NormOptInfo bef aft (checkSpans cont $ collectSpanRanges sp cont)
collectSpanRanges :: SrcLoc -> [SrcSpan] -> SrcSpan
collectSpanRanges loc@(RealSrcLoc _) [] = srcLocSpan loc
collectSpanRanges _ ls = foldl combineSrcSpans noSrcSpan ls
checkSpans :: [SrcSpan] -> SrcSpan -> SrcSpan
checkSpans spans res
= if any (not . isGoodSrcSpan) spans && isGoodSrcSpan res
then trfProblem $ "Wrong src spans in " ++ show res
else res