--------------------------------------------------------------------------------
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
    -- | Actual extension, and whether we want to turn it on or off.
    = ExtensionOk LangExt.Extension Bool
    -- | Failed to parse extension.
    | ExtensionError String
    -- | Other LANGUAGE things that aren't really extensions, like 'Safe'.
    | 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"]


--------------------------------------------------------------------------------
-- | Filter out lines which use CPP macros
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


--------------------------------------------------------------------------------
-- | If the given string is prefixed with an UTF-8 Byte Order Mark, drop it
-- because haskell-src-exts can't handle it.
dropBom :: String -> String
dropBom :: [Char] -> [Char]
dropBom (Char
'\xfeff' : [Char]
str) = [Char]
str
dropBom [Char]
str              = [Char]
str


--------------------------------------------------------------------------------
-- | Abstraction over GHC lib's parsing
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
    -- Parse extensions.
    [(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)

    -- Build first dynflags.
    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

    -- Parse options from file
    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

    -- Set further dynflags.
    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

    -- Possibly strip CPP.
    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

    -- Actual parse.
    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]