{-# LANGUAGE LambdaCase #-}
--------------------------------------------------------------------------------
module Language.Haskell.Stylish.Parse
  ( parseModule
  ) where


--------------------------------------------------------------------------------
import           Data.Function                   ((&))
import           Data.Maybe                      (fromMaybe, listToMaybe)
import           System.IO.Unsafe                (unsafePerformIO)

--------------------------------------------------------------------------------
import           Bag                             (bagToList)
import qualified DynFlags                        as GHC
import qualified ErrUtils                        as GHC
import           FastString                      (mkFastString)
import qualified GHC.Hs                          as GHC
import qualified GHC.LanguageExtensions          as GHC
import qualified HeaderInfo                      as GHC
import qualified HscTypes                        as GHC
import           Lexer                           (ParseResult (..))
import           Lexer                           (mkPState, unP)
import qualified Lexer                           as GHC
import qualified Panic                           as GHC
import qualified Parser                          as GHC
import           SrcLoc                          (mkRealSrcLoc)
import qualified SrcLoc                          as GHC
import           StringBuffer                    (stringToStringBuffer)
import qualified StringBuffer                    as GHC

--------------------------------------------------------------------------------
import           Language.Haskell.Stylish.GHC    (baseDynFlags)
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]
exts Maybe String
fp String
string =
  DynFlags
-> [Located String] -> String -> String -> Either String DynFlags
parsePragmasIntoDynFlags DynFlags
baseDynFlags [Located String]
userExtensions String
filePath String
string Either String DynFlags
-> (DynFlags -> Either String Module) -> Either String Module
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \DynFlags
dynFlags ->
    String -> String
dropBom String
string
      String -> (String -> String) -> String
forall a b. a -> (a -> b) -> b
& DynFlags -> String -> String
removeCpp DynFlags
dynFlags
      String
-> (String -> ParseResult (Located (HsModule GhcPs)))
-> ParseResult (Located (HsModule GhcPs))
forall a b. a -> (a -> b) -> b
& DynFlags -> String -> ParseResult (Located (HsModule GhcPs))
runParser DynFlags
dynFlags
      ParseResult (Located (HsModule GhcPs))
-> (ParseResult (Located (HsModule GhcPs)) -> Either String Module)
-> Either String Module
forall a b. a -> (a -> b) -> b
& DynFlags
-> ParseResult (Located (HsModule GhcPs)) -> Either String Module
toModule DynFlags
dynFlags
  where
    toModule :: GHC.DynFlags -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs)) -> Either String Module
    toModule :: DynFlags
-> ParseResult (Located (HsModule GhcPs)) -> Either String Module
toModule DynFlags
dynFlags ParseResult (Located (HsModule GhcPs))
res = case ParseResult (Located (HsModule GhcPs))
res of
      POk PState
ps Located (HsModule GhcPs)
m ->
        Module -> Either String Module
forall a b. b -> Either a b
Right (PState -> Located (HsModule GhcPs) -> Module
makeModule PState
ps Located (HsModule GhcPs)
m)
      PFailed PState
failureState ->
        let
          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
        in
        String -> Either String Module
forall a b. a -> Either a b
Left (String -> Either String Module)
-> (PState -> String) -> PState -> Either String Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
withFileName (String -> String) -> (PState -> String) -> PState -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String) -> (PState -> [String]) -> PState -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PState -> [String]
getParserStateErrors DynFlags
dynFlags (PState -> Either String Module) -> PState -> Either String Module
forall a b. (a -> b) -> a -> b
$ PState
failureState

    removeCpp :: DynFlags -> String -> String
removeCpp DynFlags
dynFlags String
s =
      if Extension -> DynFlags -> Bool
GHC.xopt Extension
GHC.Cpp DynFlags
dynFlags then String -> String
unCpp String
s
      else String
s

    userExtensions :: [Located String]
userExtensions =
      (String -> Located String) -> [String] -> [Located String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Located String
toLocatedExtensionFlag (String
"Haskell2010" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
exts) -- FIXME: do we need `Haskell2010` here?

    toLocatedExtensionFlag :: String -> Located String
toLocatedExtensionFlag String
flag
      = String
"-X" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
flag
      String -> (String -> Located String) -> Located String
forall a b. a -> (a -> b) -> b
& SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
GHC.noSrcSpan

    getParserStateErrors :: DynFlags -> PState -> [String]
getParserStateErrors DynFlags
dynFlags PState
state
      = PState -> DynFlags -> ErrorMessages
GHC.getErrorMessages PState
state DynFlags
dynFlags
      ErrorMessages -> (ErrorMessages -> [ErrMsg]) -> [ErrMsg]
forall a b. a -> (a -> b) -> b
& ErrorMessages -> [ErrMsg]
forall a. Bag a -> [a]
bagToList
      [ErrMsg] -> ([ErrMsg] -> [String]) -> [String]
forall a b. a -> (a -> b) -> b
& (ErrMsg -> String) -> [ErrMsg] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ErrMsg
errMsg -> SrcSpan -> String
forall a. Show a => a -> String
show (ErrMsg -> SrcSpan
GHC.errMsgSpan ErrMsg
errMsg) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ErrMsg -> String
forall a. Show a => a -> String
show ErrMsg
errMsg)

    filePath :: String
