{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Ormolu.Parser
( parseModule,
manualExts,
)
where
import qualified CmdLineParser as GHC
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.List ((\\), foldl', isPrefixOf)
import Data.Maybe (catMaybes)
import qualified DynFlags as GHC
import qualified FastString as GHC
import GHC hiding (IE, parseModule, parser)
import GHC.LanguageExtensions.Type (Extension (..))
import GHC.Paths (libdir)
import qualified HeaderInfo as GHC
import qualified Lexer as GHC
import Ormolu.Config
import Ormolu.Exception
import Ormolu.Parser.Anns
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Result
import qualified Outputable as GHC
import qualified Parser as GHC
import qualified SrcLoc as GHC
import qualified StringBuffer as GHC
parseModule ::
MonadIO m =>
Config ->
FilePath ->
String ->
m
( [GHC.Warn],
Either (SrcSpan, String) ParseResult
)
parseModule Config {..} path input' = liftIO $ do
let (input, extraComments) = stripLinePragmas path input'
(ws, dynFlags) <- ghcWrapper $ do
dynFlags0 <- initDynFlagsPure path input
(dynFlags1, _, ws) <-
GHC.parseDynamicFilePragma
dynFlags0
(dynOptionToLocatedStr <$> cfgDynOptions)
return (ws, GHC.setGeneralFlag' GHC.Opt_Haddock dynFlags1)
when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $
throwIO (OrmoluCppEnabled path)
let r = case runParser GHC.parseModule dynFlags path input of
GHC.PFailed _ ss m ->
Left (ss, GHC.showSDoc dynFlags m)
GHC.POk pstate pmod ->
let (comments, exts) = mkCommentStream extraComments pstate
in Right ParseResult
{ prParsedSource = pmod,
prAnns = mkAnns pstate,
prCommentStream = comments,
prExtensions = exts
}
return (ws, r)
manualExts :: [Extension]
manualExts =
[ Arrows,
Cpp,
BangPatterns,
PatternSynonyms,
RecursiveDo,
StaticPointers,
TransformListComp,
UnboxedTuples,
MagicHash,
TypeApplications,
AlternativeLayoutRule,
AlternativeLayoutRuleTransitional,
MonadComprehensions,
UnboxedSums,
UnicodeSyntax,
TemplateHaskellQuotes
]
initDynFlagsPure ::
GHC.GhcMonad m =>
FilePath ->
String ->
m GHC.DynFlags
initDynFlagsPure fp input = do
dflags0 <- setDefaultExts <$> GHC.getSessionDynFlags
let tokens = GHC.getOptions dflags0 (GHC.stringToStringBuffer input) fp
(dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 tokens
let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
(dflags3, _, _) <-
GHC.parseDynamicFlagsCmdLine
dflags2
[GHC.noLoc "-hide-all-packages"]
_ <- GHC.setSessionDynFlags dflags3
return dflags3
ghcWrapper :: GHC.Ghc a -> IO a
ghcWrapper act =
let GHC.FlushOut flushOut = GHC.defaultFlushOut
in GHC.runGhc (Just libdir) act
`finally` flushOut
runParser ::
GHC.P a ->
GHC.DynFlags ->
FilePath ->
String ->
GHC.ParseResult a
runParser parser flags filename input = GHC.unP parser parseState
where
location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1
buffer = GHC.stringToStringBuffer input
parseState = GHC.mkPState flags buffer location
stripLinePragmas :: FilePath -> String -> (String, [Located String])
stripLinePragmas path = unlines' . unzip . findLines path . lines
where
unlines' (a, b) = (unlines a, catMaybes b)
findLines :: FilePath -> [String] -> [(String, Maybe (Located String))]
findLines path = zipWith (checkLine path) [1 ..]
checkLine :: FilePath -> Int -> String -> (String, Maybe (Located String))
checkLine path line s
| "{-# LINE" `isPrefixOf` s =
let (pragma, res) = getPragma s
size = length pragma
ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
in (res, Just $ L ss pragma)
| "#!" `isPrefixOf` s =
let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length s))
in ("", Just $ L ss s)
| otherwise = (s, Nothing)
where
mkSrcLoc' = mkSrcLoc (GHC.mkFastString path) line
getPragma :: String -> (String, String)
getPragma [] = error "Ormolu.Parser.getPragma: input must not be empty"
getPragma s@(x : xs)
| "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s)
| otherwise =
let (prag, remline) = getPragma xs
in (x : prag, ' ' : remline)
setDefaultExts :: DynFlags -> DynFlags
setDefaultExts flags = foldl' GHC.xopt_set flags autoExts
where
autoExts = allExts \\ manualExts
allExts = [minBound .. maxBound]
deriving instance Bounded Extension