module Language.Haskell.GHC.ExactPrint.Delta
( relativiseApiAnns
, relativiseApiAnnsWithComments
, relativiseApiAnnsWithOptions
, DeltaOptions(drRigidity)
, deltaOptions
, normalLayout
) where
import Control.Monad.RWS
import Control.Monad.Trans.Free
import Data.Data (Data)
import Data.List (sort, nub, partition, sortBy)
import Data.Ord
import Language.Haskell.GHC.ExactPrint.Utils
#if __GLASGOW_HASKELL__ <= 710
import Language.Haskell.GHC.ExactPrint.Lookup
#endif
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Annotate (AnnotationF(..), Annotated
, annotate, Annotate(..))
import qualified GHC
import qualified SrcLoc as GHC
import qualified Data.Map as Map
#if __GLASGOW_HASKELL__ <= 710
import qualified Data.Set as Set
#endif
relativiseApiAnns :: Annotate ast
=> GHC.Located ast
-> GHC.ApiAnns
-> Anns
relativiseApiAnns = relativiseApiAnnsWithComments []
relativiseApiAnnsWithComments ::
Annotate ast
=> [Comment]
-> GHC.Located ast
-> GHC.ApiAnns
-> Anns
relativiseApiAnnsWithComments =
relativiseApiAnnsWithOptions normalLayout
relativiseApiAnnsWithOptions ::
Annotate ast
=> DeltaOptions
-> [Comment]
-> GHC.Located ast
-> GHC.ApiAnns
-> Anns
relativiseApiAnnsWithOptions opts cs modu ghcAnns
= runDeltaWithComments
opts cs (annotate modu) ghcAnns
(ss2pos $ GHC.getLoc modu)
type Delta a = RWS DeltaOptions DeltaWriter DeltaState a
runDeltaWithComments :: DeltaOptions -> [Comment] -> Annotated () -> GHC.ApiAnns -> Pos -> Anns
runDeltaWithComments opts cs action ga priorEnd =
mkAnns . snd
. (\next -> execRWS next opts (defaultDeltaState cs priorEnd ga))
. deltaInterpret $ action
where
mkAnns :: DeltaWriter -> Anns
mkAnns = f . dwAnns
f :: Monoid a => Endo a -> a
f = ($ mempty) . appEndo
data DeltaOptions = DeltaOptions
{
curSrcSpan :: !GHC.SrcSpan
, annConName :: !AnnConName
, drRigidity :: Rigidity
}
data DeltaWriter = DeltaWriter
{
dwAnns :: Endo (Map.Map AnnKey Annotation)
, annKds :: ![(KeywordId, DeltaPos)]
, sortKeys :: !(Maybe [GHC.SrcSpan])
, dwCapturedSpan :: !(First AnnKey)
}
data DeltaState = DeltaState
{
priorEndPosition :: !Pos
, apComments :: ![Comment]
, apAnns :: !GHC.ApiAnns
, apMarkLayout :: Bool
, apLayoutStart :: LayoutStartCol
}
deltaOptions :: Rigidity -> DeltaOptions
deltaOptions ridigity =
DeltaOptions
{ curSrcSpan = GHC.noSrcSpan
, annConName = annGetConstr ()
, drRigidity = ridigity
}
normalLayout :: DeltaOptions
normalLayout = deltaOptions NormalLayout
defaultDeltaState :: [Comment] -> Pos -> GHC.ApiAnns -> DeltaState
defaultDeltaState injectedComments priorEnd ga =
DeltaState
{ priorEndPosition = priorEnd
, apComments = cs ++ injectedComments
, apAnns = ga
, apLayoutStart = 1
, apMarkLayout = False
}
where
cs :: [Comment]
cs = flattenedComments ga
flattenedComments :: GHC.ApiAnns -> [Comment]
flattenedComments (_,cm) =
map tokComment . GHC.sortLocated . concat $ Map.elems cm
tellFinalAnn :: (AnnKey, Annotation) -> Delta ()
tellFinalAnn (k, v) =
tell (mempty { dwAnns = Endo (Map.insert k v) })
tellSortKey :: [GHC.SrcSpan] -> Delta ()
tellSortKey xs = tell (mempty { sortKeys = Just xs } )
tellCapturedSpan :: AnnKey -> Delta ()
tellCapturedSpan key = tell ( mempty { dwCapturedSpan = First $ Just key })
tellKd :: (KeywordId, DeltaPos) -> Delta ()
tellKd kd = tell (mempty { annKds = [kd] })
instance Monoid DeltaWriter where
mempty = DeltaWriter mempty mempty mempty mempty
(DeltaWriter a b e g) `mappend` (DeltaWriter c d f h)
= DeltaWriter (a <> c) (b <> d) (e <> f) (g <> h)
deltaInterpret :: Annotated a -> Delta a
deltaInterpret = iterTM go
where
go :: AnnotationF (Delta a) -> Delta a
go (MarkEOF next) = addEofAnnotation >> next
go (MarkPrim kwid _ next) = addDeltaAnnotation kwid >> next
go (MarkOutside akwid kwid next) = addDeltaAnnotationsOutside akwid kwid >> next
go (MarkInside akwid next) = addDeltaAnnotationsInside akwid >> next
go (MarkMany akwid next) = addDeltaAnnotations akwid >> next
go (MarkOffsetPrim akwid n _ next) = addDeltaAnnotationLs akwid n >> next
go (WithAST lss prog next) = withAST lss (deltaInterpret prog) >> next
go (CountAnns kwid next) = countAnnsDelta kwid >>= next
go (SetLayoutFlag r action next) = do
rigidity <- asks drRigidity
(if (r <= rigidity) then setLayoutFlag else id) (deltaInterpret action)
next
go (MarkExternal ss akwid _ next) = addDeltaAnnotationExt ss akwid >> next
go (StoreOriginalSrcSpan key next) = storeOriginalSrcSpanDelta key >>= next
go (GetSrcSpanForKw kw next) = getSrcSpanForKw kw >>= next
#if __GLASGOW_HASKELL__ <= 710
go (StoreString s ss next) = storeString s ss >> next
#endif
go (AnnotationsToComments kws next) = annotationsToCommentsDelta kws >> next
go (WithSortKey kws next) = withSortKey kws >> next
withSortKey :: [(GHC.SrcSpan, Annotated b)] -> Delta ()
withSortKey kws =
let order = sortBy (comparing fst) kws
in do
tellSortKey (map fst order)
mapM_ (deltaInterpret . snd) order
setLayoutFlag :: Delta () -> Delta ()
setLayoutFlag action = do
oldLay <- gets apLayoutStart
modify (\s -> s { apMarkLayout = True } )
let reset = do
modify (\s -> s { apMarkLayout = False
, apLayoutStart = oldLay })
action <* reset
storeOriginalSrcSpanDelta :: AnnKey -> Delta AnnKey
storeOriginalSrcSpanDelta key = do
tellCapturedSpan key
return key
#if __GLASGOW_HASKELL__ <= 710
storeString :: String -> GHC.SrcSpan -> Delta ()
storeString s ss = addAnnotationWorker (AnnString s) ss
#endif
annotationsToCommentsDelta :: [GHC.AnnKeywordId] -> Delta ()
annotationsToCommentsDelta kws = do
ga <- gets apAnns
ss <- getSrcSpan
cs <- gets apComments
let
doOne :: GHC.AnnKeywordId -> [Comment]
doOne kw = comments
where
spans = GHC.getAnnotation ga ss kw
comments = map (mkKWComment kw) spans
newComments = concatMap doOne kws
putUnallocatedComments (cs ++ newComments)
getSrcSpanForKw :: GHC.AnnKeywordId -> Delta GHC.SrcSpan
getSrcSpanForKw kw = do
ga <- gets apAnns
ss <- getSrcSpan
case GHC.getAnnotation ga ss kw of
[] -> return GHC.noSrcSpan
(sp:_) -> return sp
getSrcSpan :: Delta GHC.SrcSpan
getSrcSpan = asks curSrcSpan
withSrcSpanDelta :: Data a => GHC.Located a -> Delta b -> Delta b
withSrcSpanDelta (GHC.L l a) =
local (\s -> s { curSrcSpan = l
, annConName = annGetConstr a
})
getUnallocatedComments :: Delta [Comment]
getUnallocatedComments = gets apComments
putUnallocatedComments :: [Comment] -> Delta ()
putUnallocatedComments cs = modify (\s -> s { apComments = cs } )
adjustDeltaForOffsetM :: DeltaPos -> Delta DeltaPos
adjustDeltaForOffsetM dp = do
colOffset <- gets apLayoutStart
return (adjustDeltaForOffset colOffset dp)
adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos
adjustDeltaForOffset _colOffset dp@(DP (0,_)) = dp
adjustDeltaForOffset (LayoutStartCol colOffset) (DP (l,c)) = DP (l,c colOffset)
getPriorEnd :: Delta Pos
getPriorEnd = gets priorEndPosition
setPriorEnd :: Pos -> Delta ()
setPriorEnd pe =
modify (\s -> s { priorEndPosition = pe })
setPriorEndAST :: GHC.SrcSpan -> Delta ()
setPriorEndAST pe = do
setLayoutStart (snd (ss2pos pe))
modify (\s -> s { priorEndPosition = (ss2posEnd pe) } )
setLayoutStart :: Int -> Delta ()
setLayoutStart p = do
DeltaState{apMarkLayout} <- get
when apMarkLayout (
modify (\s -> s { apMarkLayout = False
, apLayoutStart = LayoutStartCol p}))
peekAnnotationDelta :: GHC.AnnKeywordId -> Delta [GHC.SrcSpan]
peekAnnotationDelta an = do
ga <- gets apAnns
ss <- getSrcSpan
#if __GLASGOW_HASKELL__ <= 710
return $ GHC.getAnnotation ga ss an
#else
let unicodeAnns = case unicodeEquivalent an of
[] -> []
[kw] -> GHC.getAnnotation ga ss kw
return $ unicodeAnns ++ GHC.getAnnotation ga ss an
#endif
getAnnotationDelta :: GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)
getAnnotationDelta an = do
ss <- getSrcSpan
getAndRemoveAnnotationDelta ss an
getAndRemoveAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)
getAndRemoveAnnotationDelta sp an = do
ga <- gets apAnns
#if __GLASGOW_HASKELL__ <= 710
let (r,ga') = GHC.getAndRemoveAnnotation ga sp an
kw = an
#else
let (r,ga',kw) = case GHC.getAndRemoveAnnotation ga sp an of
([],_) -> (ss,g,k)
where
k = GHC.unicodeAnn an
(ss,g) = GHC.getAndRemoveAnnotation ga sp k
(ss,g) -> (ss,g,an)
#endif
modify (\s -> s { apAnns = ga' })
return (r,kw)
getOneAnnotationDelta :: GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)
getOneAnnotationDelta an = do
ss <- getSrcSpan
getAndRemoveOneAnnotationDelta ss an
getAndRemoveOneAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)
getAndRemoveOneAnnotationDelta sp an = do
(anns,cs) <- gets apAnns
#if __GLASGOW_HASKELL__ <= 710
let (r,ga',kw) = case Map.lookup (sp,an) anns of
Nothing -> ([],(anns,cs),an)
Just [] -> ([], (Map.delete (sp,an) anns,cs),an)
Just (s:ss) -> ([s],(Map.insert (sp,an) ss anns,cs),an)
#else
let getKw kw =
case Map.lookup (sp,kw) anns of
Nothing -> ([],(anns,cs),kw)
Just [] -> ([], (Map.delete (sp,kw) anns,cs),kw)
Just (s:ss) -> ([s],(Map.insert (sp,kw) ss anns,cs),kw)
let (r,ga',kw) =
case getKw an of
([],_,_) -> getKw (GHC.unicodeAnn an)
v -> v
#endif
modify (\s -> s { apAnns = ga' })
return (r,kw)
addAnnotationsDelta :: Annotation -> Delta ()
addAnnotationsDelta ann = do
l <- ask
tellFinalAnn (getAnnKey l,ann)
getAnnKey :: DeltaOptions -> AnnKey
getAnnKey DeltaOptions {curSrcSpan, annConName}
= AnnKey curSrcSpan annConName
addAnnDeltaPos :: KeywordId -> DeltaPos -> Delta ()
addAnnDeltaPos kw dp = tellKd (kw, dp)
withAST :: Data a
=> GHC.Located a
-> Delta b -> Delta b
withAST lss@(GHC.L ss _) action = do
off <- gets apLayoutStart
(resetAnns . withSrcSpanDelta lss) (do
let maskWriter s = s { annKds = []
, sortKeys = Nothing
, dwCapturedSpan = mempty }
let spanStart = ss2pos ss
cs <- do
priorEndBeforeComments <- getPriorEnd
if GHC.isGoodSrcSpan ss && priorEndBeforeComments < ss2pos ss
then
commentAllocation (priorComment spanStart) return
else
return []
priorEndAfterComments <- getPriorEnd
let edp = adjustDeltaForOffset
off (ss2delta priorEndAfterComments ss)
when (GHC.isGoodSrcSpan ss && priorEndAfterComments < ss2pos ss) (do
modify (\s -> s { priorEndPosition = (ss2pos ss) } ))
(res, w) <- censor maskWriter (listen action)
let kds = annKds w
an = Ann
{ annEntryDelta = edp
, annPriorComments = cs
, annFollowingComments = []
, annsDP = kds
, annSortKey = sortKeys w
, annCapturedSpan = getFirst $ dwCapturedSpan w }
addAnnotationsDelta an
`debug` ("leaveAST:(annkey,an)=" ++ show (mkAnnKey lss,an))
return res)
resetAnns :: Delta a -> Delta a
resetAnns action = do
ans <- gets apAnns
action <* modify (\s -> s { apAnns = ans })
priorComment :: Pos -> Comment -> Bool
priorComment start c = (ss2pos . commentIdentifier $ c) < start
allocateComments :: (Comment -> Bool) -> [Comment] -> ([Comment], [Comment])
allocateComments = partition
addAnnotationWorker :: KeywordId -> GHC.SrcSpan -> Delta ()
addAnnotationWorker ann pa =
unless (isPointSrcSpan pa) $
do
pe <- getPriorEnd
ss <- getSrcSpan
let p = ss2delta pe pa
case (ann,isGoodDelta p) of
(G GHC.AnnComma,False) -> return ()
(G GHC.AnnSemi, False) -> return ()
(G GHC.AnnOpen, False) -> return ()
(G GHC.AnnClose,False) -> return ()
_ -> do
p' <- adjustDeltaForOffsetM p
commentAllocation (priorComment (ss2pos pa)) (mapM_ (uncurry addDeltaComment))
#if __GLASGOW_HASKELL__ <= 710
addAnnDeltaPos (checkUnicode ann pa) p'
#else
addAnnDeltaPos ann p'
#endif
setPriorEndAST pa
`debug` ("addAnnotationWorker:(ss,ss,pe,pa,p,p',ann)=" ++ show (showGhc ss,showGhc ss,pe,showGhc pa,p,p',ann))
#if __GLASGOW_HASKELL__ <= 710
checkUnicode :: KeywordId -> GHC.SrcSpan -> KeywordId
checkUnicode gkw@(G kw) ss =
if kw `Set.member` unicodeSyntax
then
let s = keywordToString gkw in
if (length s /= spanLength ss)
then AnnUnicode kw
else gkw
else
gkw
where
unicodeSyntax = Set.fromList
[ GHC.AnnDcolon
, GHC.AnnDarrow
, GHC.AnnForall
, GHC.AnnRarrow
, GHC.AnnLarrow
, GHC.Annlarrowtail
, GHC.Annrarrowtail
, GHC.AnnLarrowtail
, GHC.AnnRarrowtail]
checkUnicode kwid _ = kwid
#else
unicodeEquivalent :: GHC.AnnKeywordId -> [GHC.AnnKeywordId]
unicodeEquivalent kw =
case Map.lookup kw unicodeSyntax of
Nothing -> []
Just kwu -> [kwu]
where
unicodeSyntax = Map.fromList
[ (GHC.AnnDcolon, GHC.AnnDcolonU)
, (GHC.AnnDarrow, GHC.AnnDarrowU)
, (GHC.AnnForall, GHC.AnnForallU)
, (GHC.AnnRarrow, GHC.AnnRarrowU)
, (GHC.AnnLarrow, GHC.AnnLarrowU)
, (GHC.Annlarrowtail, GHC.AnnlarrowtailU)
, (GHC.Annrarrowtail, GHC.AnnrarrowtailU)
, (GHC.AnnLarrowtail, GHC.AnnLarrowtailU)
, (GHC.AnnRarrowtail, GHC.AnnRarrowtailU)]
#endif
commentAllocation :: (Comment -> Bool)
-> ([(Comment, DeltaPos)] -> Delta a)
-> Delta a
commentAllocation p k = do
cs <- getUnallocatedComments
let (allocated,cs') = allocateComments p cs
putUnallocatedComments cs'
k =<< mapM makeDeltaComment (sortBy (comparing commentIdentifier) allocated)
makeDeltaComment :: Comment -> Delta (Comment, DeltaPos)
makeDeltaComment c = do
let pa = commentIdentifier c
pe <- getPriorEnd
let p = ss2delta pe pa
p' <- adjustDeltaForOffsetM p
setPriorEnd (ss2posEnd pa)
return $ (c, p')
addDeltaComment :: Comment -> DeltaPos -> Delta ()
addDeltaComment d p = do
addAnnDeltaPos (AnnComment d) p
addDeltaAnnotation :: GHC.AnnKeywordId -> Delta ()
addDeltaAnnotation ann' = do
ss <- getSrcSpan
(ma,ann) <- getOneAnnotationDelta ann'
case nub ma of
[] -> return () `debug` ("addDeltaAnnotation empty ma for:" ++ show (ss,ann))
[pa] -> addAnnotationWorker (G ann) pa
(pa:_) -> addAnnotationWorker (G ann) pa `warn` ("addDeltaAnnotation:(ss,ann,ma)=" ++ showGhc (ss,ann,ma))
addDeltaAnnotationLs :: GHC.AnnKeywordId -> Int -> Delta ()
addDeltaAnnotationLs ann off = do
ss <- getSrcSpan
ma <- peekAnnotationDelta ann
let ma' = filter (\s -> (GHC.isSubspanOf s ss)) ma
case drop off ma' of
[] -> return ()
`debug` ("addDeltaAnnotationLs:missed:(off,ann,ma)=" ++ showGhc (off,ss,ann))
(pa:_) -> addAnnotationWorker (G ann) pa
addDeltaAnnotations :: GHC.AnnKeywordId -> Delta ()
addDeltaAnnotations ann = do
(ma,kw) <- getAnnotationDelta ann
let do_one ap' = addAnnotationWorker (G kw) ap'
`debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann))
mapM_ do_one (sort ma)
addDeltaAnnotationsInside :: GHC.AnnKeywordId -> Delta ()
addDeltaAnnotationsInside ann = do
ss <- getSrcSpan
ma <- peekAnnotationDelta ann
let do_one ap' = addAnnotationWorker (G ann) ap'
let filtered = sort $ filter (\s -> GHC.isSubspanOf s ss) ma
mapM_ do_one filtered
addDeltaAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Delta ()
addDeltaAnnotationsOutside gann ann = do
ss <- getSrcSpan
(ma,kw) <- getAndRemoveAnnotationDelta ss gann
let do_one ap' = if ann == AnnSemiSep
then addAnnotationWorker ann ap'
else addAnnotationWorker (G kw) ap'
mapM_ do_one (sort $ filter (\s -> not (GHC.isSubspanOf s ss)) ma)
addDeltaAnnotationExt :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ()
addDeltaAnnotationExt s ann = addAnnotationWorker (G ann) s
addEofAnnotation :: Delta ()
addEofAnnotation = do
pe <- getPriorEnd
(ma,_kw) <- withSrcSpanDelta (GHC.noLoc ()) (getAnnotationDelta GHC.AnnEofPos)
case ma of
[] -> return ()
(pa:pss) -> do
commentAllocation (const True) (mapM_ (uncurry addDeltaComment))
let DP (r,c) = ss2delta pe pa
addAnnDeltaPos (G GHC.AnnEofPos) (DP (r, c 1))
setPriorEndAST pa `warn` ("Trailing annotations after Eof: " ++ showGhc pss)
countAnnsDelta :: GHC.AnnKeywordId -> Delta Int
countAnnsDelta ann = do
ma <- peekAnnotationDelta ann
return (length ma)