filePath =
      String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"<interactive>" Maybe String
fp

    runParser :: GHC.DynFlags -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs))
    runParser :: DynFlags -> String -> ParseResult (Located (HsModule GhcPs))
runParser DynFlags
flags String
str =
      let
        filename :: FastString
filename = String -> FastString
mkFastString String
filePath
        parseState :: PState
parseState = DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState DynFlags
flags (String -> StringBuffer
stringToStringBuffer String
str) (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
filename Int
1 Int
1)
      in
        P (Located (HsModule GhcPs))
-> PState -> ParseResult (Located (HsModule GhcPs))
forall a. P a -> PState -> ParseResult a
unP P (Located (HsModule GhcPs))
GHC.parseModule PState
parseState

-- | Parse 'DynFlags' from the extra options
--
--   /Note:/ this function would be IO, but we're not using any of the internal
--   features that constitute side effectful computation. So I think it's fine
--   if we run this to avoid changing the interface too much.
parsePragmasIntoDynFlags ::
     GHC.DynFlags
  -> [GHC.Located String]
  -> FilePath
  -> String
  -> Either String GHC.DynFlags
{-# NOINLINE parsePragmasIntoDynFlags #-}
parsePragmasIntoDynFlags :: DynFlags
-> [Located String] -> String -> String -> Either String DynFlags
parsePragmasIntoDynFlags DynFlags
originalFlags [Located String]
extraOpts String
filepath String
str = IO (Either String DynFlags) -> Either String DynFlags
forall a. IO a -> a
unsafePerformIO (IO (Either String DynFlags) -> Either String DynFlags)
-> IO (Either String DynFlags) -> Either String DynFlags
forall a b. (a -> b) -> a -> b
$ IO (Either String DynFlags) -> IO (Either String DynFlags)
forall (m :: * -> *) b.
ExceptionMonad m =>
m (Either String b) -> m (Either String b)
catchErrors (IO (Either String DynFlags) -> IO (Either String DynFlags))
-> IO (Either String DynFlags) -> IO (Either String DynFlags)
forall a b. (a -> b) -> a -> b
$ do
  let opts :: [Located String]
opts = DynFlags -> StringBuffer -> String -> [Located String]
GHC.getOptions DynFlags
originalFlags (String -> StringBuffer
GHC.stringToStringBuffer String
str) String
filepath
  (DynFlags
parsedFlags, [Located String]
_invalidFlags, [Warn]
_warnings) <- DynFlags
-> [Located String] -> IO (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
GHC.parseDynamicFilePragma DynFlags
originalFlags ([Located String]
opts [Located String] -> [Located String] -> [Located String]
forall a. Semigroup a => a -> a -> a
<> [Located String]
extraOpts)
  -- FIXME: have a look at 'leftovers' since it should be empty
  Either String DynFlags -> IO (Either String DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String DynFlags -> IO (Either String DynFlags))
-> Either String DynFlags -> IO (Either String DynFlags)
forall a b. (a -> b) -> a -> b
$ DynFlags -> Either String DynFlags
forall a b. b -> Either a b
Right (DynFlags -> Either String DynFlags)
-> DynFlags -> Either String DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
parsedFlags DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_KeepRawTokenStream
  where
    catchErrors :: m (Either String b) -> m (Either String b)
catchErrors m (Either String b)
act = (GhcException -> m (Either String b))
-> m (Either String b) -> m (Either String b)
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
GHC.handleGhcException GhcException -> m (Either String b)
forall (m :: * -> *) a b.
(Monad m, Show a) =>
a -> m (Either String b)
reportErr ((SourceError -> m (Either String b))
-> m (Either String b) -> m (Either String b)
forall (m :: * -> *) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
GHC.handleSourceError SourceError -> m (Either String b)
forall (m :: * -> *) a b.
(Monad m, Show a) =>
a -> m (Either String b)
reportErr m (Either String b)
act)
    reportErr :: a -> m (Either String b)
reportErr a
e = Either String b -> m (Either String b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String b -> m (Either String b))
-> Either String b -> m (Either String b)
forall a b. (a -> b) -> a -> b
$ String -> Either String b
forall a b. a -> Either a b
Left (a -> String
forall a. Show a => a -> String
show a
e)