{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Ormolu.Parser.Pragma
( Pragma (..),
parsePragma,
)
where
import Control.Monad
import Data.Char (isSpace, toLower)
import Data.List
import qualified EnumSet as ES
import FastString (mkFastString, unpackFS)
import qualified Lexer as L
import Module (ComponentId (..), newSimpleUnitId)
import SrcLoc
import StringBuffer
data Pragma
=
PragmaLanguage [String]
|
PragmaOptionsGHC String
|
PragmaOptionsHaddock String
deriving (Show, Eq)
parsePragma ::
String ->
Maybe Pragma
parsePragma input = do
inputNoPrefix <- stripPrefix "{-#" input
guard ("#-}" `isSuffixOf` input)
let contents = take (length inputNoPrefix - 3) inputNoPrefix
(pragmaName, cs) = (break isSpace . dropWhile isSpace) contents
case toLower <$> pragmaName of
"language" -> PragmaLanguage <$> parseExtensions cs
"options_ghc" -> Just $ PragmaOptionsGHC (trimSpaces cs)
"options_haddock" -> Just $ PragmaOptionsHaddock (trimSpaces cs)
_ -> Nothing
where
trimSpaces :: String -> String
trimSpaces = dropWhileEnd isSpace . dropWhile isSpace
parseExtensions :: String -> Maybe [String]
parseExtensions str = tokenize str >>= go
where
go = \case
(L.ITconid ext : []) -> return [unpackFS ext]
(L.ITconid ext : L.ITcomma : xs) -> (unpackFS ext :) <$> go xs
_ -> Nothing
tokenize :: String -> Maybe [L.Token]
tokenize input =
case L.unP pLexer parseState of
L.PFailed {} -> Nothing
L.POk _ x -> Just x
where
location = mkRealSrcLoc (mkFastString "") 1 1
buffer = stringToStringBuffer input
parseState = L.mkPStatePure parserFlags buffer location
parserFlags = L.ParserFlags
{ L.pWarningFlags = ES.empty,
L.pExtensionFlags = ES.empty,
L.pThisPackage = newSimpleUnitId (ComponentId (mkFastString "")),
L.pExtsBitmap = 0xffffffffffffffff
}
pLexer :: L.P [L.Token]
pLexer = go
where
go = do
r <- L.lexer False return
case unLoc r of
L.ITeof -> return []
x -> (x :) <$> go