{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
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
data Pragma
=
PragmaLanguage [String]
|
PragmaOptionsGHC String
|
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)
parsePragma ::
String ->
Maybe Pragma
parsePragma :: String -> Maybe Pragma
parsePragma String
input = do
String
inputNoPrefix <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
L.stripPrefix String
"{-#" String
input
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
"#-}" 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
- Int
3) String
inputNoPrefix
(String
pragmaName, 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
String
"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
String
"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)
String
"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)
String
_ -> 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
parseExtensions :: String -> Maybe [String]
parseExtensions :: String -> Maybe [String]
parseExtensions 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 FastString
ext] -> [String] -> Maybe [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [FastString -> String
unpackFS FastString
ext]
(L.ITconid FastString
ext : Token
L.ITcomma : [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
[Token]
_ -> Maybe [String]
forall a. Maybe a
Nothing
tokenize :: String -> Maybe [L.Token]
tokenize :: String -> Maybe [Token]
tokenize 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 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 = 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 String
"")))
Bool
True
Bool
True
Bool
True
Bool
True
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
SrcSpanLess (Located Token)
L.ITeof -> [Token] -> P [Token]
forall (m :: * -> *) a. Monad m => a -> m a
return []
SrcSpanLess (Located Token)
x -> (SrcSpanLess (Located Token)
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