    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE OverloadedStrings #-}

    -- | A module for parsing of pragmas from comments.
    module Ormolu.Parser.Pragma
      ( Pragma (..),
        parsePragma,
      )
    where

    import Data.Char (isSpace)
    import Data.Text (Text)
    import qualified Data.Text as T
    import qualified Data.Text.Encoding as T
    import GHC.Data.FastString (bytesFS, mkFastString)
    import GHC.Driver.Config.Parser (initParserOpts)
    import GHC.DynFlags (baseDynFlags)
    import qualified GHC.Parser.Lexer as L
    import GHC.Types.SrcLoc
    import Ormolu.Utils (textToStringBuffer)

    -- | Ormolu's representation of pragmas.
    data Pragma
      = -- | Language pragma
        PragmaLanguage [Text]
      | -- | GHC options pragma
        PragmaOptionsGHC Text
      | -- | Haddock options pragma
        PragmaOptionsHaddock Text
      deriving (Int -> Pragma -> ShowS
    [Pragma] -> ShowS
    Pragma -> String
    (Int -> Pragma -> ShowS)
    -> (Pragma -> String) -> ([Pragma] -> ShowS) -> Show Pragma
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Pragma -> ShowS
    showsPrec :: Int -> Pragma -> ShowS
    $cshow :: Pragma -> String
    show :: Pragma -> String
    $cshowList :: [Pragma] -> ShowS
    showList :: [Pragma] -> ShowS
    Show, Pragma -> Pragma -> Bool
    (Pragma -> Pragma -> Bool)
    -> (Pragma -> Pragma -> Bool) -> Eq Pragma
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Pragma -> Pragma -> Bool
    == :: Pragma -> Pragma -> Bool
    $c/= :: Pragma -> Pragma -> Bool
    /= :: Pragma -> Pragma -> Bool
    Eq)

    -- | Extract a pragma from a comment if possible, or return 'Nothing'
    -- otherwise.
    parsePragma ::
      -- | Comment to try to parse
      Text ->
      Maybe Pragma
    parsePragma :: Text -> Maybe Pragma
    parsePragma Text
    input = do
      Text
    contents <- Text -> Text -> Maybe Text
    T.stripSuffix Text
    "#-}" (Text -> Maybe Text) -> Maybe Text -> Maybe Text
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< Text -> Text -> Maybe Text
    T.stripPrefix Text
    "{-#" Text
    input
      let (Text
    pragmaName, Text
    cs) = ((Char -> Bool) -> Text -> (Text, Text)
    T.break Char -> Bool
    isSpace (Text -> (Text, Text)) -> (Text -> Text) -> Text -> (Text, Text)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> Text -> Text
    T.dropWhile Char -> Bool
    isSpace) Text
    contents
      case Text -> Text
    T.toLower Text
    pragmaName of
        Text
    "language" -> [Text] -> Pragma
    PragmaLanguage ([Text] -> Pragma) -> Maybe [Text] -> Maybe Pragma
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Text -> Maybe [Text]
    parseExtensions Text
    cs
        Text
    "options_ghc" -> Pragma -> Maybe Pragma
    forall a. a -> Maybe a
    Just (Pragma -> Maybe Pragma) -> Pragma -> Maybe Pragma
    forall a b. (a -> b) -> a -> b
    $ Text -> Pragma
    PragmaOptionsGHC (Text -> Text
    T.strip Text
    cs)
        Text
    "options_haddock" -> Pragma -> Maybe Pragma
    forall a. a -> Maybe a
    Just (Pragma -> Maybe Pragma) -> Pragma -> Maybe Pragma
    forall a b. (a -> b) -> a -> b
    $ Text -> Pragma
    PragmaOptionsHaddock (Text -> Text
    T.strip Text
    cs)
        Text
    _ -> Maybe Pragma
    forall a. Maybe a
    Nothing

    -- | Assuming the input consists of a series of tokens from a language
    -- pragma, return the set of enabled extensions.
    parseExtensions :: Text -> Maybe [Text]
    parseExtensions :: Text -> Maybe [Text]
    parseExtensions Text
    str = Text -> Maybe [Token]
    tokenize Text
    str Maybe [Token] -> ([Token] -> Maybe [Text]) -> Maybe [Text]
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= [Token] -> Maybe [Text]
    go
      where
        go :: [Token] -> Maybe [Text]
    go = \case
          [L.ITconid FastString
    ext] -> [Text] -> Maybe [Text]
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [FastString -> Text
    fsToText FastString
    ext]
          (L.ITconid FastString
    ext : Token
    L.ITcomma : [Token]
    xs) -> (FastString -> Text
    fsToText FastString
    ext Text -> [Text] -> [Text]
    forall a. a -> [a] -> [a]
    :) ([Text] -> [Text]) -> Maybe [Text] -> Maybe [Text]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Token] -> Maybe [Text]
    go [Token]
    xs
          [Token]
    _ -> Maybe [Text]
    forall a. Maybe a
    Nothing
        fsToText :: FastString -> Text
    fsToText = ByteString -> Text
    T.decodeUtf8 (ByteString -> Text)
    -> (FastString -> ByteString) -> FastString -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . FastString -> ByteString
    bytesFS

    -- | Tokenize a given input using GHC's lexer.
    tokenize :: Text -> Maybe [L.Token]
    tokenize :: Text -> Maybe [Token]
    tokenize Text
    input =
      case P [Token] -> PState -> ParseResult [Token]
    forall a. P a -> PState -> ParseResult a
    L.unP P [Token]
    pLexer PState
    parseState of
        L.PFailed {} -> Maybe [Token]
    forall a. Maybe a
    Nothing
        L.POk PState
    _ [Token]
    x -> [Token] -> Maybe [Token]
    forall a. a -> Maybe a
    Just [Token]
    x
      where
        location :: RealSrcLoc
    location = FastString -> Int -> Int -> RealSrcLoc
    mkRealSrcLoc (String -> FastString
    mkFastString String
    "") Int
    1 Int
    1
        buffer :: StringBuffer
    buffer = Text -> StringBuffer
    textToStringBuffer Text
    input
        parseState :: PState
    parseState = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
    L.initParserState ParserOpts
    parserOpts StringBuffer
    buffer RealSrcLoc
    location
        parserOpts :: ParserOpts
    parserOpts = DynFlags -> ParserOpts
    initParserOpts DynFlags
    baseDynFlags

    -- | Haskell lexer.
    pLexer :: L.P [L.Token]
    pLexer :: P [Token]
    pLexer = P [Token]
    go
      where
        go :: P [Token]
    go = do
          Located Token
    r <- Bool -> (Located Token -> P (Located Token)) -> P (Located Token)
    forall a. Bool -> (Located Token -> P a) -> P a
    L.lexer Bool
    False Located Token -> P (Located Token)
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return
          case Located Token -> Token
    forall l e. GenLocated l e -> e
    unLoc Located Token
    r of
            Token
    L.ITeof -> [Token] -> P [Token]
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
            Token
    x -> (Token
    x Token -> [Token] -> [Token]
    forall a. a -> [a] -> [a]
    :) ([Token] -> [Token]) -> P [Token] -> P [Token]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> P [Token]
    go