{-# 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.mkParserFlags'
ES.empty
ES.empty
(newSimpleUnitId (ComponentId (mkFastString "")))
True
True
True
True
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