module GHC.Util.ApiAnnotation (
comment, commentText, isCommentMultiline
, pragmas, flags, languagePragmas
, mkFlags, mkLanguagePragmas
) where
import ApiAnnotation
import SrcLoc
import Control.Applicative
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.List.Extra
trimCommentStart :: String -> String
trimCommentStart s
| Just s <- stripPrefix "{-" s = s
| Just s <- stripPrefix "--" s = s
| otherwise = s
trimCommentEnd :: String -> String
trimCommentEnd s
| Just s <- stripSuffix "-}" s = s
| otherwise = s
trimCommentDelims :: String -> String
trimCommentDelims = trimCommentEnd . trimCommentStart
comment :: Located AnnotationComment -> String
comment (L _ (AnnBlockComment s)) = s
comment (L _ (AnnLineComment s)) = s
comment (L _ (AnnDocOptions s)) = s
comment (L _ (AnnDocCommentNamed s)) = s
comment (L _ (AnnDocCommentPrev s)) = s
comment (L _ (AnnDocCommentNext s)) = s
comment (L _ (AnnDocSection _ s)) = s
commentText :: Located AnnotationComment -> String
commentText = trimCommentDelims . comment
isCommentMultiline :: Located AnnotationComment -> Bool
isCommentMultiline (L _ (AnnBlockComment _)) = True
isCommentMultiline _ = False
pragmas :: ApiAnns -> [(Located AnnotationComment, String)]
pragmas anns =
reverse
[ (c, s) |
c@(L _ (AnnBlockComment comm)) <- fromMaybe [] $ Map.lookup noSrcSpan (snd anns)
, let body = trimCommentDelims comm
, Just rest <- [stripSuffix "#" =<< stripPrefix "#" body]
, let s = trim rest
]
stripPrefixCI :: String -> String -> Maybe String
stripPrefixCI pref str =
let pref' = lower pref
(str_pref, rest) = splitAt (length pref') str
in if lower str_pref == pref' then Just rest else Nothing
flags :: [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])]
flags ps =
[(c, opts) | (c, s) <- ps
, Just rest <- [stripPrefixCI "OPTIONS_GHC " s
<|> stripPrefixCI "OPTIONS " s]
, let opts = words rest]
languagePragmas :: [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])]
languagePragmas ps =
[(c, exts) | (c, s) <- ps
, Just rest <- [stripPrefixCI "LANGUAGE " s]
, let exts = map trim (splitOn "," rest)]
mkFlags :: SrcSpan -> [String] -> Located AnnotationComment
mkFlags loc flags =
L loc $ AnnBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")
mkLanguagePragmas :: SrcSpan -> [String] -> Located AnnotationComment
mkLanguagePragmas loc exts =
L loc $ AnnBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")