module GHC.Util.ApiAnnotation (
comment, commentText, isCommentMultiline
, pragmas, flags, languagePragmas
, mkFlags, mkLanguagePragmas
) where
import GHC.Parser.Annotation
import GHC.Types.SrcLoc
import Control.Applicative
import Data.List.Extra
trimCommentStart :: String -> String
String
s
| Just String
s <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"{-" String
s = String
s
| Just String
s <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"--" String
s = String
s
| Bool
otherwise = String
s
trimCommentEnd :: String -> String
String
s
| Just String
s <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix String
"-}" String
s = String
s
| Bool
otherwise = String
s
trimCommentDelims :: String -> String
= String -> String
trimCommentEnd (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
trimCommentStart
comment :: Located AnnotationComment -> String
(L SrcSpan
_ (AnnBlockComment String
s)) = String
s
comment (L SrcSpan
_ (AnnLineComment String
s)) = String
s
comment (L SrcSpan
_ (AnnDocOptions String
s)) = String
s
comment (L SrcSpan
_ (AnnDocCommentNamed String
s)) = String
s
comment (L SrcSpan
_ (AnnDocCommentPrev String
s)) = String
s
comment (L SrcSpan
_ (AnnDocCommentNext String
s)) = String
s
comment (L SrcSpan
_ (AnnDocSection Int
_ String
s)) = String
s
commentText :: Located AnnotationComment -> String
= String -> String
trimCommentDelims (String -> String)
-> (Located AnnotationComment -> String)
-> Located AnnotationComment
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located AnnotationComment -> String
comment
isCommentMultiline :: Located AnnotationComment -> Bool
(L SrcSpan
_ (AnnBlockComment String
_)) = Bool
True
isCommentMultiline Located AnnotationComment
_ = Bool
False
pragmas :: ApiAnns -> [(Located AnnotationComment, String)]
pragmas :: ApiAnns -> [(Located AnnotationComment, String)]
pragmas ApiAnns
anns =
[(Located AnnotationComment, String)]
-> [(Located AnnotationComment, String)]
forall a. [a] -> [a]
reverse
[ (RealLocated AnnotationComment -> Located AnnotationComment
forall a. RealLocated a -> Located a
realToLoc RealLocated AnnotationComment
c, String
s) |
c :: RealLocated AnnotationComment
c@(L RealSrcSpan
_ (AnnBlockComment String
comm)) <- ApiAnns -> [RealLocated AnnotationComment]
apiAnnRogueComments ApiAnns
anns
, let body :: String
body = String -> String
trimCommentDelims String
comm
, Just String
rest <- [String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix String
"#" (String -> Maybe String) -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"#" String
body]
, let s :: String
s = String -> String
trim String
rest
]
where
realToLoc :: RealLocated a -> Located a
realToLoc :: RealLocated a -> Located a
realToLoc (L RealSrcSpan
r a
x) = SrcSpan -> a -> Located a
forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
r Maybe BufSpan
forall a. Maybe a
Nothing) a
x
stripPrefixCI :: String -> String -> Maybe String
stripPrefixCI :: String -> String -> Maybe String
stripPrefixCI String
pref String
str =
let pref' :: String
pref' = String -> String
lower String
pref
(String
str_pref, String
rest) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pref') String
str
in if String -> String
lower String
str_pref String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
pref' then String -> Maybe String
forall a. a -> Maybe a
Just String
rest else Maybe String
forall a. Maybe a
Nothing
flags :: [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])]
flags :: [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])]
flags [(Located AnnotationComment, String)]
ps =
[(Located AnnotationComment
c, [String]
opts) | (Located AnnotationComment
c, String
s) <- [(Located AnnotationComment, String)]
ps
, Just String
rest <- [String -> String -> Maybe String
stripPrefixCI String
"OPTIONS_GHC " String
s
Maybe String -> Maybe String -> Maybe String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> String -> Maybe String
stripPrefixCI String
"OPTIONS " String
s]
, let opts :: [String]
opts = String -> [String]
words String
rest]
languagePragmas :: [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])]
languagePragmas :: [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])]
languagePragmas [(Located AnnotationComment, String)]
ps =
[(Located AnnotationComment
c, [String]
exts) | (Located AnnotationComment
c, String
s) <- [(Located AnnotationComment, String)]
ps
, Just String
rest <- [String -> String -> Maybe String
stripPrefixCI String
"LANGUAGE " String
s]
, let exts :: [String]
exts = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
trim (String -> String -> [String]
forall a. (Partial, Eq a) => [a] -> [a] -> [[a]]
splitOn String
"," String
rest)]
mkFlags :: SrcSpan -> [String] -> Located AnnotationComment
mkFlags :: SrcSpan -> [String] -> Located AnnotationComment
mkFlags SrcSpan
loc [String]
flags =
SrcSpan -> AnnotationComment -> Located AnnotationComment
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (AnnotationComment -> Located AnnotationComment)
-> AnnotationComment -> Located AnnotationComment
forall a b. (a -> b) -> a -> b
$ String -> AnnotationComment
AnnBlockComment (String
"{-# " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"OPTIONS_GHC " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
flags String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" #-}")
mkLanguagePragmas :: SrcSpan -> [String] -> Located AnnotationComment
mkLanguagePragmas :: SrcSpan -> [String] -> Located AnnotationComment
mkLanguagePragmas SrcSpan
loc [String]
exts =
SrcSpan -> AnnotationComment -> Located AnnotationComment
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (AnnotationComment -> Located AnnotationComment)
-> AnnotationComment -> Located AnnotationComment
forall a b. (a -> b) -> a -> b
$ String -> AnnotationComment
AnnBlockComment (String
"{-# " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"LANGUAGE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
exts String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" #-}")