{-# 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 GHC.Data.EnumSet as ES
import GHC.Data.FastString (mkFastString, unpackFS)
import GHC.Data.StringBuffer
import qualified GHC.Parser.Lexer as L
import GHC.Types.SrcLoc
import GHC.Unit.Module (stringToUnitId)

-- | 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 -> [Char]
(Int -> Pragma -> ShowS)
-> (Pragma -> [Char]) -> ([Pragma] -> ShowS) -> Show Pragma
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Pragma] -> ShowS
$cshowList :: [Pragma] -> ShowS
show :: Pragma -> [Char]
$cshow :: Pragma -> [Char]
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 :: [Char] -> Maybe Pragma
parsePragma [Char]
input = do
  [Char]
inputNoPrefix <- [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
L.stripPrefix [Char]
"{-#" [Char]
input
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([Char]
"#-}" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` [Char]
input)
  let contents :: [Char]
contents = Int -> ShowS
forall a. Int -> [a] -> [a]
take ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
inputNoPrefix Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) [Char]
inputNoPrefix
      ([Char]
pragmaName, [Char]
cs) = ((Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace ([Char] -> ([Char], [Char])) -> ShowS -> [Char] -> ([Char], [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace) [Char]
contents
  case Char -> Char
toLower (Char -> Char) -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char]
pragmaName of
    [Char]
"language" -> [[Char]] -> Pragma
PragmaLanguage ([[Char]] -> Pragma) -> Maybe [[Char]] -> Maybe Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Maybe [[Char]]
parseExtensions [Char]
cs
    [Char]
"options_ghc" -> Pragma -> Maybe Pragma
forall a. a -> Maybe a
Just (Pragma -> Maybe Pragma) -> Pragma -> Maybe Pragma
forall a b. (a -> b) -> a -> b
$ [Char] -> Pragma
PragmaOptionsGHC (ShowS
trimSpaces [Char]
cs)
    [Char]
"options_haddock" -> Pragma -> Maybe Pragma
forall a. a -> Maybe a
Just (Pragma -> Maybe Pragma) -> Pragma -> Maybe Pragma
forall a b. (a -> b) -> a -> b
$ [Char] -> Pragma
PragmaOptionsHaddock (ShowS
trimSpaces [Char]
cs)
    [Char]
_ -> 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 :: [Char] -> Maybe [[Char]]
parseExtensions [Char]
str = [Char] -> Maybe [Token]
tokenize [Char]
str Maybe [Token] -> ([Token] -> Maybe [[Char]]) -> Maybe [[Char]]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Token] -> Maybe [[Char]]
go
  where
    go :: [Token] -> Maybe [[Char]]
go = \case
      [L.ITconid FastString
ext] -> [[Char]] -> Maybe [[Char]]
forall (m :: * -> *) a. Monad m => a -> m a
return [FastString -> [Char]
unpackFS FastString
ext]
      (L.ITconid FastString
ext : Token
L.ITcomma : [Token]
xs) -> (FastString -> [Char]
unpackFS FastString
ext [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:) ([[Char]] -> [[Char]]) -> Maybe [[Char]] -> Maybe [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token] -> Maybe [[Char]]
go [Token]
xs
      [Token]
_ -> Maybe [[Char]]
forall a. Maybe a
Nothing

-- | Tokenize a given input using GHC's lexer.
tokenize :: String -> Maybe [L.Token]
tokenize :: [Char] -> Maybe [Token]
tokenize [Char]
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 ([Char] -> FastString
mkFastString [Char]
"") Int
1 Int
1
    buffer :: StringBuffer
buffer = [Char] -> StringBuffer
stringToStringBuffer [Char]
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
        ([Char] -> UnitId
stringToUnitId [Char]
"")
        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 -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
r of
        Token
L.ITeof -> [Token] -> P [Token]
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