module Language.Haskell.Exts.SimpleComments
(
CodeComment (..), CommentPos (..)
, ppWithCommentsStyleModeParseMode
, ppWithCommentsStyleMode
, ppWithCommentsMode
, ppWithComments
, preComment, postComment, secComment
) where
import Control.Monad (forM, forM_, join)
import Control.Monad.ST.Strict
import Data.Foldable (any, foldl')
import Data.List (sortOn)
import Data.STRef
import Data.String (IsString (..))
import Language.Haskell.Exts.Comments
import Language.Haskell.Exts.Extension
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Pretty
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.Exts.Syntax
import Generics.ApplyTwins
data CodeComment
= CodeComment
{ ccPos :: !CommentPos
, ccSym :: !Char
, ccTxt :: !String
} deriving (Eq, Show, Read)
instance IsString CodeComment where
fromString = CodeComment NextToCode ' '
data CommentPos = AboveCode | BelowCode | NextToCode
deriving (Eq, Show, Read)
preComment :: String -> Maybe CodeComment
preComment "" = Nothing
preComment s = Just $ CodeComment AboveCode '|' s
postComment :: String -> Maybe CodeComment
postComment "" = Nothing
postComment s = Just $ CodeComment BelowCode '^' s
secComment :: String -> Maybe CodeComment
secComment "" = Nothing
secComment s = Just $ CodeComment AboveCode '*' s
ppWithComments :: Module (Maybe CodeComment)
-> (Module SrcSpanInfo, [Comment])
ppWithComments = ppWithCommentsMode defaultMode
ppWithCommentsMode :: PPHsMode
-> Module (Maybe CodeComment)
-> (Module SrcSpanInfo, [Comment])
ppWithCommentsMode = ppWithCommentsStyleMode style
ppWithCommentsStyleMode :: Style
-> PPHsMode
-> Module (Maybe CodeComment)
-> (Module SrcSpanInfo, [Comment])
ppWithCommentsStyleMode sty ppm
= ppWithCommentsStyleModeParseMode sty ppm defaultParseMode
ppWithCommentsStyleModeParseMode :: Style
-> PPHsMode
-> ParseMode
-> Module (Maybe CodeComment)
-> (Module SrcSpanInfo, [Comment])
ppWithCommentsStyleModeParseMode sty ppm parsem' m'' = runST $ do
mSt <- mapM (\(mt, sloc) -> (,) (sloc, mt) <$> newSTRef sloc) m
let (allLocRefs, allComments') = foldl' f ([],[]) mSt
where
f (ls, cs) ((_, Nothing), l)
= (l:ls, cs)
f (ls, cs) ((x, Just c), l)
= let shiftRight = isShiftRight x m'
shiftLoc = snd $ evalLoc (ccPos c) (srcInfoSpan x) shiftRight
in (l:ls, (shiftLoc, (c, l, shiftRight)):cs)
allComments = map snd $ sortOn fst $ reverse allComments'
ccs <- forM allComments $ \(comment, locref, shiftRight) -> do
loc <- readSTRef locref
let (comLoc, shiftLoc) = evalLoc (ccPos comment) (srcInfoSpan loc) shiftRight
(updateLoc, cs) = insertComments comLoc shiftLoc comment
forM_ allLocRefs $ flip modifySTRef updateLoc
return cs
mFin <- mapM (readSTRef . snd) mSt
return (mFin, join ccs)
where
m' :: Module SrcSpanInfo
m' = case parseModuleWithMode parsem $ prettyPrintStyleMode sty ppm m'' of
err@ParseFailed {} -> error $ show err
ParseOk r -> r
m :: Module (Maybe CodeComment, SrcSpanInfo)
m = apTwinsDef ((,) Nothing) ((,) <$> m'') m'
isShiftRight x = any (isToRight . srcInfoSpan)
where
s = srcInfoSpan x
isToRight z = srcSpanEndLine s == srcSpanStartLine z
&& srcSpanEndColumn s <= srcSpanStartColumn z
parsem = parsem' { extensions = extensions parsem' ++ getPragmas m''}
getPragmas (Module _ _ xs _ _)
= classifyExtension . getNContent <$> getLPragmas xs
getPragmas (XmlPage _ _ xs _ _ _ _)
= classifyExtension . getNContent <$> getLPragmas xs
getPragmas (XmlHybrid _ _ xs _ _ _ _ _ _)
= classifyExtension . getNContent <$> getLPragmas xs
getLPragmas [] = []
getLPragmas (LanguagePragma _ xs : ps) = xs ++ getLPragmas ps
getLPragmas (_:ps) = getLPragmas ps
getNContent (Ident _ s) = s
getNContent (Symbol _ s) = s
insertComments :: SrcLoc
-> SrcLoc
-> CodeComment
-> (SrcSpanInfo -> SrcSpanInfo, [Comment])
insertComments cmtLoc@(SrcLoc _ startL _)
(SrcLoc _ shiftL shiftC) com = (f, cmts)
where
cmts = mkComments cmtLoc (ccSym com) (ccTxt com)
lineN = length cmts + startL shiftL
f SrcSpanInfo {srcInfoSpan = s, srcInfoPoints = ps}
= SrcSpanInfo
{ srcInfoSpan = g s, srcInfoPoints = fmap g ps }
g s | srcSpanEndLine s < shiftL ||
srcSpanStartLine s == shiftL && srcSpanEndColumn s < shiftC
= s
| srcSpanStartLine s > shiftL ||
srcSpanStartLine s == shiftL && srcSpanStartColumn s >= shiftC 1
= s { srcSpanStartLine = srcSpanStartLine s + lineN
, srcSpanEndLine = srcSpanEndLine s + lineN
}
| otherwise
= s { srcSpanEndLine = srcSpanEndLine s + lineN }
evalLoc :: CommentPos
-> SrcSpan
-> Bool
-> (SrcLoc, SrcLoc)
evalLoc AboveCode SrcSpan {..} _ = ( loc, loc )
where
loc = SrcLoc srcSpanFilename srcSpanStartLine srcSpanStartColumn
evalLoc BelowCode SrcSpan {..} shiftRight = (locStart, locShift )
where
locStart = SrcLoc srcSpanFilename (srcSpanEndLine + 1) $
if srcSpanStartLine == srcSpanEndLine
then srcSpanStartColumn
else min srcSpanStartColumn srcSpanEndColumn
locShift = if shiftRight
then SrcLoc srcSpanFilename srcSpanEndLine (srcSpanEndColumn + 1)
else locStart { srcColumn = 1 }
evalLoc NextToCode SrcSpan {..} shiftRight = (locStart, locShift)
where
locStart = SrcLoc srcSpanFilename srcSpanEndLine (srcSpanEndColumn + 1)
locShift = if shiftRight
then locStart
else SrcLoc srcSpanFilename (srcSpanEndLine + 1) 1
mkComments :: SrcLoc
-> Char
-> String
-> [Comment]
mkComments SrcLoc {..} c txt = mkComment srcLine lns
where
lns = indent $ lines txt
indent [] = []
indent (x:xs) = if c == ' '
then map (' ':) (x:xs)
else (' ':c:' ':x) : map (" " ++) xs
mkComment _ [] = []
mkComment i (x:xs)
= Comment False
(SrcSpan srcFilename i srcColumn i $ srcColumn + 2 + length x) x
: mkComment (i+1) xs