{-# LANGUAGE ImportQualifiedPost #-}

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.Hs.DocString
import GHC.Types.SrcLoc

import Language.Haskell.GhclibParserEx.GHC.Driver.Session

import Control.Applicative
import Data.List.Extra
import Data.Maybe
import Data.Set qualified as Set

trimCommentStart :: String -> String
trimCommentStart :: String -> String
trimCommentStart String
s
    | Just String
s <- forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"{-" String
s = String
s
    | Just String
s <- forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"--" String
s = String
s
    | Bool
otherwise = String
s

trimCommentEnd :: String -> String
trimCommentEnd :: String -> String
trimCommentEnd String
s
    | Just String
s <- forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix String
"-}" String
s = String
s
    | Bool
otherwise = String
s

trimCommentDelims :: String -> String
trimCommentDelims :: String -> String
trimCommentDelims = String -> String
trimCommentEnd forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
trimCommentStart

-- | A comment as a string.
comment_ :: LEpaComment -> String
comment_ :: LEpaComment -> String
comment_ (L Anchor
_ (EpaComment (EpaDocComment HsDocString
ds ) RealSrcSpan
_)) = HsDocString -> String
renderHsDocString HsDocString
ds
comment_ (L Anchor
_ (EpaComment (EpaDocOptions String
s) RealSrcSpan
_)) = String
s
comment_ (L Anchor
_ (EpaComment (EpaLineComment String
s) RealSrcSpan
_)) = String
s
comment_ (L Anchor
_ (EpaComment (EpaBlockComment String
s) RealSrcSpan
_)) = String
s
comment_ (L Anchor
_ (EpaComment EpaCommentTok
EpaEofComment RealSrcSpan
_)) = String
""

-- | The comment string with delimiters removed.
commentText :: LEpaComment -> String
commentText :: LEpaComment -> String
commentText = String -> String
trimCommentDelims forall b c a. (b -> c) -> (a -> b) -> a -> c
. LEpaComment -> String
comment_

isCommentMultiline :: LEpaComment -> Bool
isCommentMultiline :: LEpaComment -> Bool
isCommentMultiline (L Anchor
_ (EpaComment (EpaBlockComment String
_) RealSrcSpan
_)) = Bool
True
isCommentMultiline LEpaComment
_ = Bool
False

-- Pragmas have the form @{-# ...#-}@.
pragmas :: EpAnnComments -> [(LEpaComment, String)]
pragmas :: EpAnnComments -> [(LEpaComment, String)]
pragmas EpAnnComments
x =
  -- 'EpaAnnComments' stores pragmas in reverse order to how they were
  -- encountered in the source file with the last at the head of the
  -- list (makes sense when you think about it).
  forall a. [a] -> [a]
reverse
    [ (LEpaComment
c, String
s) |
        c :: LEpaComment
c@(L Anchor
_ (EpaComment (EpaBlockComment String
comm) RealSrcSpan
_)) <- EpAnnComments -> [LEpaComment]
priorComments EpAnnComments
x
      , let body :: String
body = String -> String
trimCommentDelims String
comm
      , Just String
rest <- [forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix String
"#" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"#" String
body]
      , let s :: String
s = String -> String
trim String
rest
    ]

-- All the extensions defined to be used.
extensions :: EpAnnComments -> Set.Set Extension
extensions :: EpAnnComments -> Set Extension
extensions = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe Extension
readExtension forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(LEpaComment, String)] -> [(LEpaComment, [String])]
languagePragmas forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpAnnComments -> [(LEpaComment, String)]
pragmas

-- Utility for a case insensitive prefix strip.
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) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pref') String
str
  in if String -> String
lower String
str_pref forall a. Eq a => a -> a -> Bool
== String
pref' then forall a. a -> Maybe a
Just String
rest else forall a. Maybe a
Nothing

-- Flags. The first element of the pair is the comment that
-- sets the flags enumerated in the second element of the pair.
flags :: [(LEpaComment, String)] -> [(LEpaComment, [String])]
flags :: [(LEpaComment, String)] -> [(LEpaComment, [String])]
flags [(LEpaComment, String)]
ps =
  -- Old versions of GHC accepted 'OPTIONS' rather than 'OPTIONS_GHC' (but
  -- this is deprecated).
  [(LEpaComment
c, [String]
opts) | (LEpaComment
c, String
s) <- [(LEpaComment, String)]
ps
             , Just String
rest <- [String -> String -> Maybe String
stripPrefixCI String
"OPTIONS_GHC " String
s
                             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]

-- Language pragmas. The first element of the
-- pair is the (located) annotation comment that enables the
-- pragmas enumerated by the second element of the pair.
languagePragmas :: [(LEpaComment, String)] -> [(LEpaComment, [String])]
languagePragmas :: [(LEpaComment, String)] -> [(LEpaComment, [String])]
languagePragmas [(LEpaComment, String)]
ps =
  [(LEpaComment
c, [String]
exts) | (LEpaComment
c, String
s) <- [(LEpaComment, String)]
ps
             , Just String
rest <- [String -> String -> Maybe String
stripPrefixCI String
"LANGUAGE " String
s]
             , let exts :: [String]
exts = forall a b. (a -> b) -> [a] -> [b]
map String -> String
trim (forall a. (Partial, Eq a) => [a] -> [a] -> [[a]]
splitOn String
"," String
rest)]

-- Given a list of flags, make a GHC options pragma.
mkFlags :: Anchor -> [String] -> LEpaComment
mkFlags :: Anchor -> [String] -> LEpaComment
mkFlags Anchor
anc [String]
flags =
  forall l e. l -> e -> GenLocated l e
L Anchor
anc forall a b. (a -> b) -> a -> b
$ EpaCommentTok -> RealSrcSpan -> EpaComment
EpaComment (String -> EpaCommentTok
EpaBlockComment (String
"{-# " forall a. [a] -> [a] -> [a]
++ String
"OPTIONS_GHC " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
flags forall a. [a] -> [a] -> [a]
++ String
" #-}")) (Anchor -> RealSrcSpan
anchor Anchor
anc)

mkLanguagePragmas :: Anchor -> [String] -> LEpaComment
mkLanguagePragmas :: Anchor -> [String] -> LEpaComment
mkLanguagePragmas Anchor
anc [String]
exts =
  forall l e. l -> e -> GenLocated l e
L Anchor
anc forall a b. (a -> b) -> a -> b
$ EpaCommentTok -> RealSrcSpan -> EpaComment
EpaComment (String -> EpaCommentTok
EpaBlockComment (String
"{-# " forall a. [a] -> [a] -> [a]
++ String
"LANGUAGE " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
exts forall a. [a] -> [a] -> [a]
++ String
" #-}")) (Anchor -> RealSrcSpan
anchor Anchor
anc)