module Language.Haskell.Stylish.Parse
( parseModule
) where
import Control.Monad ((>=>))
import Data.List (foldl',
stripPrefix)
import Data.Maybe (fromMaybe,
listToMaybe,
mapMaybe)
import Data.Traversable (for)
import qualified GHC.Data.StringBuffer as GHC
import GHC.Driver.Ppr as GHC
import qualified GHC.Driver.Session as GHC
import qualified GHC.LanguageExtensions.Type as LangExt
import qualified GHC.Parser.Errors.Ppr as GHC
import qualified GHC.Parser.Header as GHC
import qualified GHC.Parser.Lexer as GHC
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Utils.Error as GHC
import qualified GHC.Utils.Outputable as GHC
import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as GHCEx
import qualified Language.Haskell.GhclibParserEx.GHC.Parser as GHCEx
import Language.Haskell.Stylish.GHC
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]
externalExts0 Maybe String
fp String
string = do
[Extension]
externalExts1 <- [String]
-> (String -> Either String Extension) -> Either String [Extension]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [String]
externalExts0 ((String -> Either String Extension) -> Either String [Extension])
-> (String -> Either String Extension) -> Either String [Extension]
forall a b. (a -> b) -> a -> b
$ \String
s -> case String -> Maybe Extension
GHCEx.readExtension String
s of
Maybe Extension
Nothing -> String -> Either String Extension
forall a b. a -> Either a b
Left (String -> Either String Extension)
-> String -> Either String Extension
forall a b. (a -> b) -> a -> b
$ String
"Unknown extension: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s
Just Extension
e -> Extension -> Either String Extension
forall a b. b -> Either a b
Right Extension
e
let dynFlags0 :: DynFlags
dynFlags0 = (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
turnOn DynFlags
baseDynFlags [Extension]
externalExts1
let fileOptions :: [String]
fileOptions = (GenLocated SrcSpan String -> String)
-> [GenLocated SrcSpan String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpan String -> String
forall l e. GenLocated l e -> e
GHC.unLoc ([GenLocated SrcSpan String] -> [String])
-> [GenLocated SrcSpan String] -> [String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> StringBuffer -> String -> [GenLocated SrcSpan String]
GHC.getOptions DynFlags
dynFlags0
(String -> StringBuffer
GHC.stringToStringBuffer String
string)
(String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"-" Maybe String
fp)
fileExtensions :: [Extension]
fileExtensions = (String -> Maybe Extension) -> [String] -> [Extension]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
(String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"-X" (String -> Maybe String)
-> (String -> Maybe Extension) -> String -> Maybe Extension
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> Maybe Extension
GHCEx.readExtension)
[String]
fileOptions
let dynFlags1 :: DynFlags
dynFlags1 = (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
turnOn DynFlags
dynFlags0 [Extension]
fileExtensions
DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_KeepRawTokenStream
let removeCpp :: String -> String
removeCpp String
s = if Extension -> DynFlags -> Bool
GHC.xopt Extension
LangExt.Cpp DynFlags
dynFlags1 then String -> String
unCpp String
s else String
s
input :: String
input = String -> String
removeCpp (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
dropBom String
string
case String -> DynFlags -> ParseResult Module
GHCEx.parseModule String
input DynFlags
dynFlags1 of
GHC.POk PState
_ Module
m -> Module -> Either String Module
forall a b. b -> Either a b
Right Module
m
GHC.PFailed PState
ps -> String -> Either String Module
forall a b. a -> Either a b
Left (String -> Either String Module)
-> ((Bag PsWarning, Bag PsError) -> String)
-> (Bag PsWarning, Bag PsError)
-> Either String Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
withFileName (String -> String)
-> ((Bag PsWarning, Bag PsError) -> String)
-> (Bag PsWarning, Bag PsError)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> String
GHC.showSDoc DynFlags
dynFlags1 (SDoc -> String)
-> ((Bag PsWarning, Bag PsError) -> SDoc)
-> (Bag PsWarning, Bag PsError)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
[SDoc] -> SDoc
GHC.vcat ([SDoc] -> SDoc)
-> ((Bag PsWarning, Bag PsError) -> [SDoc])
-> (Bag PsWarning, Bag PsError)
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (MsgEnvelope DecoratedSDoc) -> [SDoc]
GHC.pprMsgEnvelopeBagWithLoc (Bag (MsgEnvelope DecoratedSDoc) -> [SDoc])
-> ((Bag PsWarning, Bag PsError)
-> Bag (MsgEnvelope DecoratedSDoc))
-> (Bag PsWarning, Bag PsError)
-> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PsError -> MsgEnvelope DecoratedSDoc)
-> Bag PsError -> Bag (MsgEnvelope DecoratedSDoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
GHC.pprError (Bag PsError -> Bag (MsgEnvelope DecoratedSDoc))
-> ((Bag PsWarning, Bag PsError) -> Bag PsError)
-> (Bag PsWarning, Bag PsError)
-> Bag (MsgEnvelope DecoratedSDoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bag PsWarning, Bag PsError) -> Bag PsError
forall a b. (a, b) -> b
snd ((Bag PsWarning, Bag PsError) -> Either String Module)
-> (Bag PsWarning, Bag PsError) -> Either String Module
forall a b. (a -> b) -> a -> b
$
PState -> (Bag PsWarning, Bag PsError)
GHC.getMessages PState
ps
where
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
turnOn :: DynFlags -> Extension -> DynFlags
turnOn DynFlags
dynFlags Extension
ext = (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
DynFlags -> Extension -> DynFlags
turnOn
(DynFlags -> Extension -> DynFlags
GHC.xopt_set DynFlags
dynFlags Extension
ext)
[Extension
rhs | (Extension
lhs, Bool
True, Extension
rhs) <- [(Extension, Bool, Extension)]
GHC.impliedXFlags, Extension
lhs Extension -> Extension -> Bool
forall a. Eq a => a -> a -> Bool
== Extension
ext]