ApiAnnotation.hs

{-# 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 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

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

-- | The comment string with delimiters removed.
commentText :: LEpaComment -> String
commentText = trimCommentDelims . comment_

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

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

-- Pragmas have the form @{-# ...#-}@.
pragmas :: EpAnnComments -> [(LEpaComment, String)]
pragmas 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).
  reverse
    [ (c, s) |
        c@(L _ (EpaComment (EpaBlockComment comm) _)) <- priorComments x
      , let body = trimCommentDelims comm
      , Just rest <- [stripSuffix "#" =<< stripPrefix "#" body]
      , let s = trim rest
    ]

-- All the extensions defined to be used.
extensions :: EpAnnComments -> Set.Set Extension
extensions = Set.fromList . concatMap (mapMaybe readExtension . snd) . languagePragmas . pragmas

-- Utility for a case insensitive prefix strip.
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. 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 ps =
  -- Old versions of GHC accepted 'OPTIONS' rather than 'OPTIONS_GHC' (but
  -- this is deprecated).
  [(c, opts) | (c, s) <- ps
             , Just rest <- [stripPrefixCI "OPTIONS_GHC " s
                             <|> stripPrefixCI "OPTIONS " s]
             , let opts = words 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 ps =
  [(c, exts) | (c, s) <- ps
             , Just rest <- [stripPrefixCI "LANGUAGE " s]
             , let exts = map trim (splitOn "," rest)]

-- Given a list of flags, make a GHC options pragma.
mkFlags :: NoCommentsLocation -> [String] -> LEpaComment
mkFlags anc flags =
  L anc $ EpaComment (EpaBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")) (epaLocationRealSrcSpan anc)

mkLanguagePragmas :: NoCommentsLocation -> [String] -> LEpaComment
mkLanguagePragmas anc exts =
  L anc $ EpaComment (EpaBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")) (epaLocationRealSrcSpan anc)