module Language.Haskell.Stylish.Parse
( parseModule
) where
import Data.Char (toLower)
import Data.List (foldl',
stripPrefix)
import Data.Maybe (catMaybes,
fromMaybe,
listToMaybe,
mapMaybe)
import Data.Traversable (for)
import qualified GHC.Data.StringBuffer as GHC
import qualified GHC.Driver.Config.Parser 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.Header as GHC
import qualified GHC.Parser.Lexer as GHC
import qualified GHC.Types.Error as GHC
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Utils.Error 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]
data ParseExtensionResult
= ExtensionOk LangExt.Extension Bool
| ExtensionError String
| ExtensionIgnore
parseExtension :: String -> ParseExtensionResult
parseExtension :: [Char] -> ParseExtensionResult
parseExtension [Char]
str
| Just Extension
x <- [Char] -> Maybe Extension
GHCEx.readExtension [Char]
str = Extension -> Bool -> ParseExtensionResult
ExtensionOk Extension
x Bool
True
| Char
'N' : Char
'o' : [Char]
str' <- [Char]
str = case [Char] -> ParseExtensionResult
parseExtension [Char]
str' of
ExtensionOk Extension
x Bool
onOff -> Extension -> Bool -> ParseExtensionResult
ExtensionOk Extension
x (Bool -> Bool
not Bool
onOff)
ParseExtensionResult
result -> ParseExtensionResult
result
| (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
str [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
ignores = ParseExtensionResult
ExtensionIgnore
| Bool
otherwise = [Char] -> ParseExtensionResult
ExtensionError ([Char] -> ParseExtensionResult) -> [Char] -> ParseExtensionResult
forall a b. (a -> b) -> a -> b
$
[Char]
"Unknown extension: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
str
where
ignores :: [[Char]]
ignores = [[Char]
"unsafe", [Char]
"trustworthy", [Char]
"safe"]
unCpp :: String -> String
unCpp :: [Char] -> [Char]
unCpp = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> [[Char]] -> [[Char]]
go Bool
False ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines
where
go :: Bool -> [[Char]] -> [[Char]]
go Bool
_ [] = []
go Bool
isMultiline ([Char]
x : [[Char]]
xs) =
let isCpp :: Bool
isCpp = Bool
isMultiline Bool -> Bool -> Bool
|| [Char] -> Maybe Char
forall a. [a] -> Maybe a
listToMaybe [Char]
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 ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
x) Bool -> Bool -> Bool
&& [Char] -> Char
forall a. HasCallStack => [a] -> a
last [Char]
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'
in (if Bool
isCpp then [Char]
"" else [Char]
x) [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: Bool -> [[Char]] -> [[Char]]
go Bool
nextMultiline [[Char]]
xs
dropBom :: String -> String
dropBom :: [Char] -> [Char]
dropBom (Char
'\xfeff' : [Char]
str) = [Char]
str
dropBom [Char]
str = [Char]
str
parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module
parseModule :: [[Char]] -> Maybe [Char] -> [Char] -> Either [Char] Module
parseModule [[Char]]
externalExts0 Maybe [Char]
fp [Char]
string = do
[(Extension, Bool)]
externalExts1 <- ([Maybe (Extension, Bool)] -> [(Extension, Bool)])
-> Either [Char] [Maybe (Extension, Bool)]
-> Either [Char] [(Extension, Bool)]
forall a b. (a -> b) -> Either [Char] a -> Either [Char] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (Extension, Bool)] -> [(Extension, Bool)]
forall a. [Maybe a] -> [a]
catMaybes (Either [Char] [Maybe (Extension, Bool)]
-> Either [Char] [(Extension, Bool)])
-> (([Char] -> Either [Char] (Maybe (Extension, Bool)))
-> Either [Char] [Maybe (Extension, Bool)])
-> ([Char] -> Either [Char] (Maybe (Extension, Bool)))
-> Either [Char] [(Extension, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]]
-> ([Char] -> Either [Char] (Maybe (Extension, Bool)))
-> Either [Char] [Maybe (Extension, Bool)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [[Char]]
externalExts0 (([Char] -> Either [Char] (Maybe (Extension, Bool)))
-> Either [Char] [(Extension, Bool)])
-> ([Char] -> Either [Char] (Maybe (Extension, Bool)))
-> Either [Char] [(Extension, Bool)]
forall a b. (a -> b) -> a -> b
$ \[Char]
str -> case [Char] -> ParseExtensionResult
parseExtension [Char]
str of
ExtensionError [Char]
err -> [Char] -> Either [Char] (Maybe (Extension, Bool))
forall a b. a -> Either a b
Left [Char]
err
ParseExtensionResult
ExtensionIgnore -> Maybe (Extension, Bool) -> Either [Char] (Maybe (Extension, Bool))
forall a. a -> Either [Char] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Extension, Bool)
forall a. Maybe a
Nothing
ExtensionOk Extension
x Bool
onOff -> Maybe (Extension, Bool) -> Either [Char] (Maybe (Extension, Bool))
forall a. a -> Either [Char] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Extension, Bool)
-> Either [Char] (Maybe (Extension, Bool)))
-> Maybe (Extension, Bool)
-> Either [Char] (Maybe (Extension, Bool))
forall a b. (a -> b) -> a -> b
$ (Extension, Bool) -> Maybe (Extension, Bool)
forall a. a -> Maybe a
Just (Extension
x, Bool
onOff)
let dynFlags0 :: DynFlags
dynFlags0 = (DynFlags -> (Extension, Bool) -> DynFlags)
-> DynFlags -> [(Extension, Bool)] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> (Extension, Bool) -> DynFlags
toggleExt DynFlags
baseDynFlags [(Extension, Bool)]
externalExts1
let fileOptions :: [[Char]]
fileOptions = (GenLocated SrcSpan [Char] -> [Char])
-> [GenLocated SrcSpan [Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpan [Char] -> [Char]
forall l e. GenLocated l e -> e
GHC.unLoc ([GenLocated SrcSpan [Char]] -> [[Char]])
-> [GenLocated SrcSpan [Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (Messages PsMessage, [GenLocated SrcSpan [Char]])
-> [GenLocated SrcSpan [Char]]
forall a b. (a, b) -> b
snd ((Messages PsMessage, [GenLocated SrcSpan [Char]])
-> [GenLocated SrcSpan [Char]])
-> (Messages PsMessage, [GenLocated SrcSpan [Char]])
-> [GenLocated SrcSpan [Char]]
forall a b. (a -> b) -> a -> b
$ ParserOpts
-> StringBuffer
-> [Char]
-> (Messages PsMessage, [GenLocated SrcSpan [Char]])
GHC.getOptions (DynFlags -> ParserOpts
GHC.initParserOpts DynFlags
dynFlags0)
([Char] -> StringBuffer
GHC.stringToStringBuffer [Char]
string)
([Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"-" Maybe [Char]
fp)
fileExtensions :: [(Extension, Bool)]
fileExtensions = ([Char] -> Maybe (Extension, Bool))
-> [[Char]] -> [(Extension, Bool)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\[Char]
str -> do
[Char]
str' <- [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"-X" [Char]
str
case [Char] -> ParseExtensionResult
parseExtension [Char]
str' of
ExtensionOk Extension
x Bool
onOff -> (Extension, Bool) -> Maybe (Extension, Bool)
forall a. a -> Maybe a
Just (Extension
x, Bool
onOff)
ParseExtensionResult
_ -> Maybe (Extension, Bool)
forall a. Maybe a
Nothing)
[[Char]]
fileOptions
let dynFlags1 :: DynFlags
dynFlags1 = (DynFlags -> (Extension, Bool) -> DynFlags)
-> DynFlags -> [(Extension, Bool)] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> (Extension, Bool) -> DynFlags
toggleExt DynFlags
dynFlags0 [(Extension, Bool)]
fileExtensions
DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_KeepRawTokenStream
let removeCpp :: [Char] -> [Char]
removeCpp [Char]
s = if Extension -> DynFlags -> Bool
GHC.xopt Extension
LangExt.Cpp DynFlags
dynFlags1 then [Char] -> [Char]
unCpp [Char]
s else [Char]
s
input :: [Char]
input = [Char] -> [Char]
removeCpp ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
dropBom [Char]
string
case [Char] -> DynFlags -> ParseResult Module
GHCEx.parseModule [Char]
input DynFlags
dynFlags1 of
GHC.POk PState
_ Module
m -> Module -> Either [Char] Module
forall a b. b -> Either a b
Right Module
m
GHC.PFailed PState
ps -> [Char] -> Either [Char] Module
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Module)
-> ((Messages PsMessage, Messages PsMessage) -> [Char])
-> (Messages PsMessage, Messages PsMessage)
-> Either [Char] Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
withFileName ([Char] -> [Char])
-> ((Messages PsMessage, Messages PsMessage) -> [Char])
-> (Messages PsMessage, Messages PsMessage)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> [Char]
GHC.showSDoc DynFlags
dynFlags1 (SDoc -> [Char])
-> ((Messages PsMessage, Messages PsMessage) -> SDoc)
-> (Messages PsMessage, Messages PsMessage)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiagnosticOpts PsMessage -> Messages PsMessage -> SDoc
forall e. Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc
GHC.pprMessages NoDiagnosticOpts
DiagnosticOpts PsMessage
GHC.NoDiagnosticOpts (Messages PsMessage -> SDoc)
-> ((Messages PsMessage, Messages PsMessage) -> Messages PsMessage)
-> (Messages PsMessage, Messages PsMessage)
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Messages PsMessage, Messages PsMessage) -> Messages PsMessage
forall a b. (a, b) -> b
snd ((Messages PsMessage, Messages PsMessage) -> Either [Char] Module)
-> (Messages PsMessage, Messages PsMessage) -> Either [Char] Module
forall a b. (a -> b) -> a -> b
$
PState -> (Messages PsMessage, Messages PsMessage)
GHC.getPsMessages PState
ps
where
withFileName :: [Char] -> [Char]
withFileName [Char]
x = [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": ") Maybe [Char]
fp [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
x
toggleExt :: DynFlags -> (Extension, Bool) -> DynFlags
toggleExt DynFlags
dynFlags (Extension
ext, Bool
onOff) = (DynFlags -> (Extension, Bool) -> DynFlags)
-> DynFlags -> [(Extension, Bool)] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
DynFlags -> (Extension, Bool) -> DynFlags
toggleExt
((if Bool
onOff then DynFlags -> Extension -> DynFlags
GHC.xopt_set else DynFlags -> Extension -> DynFlags
GHC.xopt_unset) DynFlags
dynFlags Extension
ext)
[(Extension
rhs, Bool
onOff') | (Extension
lhs, Bool
onOff', Extension
rhs) <- [(Extension, Bool, Extension)]
GHC.impliedXFlags, Extension
lhs Extension -> Extension -> Bool
forall a. Eq a => a -> a -> Bool
== Extension
ext]