@@ -0,0 +1,91 @@
1+-- | A module for parsing of language pragmas from comments.
2+
3+{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+
6+module Ormolu.Parser.Pragma
7+ ( Pragma (..)
8+ , parsePragma
9+ )
10+where
11+
12+import Data.Char (toLower, isSpace)
13+import Data.List (stripPrefix, dropWhileEnd)
14+import FastString (mkFastString, unpackFS)
15+import Module (newSimpleUnitId, ComponentId (..))
16+import SrcLoc
17+import StringBuffer
18+import qualified EnumSet as ES
19+import qualified Lexer as L
20+
21+data Pragma
22+ = PragmaLanguage [String]
23+ | PragmaOptionsGHC String
24+ | PragmaOptionsHaddock String
25+ deriving (Show, Eq)
26+
27+-- | Extract a Pragma from a comment if possible, or return 'Nothing'
28+-- otherwise.
29+
30+parsePragma :: String -> Maybe Pragma
31+parsePragma input = do
32+ contents <- trimSpaces <$> stripEnclosing "{-#" "#-}" input
33+ let (name, cs) = separateName contents
34+ case map toLower name of
35+ "language" -> PragmaLanguage <$> parseExtensions cs
36+ "options_ghc" -> Just $ PragmaOptionsGHC (trimSpaces cs)
37+ "options_haddock" -> Just $ PragmaOptionsHaddock (trimSpaces cs)
38+ _ -> Nothing
39+ where
40+ -- stripEnclosing pre suf (pre ++ str ++ suf) == Just str
41+ stripEnclosing :: String -> String -> String -> Maybe String
42+ stripEnclosing pre suf str =
43+ fmap reverse $ stripPrefix pre str >>= stripPrefix (reverse suf) . reverse
44+
45+ trimSpaces :: String -> String
46+ trimSpaces = dropWhileEnd isSpace . dropWhile isSpace
47+
48+-- | Assuming the input consists of a series of tokens from a language
49+-- pragma, return the set of enabled extensions.
50+
51+parseExtensions :: String -> Maybe [String]
52+parseExtensions str = tokenize str >>= go
53+ where
54+ go = \case
55+ (L.ITconid ext : []) -> return [unpackFS ext]
56+ (L.ITconid ext : L.ITcomma : xs) -> (unpackFS ext :) <$> go xs
57+ _ -> Nothing
58+
59+-- | Split a pragma to name and contents
60+
61+separateName :: String -> (String, String)
62+separateName = span (not . isSpace) . dropWhile isSpace
63+
64+-- | Tokenize a given input using GHC's lexer.
65+
66+tokenize :: String -> Maybe [L.Token]
67+tokenize input =
68+ case L.unP pLexer parseState of
69+ L.PFailed {} -> Nothing
70+ L.POk _ x -> Just x
71+ where
72+ location = mkRealSrcLoc (mkFastString "") 1 1
73+ buffer = stringToStringBuffer input
74+ parseState = L.mkPStatePure parserFlags buffer location
75+ parserFlags = L.ParserFlags
76+ { L.pWarningFlags = ES.empty
77+ , L.pExtensionFlags = ES.empty
78+ , L.pThisPackage = newSimpleUnitId (ComponentId (mkFastString ""))
79+ , L.pExtsBitmap = 0xffffffffffffffff
80+ }
81+
82+-- | Haskell lexer.
83+
84+pLexer :: L.P [L.Token]
85+pLexer = go
86+ where
87+ go = do
88+ r <- L.lexer False return
89+ case unLoc r of
90+ L.ITeof -> return []
91+ x -> (x:) <$> go