git.iko.soy/ormolu
on d82d607 help sign in
ormolu/src/Ormolu/Parser.hs
156 lines 5.7 kB history raw
1{-# LANGUAGE RecordWildCards #-}
3-- | Parser for Haskell source code.
5module Ormolu.Parser
6 ( parseModule
7 )
8where
10import Control.Exception
11import Control.Monad
12import Control.Monad.IO.Class
13import Data.List (isPrefixOf)
14import Data.Maybe (catMaybes)
15import GHC hiding (IE, parseModule, parser)
16import GHC.LanguageExtensions.Type (Extension (Cpp))
17import GHC.Paths (libdir)
18import Ormolu.Config
19import Ormolu.Exception
20import Ormolu.Parser.Anns
21import Ormolu.Parser.CommentStream
22import Ormolu.Parser.Result
23import qualified CmdLineParser as GHC
24import qualified DynFlags as GHC
25import qualified FastString as GHC
26import qualified HeaderInfo as GHC
27import qualified Lexer as GHC
28import qualified Outputable as GHC
29import qualified Parser as GHC
30import qualified SrcLoc as GHC
31import qualified StringBuffer as GHC
33-- | Parse a complete module from string.
35parseModule
36 :: MonadIO m
37 => [DynOption] -- ^ Dynamic options that affect parsing
38 -> FilePath -- ^ File name (only for source location annotations)
39 -> String -- ^ Input for parser
40 -> m ( [GHC.Warn]
41 , Either (SrcSpan, String) ParseResult
42 )
43parseModule dynOpts path input' = liftIO $ do
44 let (input, extraComments) = stripLinePragmas input'
45 (ws, dynFlags) <- ghcWrapper $ do
46 dynFlags0 <- initDynFlagsPure path input
47 (dynFlags1, _, ws) <-
48 GHC.parseDynamicFilePragma dynFlags0 (dynOptionToLocatedStr <$> dynOpts)
49 return (ws, dynFlags1)
50 -- NOTE It's better to throw this outside of 'ghcWrapper' because
51 -- otherwise the exception will be wrapped as a GHC panic, which we don't
52 -- want.
53 when (GHC.xopt Cpp dynFlags) $
54 throwIO OrmoluCppEnabled
55 let r = case runParser GHC.parseModule dynFlags path input of
56 GHC.PFailed _ ss m ->
57 Left (ss, GHC.showSDoc dynFlags m)
58 GHC.POk pstate pmod ->
59 let (comments, exts) = mkCommentStream extraComments pstate
60 in Right ParseResult
61 { prParsedSource = pmod
62 , prAnns = mkAnns pstate
63 , prCommentStream = comments
64 , prExtensions = exts
65 }
66 return (ws, r)
68----------------------------------------------------------------------------
69-- Helpers (taken from ghc-exactprint)
71-- | Requires GhcMonad constraint because there is no pure variant of
72-- 'parseDynamicFilePragma'. Yet, in constrast to 'initDynFlags', it does
73-- not (try to) read the file at filepath, but solely depends on the module
74-- source in the input string.
75--
76-- Passes "-hide-all-packages" to the GHC API to prevent parsing of package
77-- environment files. However this only works if there is no invocation of
78-- 'setSessionDynFlags' before calling 'initDynFlagsPure'. See GHC tickets
79-- #15513, #15541.
81initDynFlagsPure
82 :: GHC.GhcMonad m
83 => FilePath -- ^ Module path
84 -> String -- ^ Module contents
85 -> m GHC.DynFlags -- ^ Dynamic flags for that module
86initDynFlagsPure fp input = do
87 -- I was told we could get away with using the 'unsafeGlobalDynFlags'. as
88 -- long as 'parseDynamicFilePragma' is impure there seems to be no reason
89 -- to use it.
90 dflags0 <- GHC.getSessionDynFlags
91 let tokens = GHC.getOptions dflags0 (GHC.stringToStringBuffer input) fp
92 (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 tokens
93 -- Turn this on last to avoid T10942
94 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
95 -- Prevent parsing of .ghc.environment.* "package environment files"
96 (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine
97 dflags2
98 [GHC.noLoc "-hide-all-packages"]
99 _ <- GHC.setSessionDynFlags dflags3
100 return dflags3
102-- | Default runner of 'GHC.Ghc' action in 'IO'.
104ghcWrapper :: GHC.Ghc a -> IO a
105ghcWrapper
106 = GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut
107 . GHC.runGhc (Just libdir)
109-- | Run a 'GHC.P' computation.
111runParser
112 :: GHC.P a -- ^ Computation to run
113 -> GHC.DynFlags -- ^ Dynamic flags
114 -> FilePath -- ^ Module path
115 -> String -- ^ Module contents
116 -> GHC.ParseResult a -- ^ Parse result
117runParser parser flags filename input = GHC.unP parser parseState
118 where
119 location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1
120 buffer = GHC.stringToStringBuffer input
121 parseState = GHC.mkPState flags buffer location
123-- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into
124-- comments.
126stripLinePragmas :: String -> (String, [Located String])
127stripLinePragmas = unlines' . unzip . findLines . lines
128 where
129 unlines' (a, b) = (unlines a, catMaybes b)
131findLines :: [String] -> [(String, Maybe (Located String))]
132findLines = zipWith checkLine [1..]
134checkLine :: Int -> String -> (String, Maybe (Located String))
135checkLine line s
136 | "{-# LINE" `isPrefixOf` s =
137 let (pragma, res) = getPragma s
138 size = length pragma
139 mSrcLoc = mkSrcLoc (GHC.mkFastString "LINE")
140 ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (size+1))
141 in (res, Just $ L ss pragma)
142 -- Deal with shebang/cpp directives too
143 -- x | "#" `isPrefixOf` s = ("",Just $ Comment ((line, 1), (line, length s)) s)
144 | "#!" `isPrefixOf` s =
145 let mSrcLoc = mkSrcLoc (GHC.mkFastString "SHEBANG")
146 ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (length s))
147 in ("",Just $ L ss s)
148 | otherwise = (s, Nothing)
150getPragma :: String -> (String, String)
151getPragma [] = error "Ormolu.Parser.getPragma: input must not be empty"
152getPragma s@(x:xs)
153 | "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s)
154 | otherwise =
155 let (prag, remline) = getPragma xs
156 in (x:prag, ' ':remline)