{-# LANGUAGE LambdaCase #-}
module Language.Haskell.Stylish.Parse
( parseModule
) where
import Data.Function ((&))
import Data.Maybe (fromMaybe, listToMaybe)
import System.IO.Unsafe (unsafePerformIO)
import Bag (bagToList)
import qualified DynFlags as GHC
import qualified ErrUtils as GHC
import FastString (mkFastString)
import qualified GHC.Hs as GHC
import qualified GHC.LanguageExtensions as GHC
import qualified HeaderInfo as GHC
import qualified HscTypes as GHC
import Lexer (ParseResult (..))
import Lexer (mkPState, unP)
import qualified Lexer as GHC
import qualified Panic as GHC
import qualified Parser as GHC
import SrcLoc (mkRealSrcLoc)
import qualified SrcLoc as GHC
import StringBuffer (stringToStringBuffer)
import qualified StringBuffer as GHC
import Language.Haskell.Stylish.GHC (baseDynFlags)
import Language.Haskell.Stylish.Module
type Extensions = [String]
unCpp :: String -> String
unCpp :: String -> String
unCpp = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> [String] -> [String]
go Bool
False ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
where
go :: Bool -> [String] -> [String]
go Bool
_ [] = []
go Bool
isMultiline (String
x : [String]
xs) =
let isCpp :: Bool
isCpp = Bool
isMultiline Bool -> Bool -> Bool
|| String -> Maybe Char
forall a. [a] -> Maybe a
listToMaybe String
x Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'#'
nextMultiline :: Bool
nextMultiline = Bool
isCpp Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x) Bool -> Bool -> Bool
&& String -> Char
forall a. [a] -> a
last String
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'
in (if Bool
isCpp then String
"" else String
x) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Bool -> [String] -> [String]
go Bool
nextMultiline [String]
xs
dropBom :: String -> String
dropBom :: String -> String
dropBom (Char
'\xfeff' : String
str) = String
str
dropBom String
str = String
str
parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module
parseModule :: [String] -> Maybe String -> String -> Either String Module
parseModule [String]
exts Maybe String
fp String
string =
DynFlags
-> [Located String] -> String -> String -> Either String DynFlags
parsePragmasIntoDynFlags DynFlags
baseDynFlags [Located String]
userExtensions String
filePath String
string Either String DynFlags
-> (DynFlags -> Either String Module) -> Either String Module
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \DynFlags
dynFlags ->
String -> String
dropBom String
string
String -> (String -> String) -> String
forall a b. a -> (a -> b) -> b
& DynFlags -> String -> String
removeCpp DynFlags
dynFlags
String
-> (String -> ParseResult (Located (HsModule GhcPs)))
-> ParseResult (Located (HsModule GhcPs))
forall a b. a -> (a -> b) -> b
& DynFlags -> String -> ParseResult (Located (HsModule GhcPs))
runParser DynFlags
dynFlags
ParseResult (Located (HsModule GhcPs))
-> (ParseResult (Located (HsModule GhcPs)) -> Either String Module)
-> Either String Module
forall a b. a -> (a -> b) -> b
& DynFlags
-> ParseResult (Located (HsModule GhcPs)) -> Either String Module
toModule DynFlags
dynFlags
where
toModule :: GHC.DynFlags -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs)) -> Either String Module
toModule :: DynFlags
-> ParseResult (Located (HsModule GhcPs)) -> Either String Module
toModule DynFlags
dynFlags ParseResult (Located (HsModule GhcPs))
res = case ParseResult (Located (HsModule GhcPs))
res of
POk PState
ps Located (HsModule GhcPs)
m ->
Module -> Either String Module
forall a b. b -> Either a b
Right (PState -> Located (HsModule GhcPs) -> Module
makeModule PState
ps Located (HsModule GhcPs)
m)
PFailed PState
failureState ->
let
withFileName :: String -> String
withFileName String
x = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": ") Maybe String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
x
in
String -> Either String Module
forall a b. a -> Either a b
Left (String -> Either String Module)
-> (PState -> String) -> PState -> Either String Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
withFileName (String -> String) -> (PState -> String) -> PState -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String) -> (PState -> [String]) -> PState -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PState -> [String]
getParserStateErrors DynFlags
dynFlags (PState -> Either String Module) -> PState -> Either String Module
forall a b. (a -> b) -> a -> b
$ PState
failureState
removeCpp :: DynFlags -> String -> String
removeCpp DynFlags
dynFlags String
s =
if Extension -> DynFlags -> Bool
GHC.xopt Extension
GHC.Cpp DynFlags
dynFlags then String -> String
unCpp String
s
else String
s
userExtensions :: [Located String]
userExtensions =
(String -> Located String) -> [String] -> [Located String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Located String
toLocatedExtensionFlag (String
"Haskell2010" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
exts)
toLocatedExtensionFlag :: String -> Located String
toLocatedExtensionFlag String
flag
= String
"-X" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
flag
String -> (String -> Located String) -> Located String
forall a b. a -> (a -> b) -> b
& SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
GHC.noSrcSpan
getParserStateErrors :: DynFlags -> PState -> [String]
getParserStateErrors DynFlags
dynFlags PState
state
= PState -> DynFlags -> ErrorMessages
GHC.getErrorMessages PState
state DynFlags
dynFlags
ErrorMessages -> (ErrorMessages -> [ErrMsg]) -> [ErrMsg]
forall a b. a -> (a -> b) -> b
& ErrorMessages -> [ErrMsg]
forall a. Bag a -> [a]
bagToList
[ErrMsg] -> ([ErrMsg] -> [String]) -> [String]
forall a b. a -> (a -> b) -> b
& (ErrMsg -> String) -> [ErrMsg] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ErrMsg
errMsg -> SrcSpan -> String
forall a. Show a => a -> String
show (ErrMsg -> SrcSpan
GHC.errMsgSpan ErrMsg
errMsg) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ErrMsg -> String
forall a. Show a => a -> String
show ErrMsg
errMsg)
filePath :: String
filePath =
String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"<interactive>" Maybe String
fp
runParser :: GHC.DynFlags -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs))
runParser :: DynFlags -> String -> ParseResult (Located (HsModule GhcPs))
runParser DynFlags
flags String
str =
let
filename :: FastString
filename = String -> FastString
mkFastString String
filePath
parseState :: PState
parseState = DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState DynFlags
flags (String -> StringBuffer
stringToStringBuffer String
str) (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
filename Int
1 Int
1)
in
P (Located (HsModule GhcPs))
-> PState -> ParseResult (Located (HsModule GhcPs))
forall a. P a -> PState -> ParseResult a
unP P (Located (HsModule GhcPs))
GHC.parseModule PState
parseState
parsePragmasIntoDynFlags ::
GHC.DynFlags
-> [GHC.Located String]
-> FilePath
-> String
-> Either String GHC.DynFlags
{-# NOINLINE parsePragmasIntoDynFlags #-}
parsePragmasIntoDynFlags :: DynFlags
-> [Located String] -> String -> String -> Either String DynFlags
parsePragmasIntoDynFlags DynFlags
originalFlags [Located String]
extraOpts String
filepath String
str = IO (Either String DynFlags) -> Either String DynFlags
forall a. IO a -> a
unsafePerformIO (IO (Either String DynFlags) -> Either String DynFlags)
-> IO (Either String DynFlags) -> Either String DynFlags
forall a b. (a -> b) -> a -> b
$ IO (Either String DynFlags) -> IO (Either String DynFlags)
forall (m :: * -> *) b.
ExceptionMonad m =>
m (Either String b) -> m (Either String b)
catchErrors (IO (Either String DynFlags) -> IO (Either String DynFlags))
-> IO (Either String DynFlags) -> IO (Either String DynFlags)
forall a b. (a -> b) -> a -> b
$ do
let opts :: [Located String]
opts = DynFlags -> StringBuffer -> String -> [Located String]
GHC.getOptions DynFlags
originalFlags (String -> StringBuffer
GHC.stringToStringBuffer String
str) String
filepath
(DynFlags
parsedFlags, [Located String]
_invalidFlags, [Warn]
_warnings) <- DynFlags
-> [Located String] -> IO (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
GHC.parseDynamicFilePragma DynFlags
originalFlags ([Located String]
opts [Located String] -> [Located String] -> [Located String]
forall a. Semigroup a => a -> a -> a
<> [Located String]
extraOpts)
Either String DynFlags -> IO (Either String DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String DynFlags -> IO (Either String DynFlags))
-> Either String DynFlags -> IO (Either String DynFlags)
forall a b. (a -> b) -> a -> b
$ DynFlags -> Either String DynFlags
forall a b. b -> Either a b
Right (DynFlags -> Either String DynFlags)
-> DynFlags -> Either String DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
parsedFlags DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_KeepRawTokenStream
where
catchErrors :: m (Either String b) -> m (Either String b)
catchErrors m (Either String b)
act = (GhcException -> m (Either String b))
-> m (Either String b) -> m (Either String b)
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
GHC.handleGhcException GhcException -> m (Either String b)
forall (m :: * -> *) a b.
(Monad m, Show a) =>
a -> m (Either String b)
reportErr ((SourceError -> m (Either String b))
-> m (Either String b) -> m (Either String b)
forall (m :: * -> *) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
GHC.handleSourceError SourceError -> m (Either String b)
forall (m :: * -> *) a b.
(Monad m, Show a) =>
a -> m (Either String b)
reportErr m (Either String b)
act)
reportErr :: a -> m (Either String b)
reportErr a
e = Either String b -> m (Either String b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String b -> m (Either String b))
-> Either String b -> m (Either String b)
forall a b. (a -> b) -> a -> b
$ String -> Either String b
forall a b. a -> Either a b
Left (a -> String
forall a. Show a => a -> String
show a
e)