{-# 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 Data.Text qualified as T
import Data.Text.Encoding qualified as T
import GHC.Data.FastString (bytesFS, mkFastString)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.DynFlags (baseDynFlags)
import GHC.Parser.Lexer qualified 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]) -> 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]) -> P [Token] -> P [Token]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P [Token]
go