module GHC.Util.ApiAnnotation (
comment, commentText, isCommentMultiline
, pragmas, flags, languagePragmas
, mkFlags, mkLanguagePragmas
, extensions
) where
import GHC.LanguageExtensions.Type (Extension)
import GHC.Parser.Annotation
import GHC.Types.SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Driver.Session
import Control.Applicative
import Data.List.Extra
import Data.Maybe
import qualified Data.Set as Set
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 :: forall a. RealLocated a -> Located a
realToLoc (L RealSrcSpan
r a
x) = SrcSpan -> a -> GenLocated SrcSpan 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
extensions :: ApiAnns -> Set.Set Extension
extensions :: ApiAnns -> Set Extension
extensions = [Extension] -> Set Extension
forall a. Ord a => [a] -> Set a
Set.fromList ([Extension] -> Set Extension)
-> (ApiAnns -> [Extension]) -> ApiAnns -> Set Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe Extension) -> [String] -> [Extension]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe Extension
readExtension ([String] -> [Extension])
-> (ApiAnns -> [String]) -> ApiAnns -> [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
((Located AnnotationComment, [String]) -> [String])
-> [(Located AnnotationComment, [String])] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Located AnnotationComment, [String]) -> [String]
forall a b. (a, b) -> b
snd ([(Located AnnotationComment, [String])] -> [String])
-> (ApiAnns -> [(Located AnnotationComment, [String])])
-> ApiAnns
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])]
languagePragmas ([(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])])
-> (ApiAnns -> [(Located AnnotationComment, String)])
-> ApiAnns
-> [(Located AnnotationComment, [String])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApiAnns -> [(Located AnnotationComment, String)]
pragmas
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
" #-}")