--------------------------------------------------------------------------------
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]


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


--------------------------------------------------------------------------------
-- | 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 :: String -> String
dropBom (Char
'\xfeff' : String
str) = String
str
dropBom String
str              = String
str


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

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

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

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

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

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