module Language.Haskell.Tools.AnnTrf.PlaceComments where
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe
import Data.List
import Data.Char (isSpace, isAlphaNum)
import Data.Data
import Data.Generics.Uniplate.Data
import Control.Reference hiding (element)
import Control.Monad.Writer
import Control.Monad.State
import SrcLoc
import ApiAnnotation
import Outputable
import Debug.Trace
import Language.Haskell.Tools.AST
getNormalComments :: Map.Map SrcSpan [Located AnnotationComment] -> Map.Map SrcSpan [Located AnnotationComment]
getNormalComments = Map.map (filter (not . isPragma . unLoc))
getPragmaComments :: Map.Map SrcSpan [Located AnnotationComment] -> Map.Map String [Located String]
getPragmaComments comms = Map.fromListWith (++) $ map (\(L l (AnnBlockComment str)) -> (getPragmaCommand str, [L l str]))
$ filter (isPragma . unLoc) $ concatMap snd $ Map.toList comms
where getPragmaCommand = takeWhile (\c -> isAlphaNum c || c == '_') . dropWhile isSpace . drop 3
isPragma :: AnnotationComment -> Bool
isPragma (AnnBlockComment str) = take 3 str == "{-#" && take 3 (reverse str) == "#-}"
isPragma _ = False
placeComments :: RangeInfo stage => Map.Map SrcSpan [Located AnnotationComment]
-> Ann Module dom stage
-> Ann Module dom stage
placeComments comms mod
= resizeAnnots (concatMap (map nextSrcLoc . snd) (Map.toList comms)) mod
where spans = allElemSpans mod
sortedElemStarts = Set.fromList $ map srcSpanStart spans
sortedElemEnds = Set.fromList $ map srcSpanEnd spans
nextSrcLoc comm@(L sp _)
= let after = fromMaybe noSrcLoc (Set.lookupLE (srcSpanStart sp) sortedElemEnds)
before = fromMaybe noSrcLoc (Set.lookupGE (srcSpanEnd sp) sortedElemStarts)
in ((after,before),comm)
allElemSpans :: (SourceInfoTraversal node, RangeInfo stage) => Ann node dom stage -> [SrcSpan]
allElemSpans = execWriter . sourceInfoTraverse (SourceInfoTrf (\ni -> tell [ni ^. nodeSpan] >> pure ni) pure pure)
resizeAnnots :: RangeInfo stage => [((SrcLoc, SrcLoc), Located AnnotationComment)]
-> Ann Module dom stage
-> Ann Module dom stage
resizeAnnots comments elem
= flip evalState comments $
element&modImports&annList !~ expandAnnot
>=> element&modDecl&annList !~ expandTopLevelDecl
>=> expandAnnot
$ elem
type ExpandType elem dom stage = Ann elem dom stage -> State [((SrcLoc, SrcLoc), Located AnnotationComment)] (Ann elem dom stage)
expandTopLevelDecl :: RangeInfo stage => ExpandType Decl dom stage
expandTopLevelDecl
= element & declBody & annJust & element & cbElements & annList !~ expandClsElement
>=> element & declCons & annList !~ expandConDecl
>=> element & declGadt & annList !~ expandGadtConDecl
>=> element & declTypeSig !~ expandTypeSig
>=> expandAnnot
expandTypeSig :: RangeInfo stage => ExpandType TypeSignature dom stage
expandTypeSig
= element & tsType & typeParams !~ expandAnnot >=> expandAnnot
expandClsElement :: RangeInfo stage => ExpandType ClassElement dom stage
expandClsElement
= element & ceTypeSig !~ expandTypeSig
>=> element & ceBind !~ expandValueBind
>=> expandAnnot
expandValueBind :: RangeInfo stage => ExpandType ValueBind dom stage
expandValueBind
= element & valBindLocals & annJust & element & localBinds & annList !~ expandLocalBind
>=> element & funBindMatches & annList & element & matchBinds & annJust & element & localBinds & annList !~ expandLocalBind
>=> expandAnnot
expandLocalBind :: RangeInfo stage => ExpandType LocalBind dom stage
expandLocalBind
= element & localVal !~ expandValueBind
>=> element & localSig !~ expandTypeSig
>=> expandAnnot
expandConDecl :: RangeInfo stage => ExpandType ConDecl dom stage
expandConDecl
= element & conDeclFields & annList !~ expandAnnot >=> expandAnnot
expandGadtConDecl :: RangeInfo stage => ExpandType GadtConDecl dom stage
expandGadtConDecl
= element & gadtConType & element & gadtConRecordFields & annList !~ expandAnnot >=> expandAnnot
expandAnnot :: forall elem dom stage . RangeInfo stage => ExpandType elem dom stage
expandAnnot elem
= do let Just sp = elem ^? annotation&sourceInfo&nodeSpan
applicable <- gets (applicableComments (srcSpanStart sp) (srcSpanEnd sp))
if not (null applicable) then do
let newSp@(RealSrcSpan newSpan)
= foldl combineSrcSpans (fromJust $ elem ^? nodeSp) (map (getLoc . snd) applicable)
modify (filter (not . (\case RealSrcSpan s -> newSpan `containsSpan` s; _ -> True) . getLoc . snd))
return $ nodeSp .= newSp $ elem
else return elem
where nodeSp :: Simple Partial (Ann elem dom stage) SrcSpan
nodeSp = annotation&sourceInfo&nodeSpan
applicableComments :: SrcLoc -> SrcLoc
-> [((SrcLoc, SrcLoc), Located AnnotationComment)]
-> [((SrcLoc, SrcLoc), Located AnnotationComment)]
applicableComments start end = filter applicableComment
where
applicableComment ((_, before), L _ comm)
| isCommentOnNext comm = before == start
applicableComment ((after, _), L _ comm)
| isCommentOnPrev comm = after == end
applicableComment ((after, _), L (RealSrcSpan loc) _)
| after == end && srcLocLine (realSrcSpanStart loc) == getLineLocDefault end = True
applicableComment ((_, before), L (RealSrcSpan loc) _)
| before == start && srcLocLine (realSrcSpanEnd loc) + 1 == getLineLocDefault start
&& srcLocCol (realSrcSpanStart loc) == getLineColDefault start
= True
applicableComment _ = False
getLineLocDefault (RealSrcLoc l) = srcLocLine l
getLineLocDefault _ = 1
getLineColDefault (RealSrcLoc l) = srcLocCol l
getLineColDefault _ = 1
isCommentOnNext :: AnnotationComment -> Bool
isCommentOnNext (AnnDocCommentNext _) = True
isCommentOnNext (AnnLineComment s) = firstNonspaceCharIs '|' s
isCommentOnNext (AnnBlockComment s) = firstNonspaceCharIs '|' s
isCommentOnNext _ = False
isCommentOnPrev :: AnnotationComment -> Bool
isCommentOnPrev (AnnDocCommentPrev _) = True
isCommentOnPrev (AnnLineComment s) = firstNonspaceCharIs '^' s
isCommentOnPrev (AnnBlockComment s) = firstNonspaceCharIs '^' s
isCommentOnPrev _ = False
firstNonspaceCharIs :: Char -> String -> Bool
firstNonspaceCharIs c s = Just c == listToMaybe (dropWhile isSpace (drop 2 s))