--------------------------------------------------------------------------------
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
    | forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
str forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
ignores    = ParseExtensionResult
ExtensionIgnore
    | Bool
otherwise                         = [Char] -> ParseExtensionResult
ExtensionError forall a b. (a -> b) -> a -> b
$
        [Char]
"Unknown extension: " forall a. [a] -> [a] -> [a]
++ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> [[Char]] -> [[Char]]
go Bool
False 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
|| forall a. [a] -> Maybe a
listToMaybe [Char]
x forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Char
'#'
            nextMultiline :: Bool
nextMultiline = Bool
isCpp Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
x) Bool -> Bool -> Bool
&& forall a. [a] -> a
last [Char]
x forall a. Eq a => a -> a -> Bool
== Char
'\\'
        in (if Bool
isCpp then [Char]
"" else [Char]
x) 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [[Char]]
externalExts0 forall a b. (a -> b) -> a -> b
$ \[Char]
str -> case [Char] -> ParseExtensionResult
parseExtension [Char]
str of
        ExtensionError [Char]
err  -> forall a b. a -> Either a b
Left [Char]
err
        ParseExtensionResult
ExtensionIgnore     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        ExtensionOk Extension
x Bool
onOff -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Extension
x, Bool
onOff)

    -- Build first dynflags.
    let dynFlags0 :: DynFlags
dynFlags0 = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> e
GHC.unLoc forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ ParserOpts
-> StringBuffer -> [Char] -> (Messages PsMessage, [Located [Char]])
GHC.getOptions (DynFlags -> ParserOpts
GHC.initParserOpts DynFlags
dynFlags0)
            ([Char] -> StringBuffer
GHC.stringToStringBuffer [Char]
string)
            (forall a. a -> Maybe a -> a
fromMaybe [Char]
"-" Maybe [Char]
fp)
        fileExtensions :: [(Extension, Bool)]
fileExtensions = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\[Char]
str -> do
            [Char]
str' <- 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 -> forall a. a -> Maybe a
Just (Extension
x, Bool
onOff)
                ParseExtensionResult
_                   -> forall a. Maybe a
Nothing)
            [[Char]]
fileOptions

    -- Set further dynflags.
    let dynFlags1 :: DynFlags
dynFlags1 = 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 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 -> forall a b. b -> Either a b
Right Module
m
        GHC.PFailed PState
ps -> forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
withFileName forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> [Char]
GHC.showSDoc DynFlags
dynFlags1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc
GHC.pprMessages NoDiagnosticOpts
GHC.NoDiagnosticOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$
            PState -> (Messages PsMessage, Messages PsMessage)
GHC.getPsMessages PState
ps
  where
    withFileName :: [Char] -> [Char]
withFileName [Char]
x = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (forall a. Semigroup a => a -> a -> a
<> [Char]
": ") Maybe [Char]
fp forall a. Semigroup a => a -> a -> a
<> [Char]
x

    toggleExt :: DynFlags -> (Extension, Bool) -> DynFlags
toggleExt DynFlags
dynFlags (Extension
ext, Bool
onOff) = 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 forall a. Eq a => a -> a -> Bool
== Extension
ext]