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

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

    import Control.Monad
    import Data.Char (isSpace, toLower)
    import qualified Data.List as L
    import qualified EnumSet as ES
    import FastString (mkFastString, unpackFS)
    import qualified Lexer as L
    import Module (ComponentId (..), newSimpleUnitId)
    import SrcLoc
    import StringBuffer

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

    -- | Extract a pragma from a comment if possible, or return 'Nothing'
    -- otherwise.
    parsePragma ::
      -- | Comment to try to parse
      String ->
      Maybe Pragma
    parsePragma :: String -> Maybe Pragma
    parsePragma input :: String
    input = do
      String
    inputNoPrefix <- String -> String -> Maybe String
    forall a. Eq a => [a] -> [a] -> Maybe [a]
    L.stripPrefix "{-#" String
    input
      Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard ("#-}" String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `L.isSuffixOf` String
    input)
      let contents :: String
    contents = Int -> ShowS
    forall a. Int -> [a] -> [a]
    take (String -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    inputNoPrefix Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - 3) String
    inputNoPrefix
          (pragmaName :: String
    pragmaName, cs :: String
    cs) = ((Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break Char -> Bool
    isSpace (String -> (String, String)) -> ShowS -> String -> (String, String)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> ShowS
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace) String
    contents
      case Char -> Char
    toLower (Char -> Char) -> ShowS
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String
    pragmaName of
        "language" -> [String] -> Pragma
    PragmaLanguage ([String] -> Pragma) -> Maybe [String] -> Maybe Pragma
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Maybe [String]
    parseExtensions String
    cs
        "options_ghc" -> Pragma -> Maybe Pragma
    forall a. a -> Maybe a
    Just (Pragma -> Maybe Pragma) -> Pragma -> Maybe Pragma
    forall a b. (a -> b) -> a -> b
    $ String -> Pragma
    PragmaOptionsGHC (ShowS
    trimSpaces String
    cs)
        "options_haddock" -> Pragma -> Maybe Pragma
    forall a. a -> Maybe a
    Just (Pragma -> Maybe Pragma) -> Pragma -> Maybe Pragma
    forall a b. (a -> b) -> a -> b
    $ String -> Pragma
    PragmaOptionsHaddock (ShowS
    trimSpaces String
    cs)
        _ -> Maybe Pragma
    forall a. Maybe a
    Nothing
      where
        trimSpaces :: String -> String
        trimSpaces :: ShowS
    trimSpaces = (Char -> Bool) -> ShowS
    forall a. (a -> Bool) -> [a] -> [a]
    L.dropWhileEnd Char -> Bool
    isSpace ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> ShowS
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace

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

    -- | Tokenize a given input using GHC's lexer.
    tokenize :: String -> Maybe [L.Token]
    tokenize :: String -> Maybe [Token]
    tokenize input :: String
    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 _ x :: [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 "") 1 1
        buffer :: StringBuffer
    buffer = String -> StringBuffer
    stringToStringBuffer String
    input
        parseState :: PState
    parseState = ParserFlags -> StringBuffer -> RealSrcLoc -> PState
    L.mkPStatePure ParserFlags
    parserFlags StringBuffer
    buffer RealSrcLoc
    location
        parserFlags :: ParserFlags
    parserFlags =
          EnumSet WarningFlag
    -> EnumSet Extension
    -> UnitId
    -> Bool
    -> Bool
    -> Bool
    -> Bool
    -> ParserFlags
    L.mkParserFlags'
            EnumSet WarningFlag
    forall a. EnumSet a
    ES.empty
            EnumSet Extension
    forall a. EnumSet a
    ES.empty
            (ComponentId -> UnitId
    newSimpleUnitId (FastString -> ComponentId
    ComponentId (String -> FastString
    mkFastString "")))
            Bool
    True
            Bool
    True
            Bool
    True
            Bool
    True

    -- | 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 (m :: * -> *) a. Monad m => a -> m a
    return
          case Located Token -> SrcSpanLess (Located Token)
    forall a. HasSrcSpan a => a -> SrcSpanLess a
    unLoc Located Token
    r of
            L.ITeof -> [Token] -> P [Token]
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
            x :: SrcSpanLess (Located Token)
    x -> (Token
    SrcSpanLess (Located 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