{-# LANGUAGE ImportQualifiedPost #-}

module GHC.Util.ApiAnnotation (
    comment_
  , commentText
  , GHC.Util.ApiAnnotation.comments
  , 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 <- 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
trimCommentEnd :: String -> String
trimCommentEnd 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
trimCommentDelims :: String -> String
trimCommentDelims = String -> String
trimCommentEnd (String -> String) -> (String -> String) -> String -> String
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 (String -> String)
-> (LEpaComment -> String) -> LEpaComment -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LEpaComment -> String
comment_

-- | Total replacement for the partial `GHC.Parser.Annotation.comments` field of
-- `EpAnn`
comments :: EpAnn ann -> EpAnnComments
comments :: forall ann. EpAnn ann -> EpAnnComments
comments EpAnn{ comments :: forall ann. EpAnn ann -> EpAnnComments
GHC.Parser.Annotation.comments = EpAnnComments
result } = EpAnnComments
result
comments EpAnn ann
EpAnnNotUsed = EpAnnComments
emptyComments

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).
  [(LEpaComment, String)] -> [(LEpaComment, String)]
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 <- [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
    ]

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

-- Given a list of flags, make a GHC options pragma.
mkFlags :: Anchor -> [String] -> LEpaComment
mkFlags :: Anchor -> [String] -> LEpaComment
mkFlags Anchor
anc [String]
flags =
  Anchor -> EpaComment -> LEpaComment
forall l e. l -> e -> GenLocated l e
L Anchor
anc (EpaComment -> LEpaComment) -> EpaComment -> LEpaComment
forall a b. (a -> b) -> a -> b
$ EpaCommentTok -> RealSrcSpan -> EpaComment
EpaComment (String -> EpaCommentTok
EpaBlockComment (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
" #-}")) (Anchor -> RealSrcSpan
anchor Anchor
anc)

mkLanguagePragmas :: Anchor -> [String] -> LEpaComment
mkLanguagePragmas :: Anchor -> [String] -> LEpaComment
mkLanguagePragmas Anchor
anc [String]
exts =
  Anchor -> EpaComment -> LEpaComment
forall l e. l -> e -> GenLocated l e
L Anchor
anc (EpaComment -> LEpaComment) -> EpaComment -> LEpaComment
forall a b. (a -> b) -> a -> b
$ EpaCommentTok -> RealSrcSpan -> EpaComment
EpaComment (String -> EpaCommentTok
EpaBlockComment (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
" #-}")) (Anchor -> RealSrcSpan
anchor Anchor
anc)