{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeApplications #-}
module Language.Haskell.GHC.Parser (
  -- Parser handling
  runParser,
  LineNumber,
  ColumnNumber,
  ErrMsg,
  StringLoc(..),
  ParseOutput(..),
  Parser,
  Located(..),

  -- Different parsers
  parserStatement,
  parserImport,
  parserDeclaration,
  parserTypeSignature,
  parserModule,
  parserExpression,
  parsePragmasIntoDynFlags,

  -- Haskell string preprocessing.
  removeComments,
  layoutChunks,
  ) where

import Data.List (intercalate, findIndex, isInfixOf)
import Data.Char (isAlphaNum)

#if MIN_VERSION_ghc(9,8,0)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Parser.Errors.Types (PsMessage(..))
import GHC.Types.Error (defaultDiagnosticOpts, getMessages, MsgEnvelope(..))
import GHC.Utils.Error (diagnosticMessage, formatBulleted)
import GHC.Utils.Outputable (defaultSDocContext, renderWithContext)
#elif MIN_VERSION_ghc(9,6,0)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Parser.Errors.Types (PsMessage(..))
import GHC.Types.Error (getMessages, MsgEnvelope(..))
import GHC.Utils.Error (diagnosticMessage, defaultDiagnosticOpts, formatBulleted)
import GHC.Utils.Outputable (defaultSDocContext, renderWithContext)
#elif MIN_VERSION_ghc(9,4,0)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Types.Error (diagnosticMessage, getMessages, MsgEnvelope(..))
import GHC.Utils.Error (formatBulleted)
import GHC.Utils.Outputable (defaultSDocContext)
#elif MIN_VERSION_ghc(9,2,0)
import GHC.Driver.Config (initParserOpts)
import GHC.Parser.Errors.Ppr (pprError)
#endif

#if MIN_VERSION_ghc(9,0,0)
import GHC.Data.Bag
import GHC.Driver.Session (parseDynamicFilePragma)
import GHC.Data.FastString
import GHC.Parser.Header (getOptions)
import GHC.Parser.Lexer hiding (buffer)
import GHC.Data.OrdList
import GHC.Utils.Panic (handleGhcException)
import qualified GHC.Types.SrcLoc as SrcLoc
import GHC.Data.StringBuffer hiding (len)
#else
import Bag
import DynFlags (parseDynamicFilePragma)
import FastString
import HeaderInfo (getOptions)
import Lexer hiding (buffer)
import OrdList
import Panic (handleGhcException)
import qualified SrcLoc as SrcLoc
import StringBuffer hiding (len)
#endif
#if MIN_VERSION_ghc(8,10,0)
#else
import ErrUtils hiding (ErrMsg)
#endif
#if MIN_VERSION_ghc(8,4,0)
import GHC hiding (Located, Parsed, parser)
#else
import GHC hiding (Located, parser)
#endif

import qualified Language.Haskell.GHC.HappyParser as Parse

-- | A line number in an input string.
type LineNumber   = Int

-- | A column number in an input string.
type ColumnNumber = Int

-- | An error message string.
type ErrMsg = String

-- | A location in an input string.
data StringLoc = Loc LineNumber ColumnNumber deriving (Int -> StringLoc -> ShowS
[StringLoc] -> ShowS
StringLoc -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StringLoc] -> ShowS
$cshowList :: [StringLoc] -> ShowS
show :: StringLoc -> String
$cshow :: StringLoc -> String
showsPrec :: Int -> StringLoc -> ShowS
$cshowsPrec :: Int -> StringLoc -> ShowS
Show, StringLoc -> StringLoc -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StringLoc -> StringLoc -> Bool
$c/= :: StringLoc -> StringLoc -> Bool
== :: StringLoc -> StringLoc -> Bool
$c== :: StringLoc -> StringLoc -> Bool
Eq)

-- | Output from running a parser.
data ParseOutput a
    = Failure ErrMsg StringLoc    -- ^ Parser failed with given error message and location.
    | Parsed a                    -- ^ Parser succeeded with an output.
    | Partial a (String, String)  -- ^ Partial parser succeeded with an output.
    deriving (ParseOutput a -> ParseOutput a -> Bool
forall a. Eq a => ParseOutput a -> ParseOutput a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseOutput a -> ParseOutput a -> Bool
$c/= :: forall a. Eq a => ParseOutput a -> ParseOutput a -> Bool
== :: ParseOutput a -> ParseOutput a -> Bool
$c== :: forall a. Eq a => ParseOutput a -> ParseOutput a -> Bool
Eq, Int -> ParseOutput a -> ShowS
forall a. Show a => Int -> ParseOutput a -> ShowS
forall a. Show a => [ParseOutput a] -> ShowS
forall a. Show a => ParseOutput a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseOutput a] -> ShowS
$cshowList :: forall a. Show a => [ParseOutput a] -> ShowS
show :: ParseOutput a -> String
$cshow :: forall a. Show a => ParseOutput a -> String
showsPrec :: Int -> ParseOutput a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ParseOutput a -> ShowS
Show)                  -- Auxiliary strings say what part of the
                                  -- input string was used and what
                                  -- part is remaining.
                                  --
-- | Store locations along with a value.
data Located a = Located {
    forall a. Located a -> Int
line :: LineNumber, -- Where this element is located.
    forall a. Located a -> a
unloc :: a          -- Located element.
  } deriving (Located a -> Located a -> Bool
forall a. Eq a => Located a -> Located a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Located a -> Located a -> Bool
$c/= :: forall a. Eq a => Located a -> Located a -> Bool
== :: Located a -> Located a -> Bool
$c== :: forall a. Eq a => Located a -> Located a -> Bool
Eq, Int -> Located a -> ShowS
forall a. Show a => Int -> Located a -> ShowS
forall a. Show a => [Located a] -> ShowS
forall a. Show a => Located a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Located a] -> ShowS
$cshowList :: forall a. Show a => [Located a] -> ShowS
show :: Located a -> String
$cshow :: forall a. Show a => Located a -> String
showsPrec :: Int -> Located a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Located a -> ShowS
Show, forall a b. a -> Located b -> Located a
forall a b. (a -> b) -> Located a -> Located b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Located b -> Located a
$c<$ :: forall a b. a -> Located b -> Located a
fmap :: forall a b. (a -> b) -> Located a -> Located b
$cfmap :: forall a b. (a -> b) -> Located a -> Located b
Functor)


data Parser a = Parser (P a)

-- Our parsers.
#if MIN_VERSION_ghc(8,4,0)
parserStatement :: Parser (Maybe (LStmt GhcPs (LHsExpr GhcPs)))
#else
parserStatement :: Parser (Maybe (LStmt RdrName (LHsExpr RdrName)))
#endif
parserStatement :: Parser (Maybe (LStmt GhcPs (LHsExpr GhcPs)))
parserStatement = forall a. P a -> Parser a
Parser P (Maybe (LStmt GhcPs (LHsExpr GhcPs)))
Parse.fullStatement

#if MIN_VERSION_ghc(8,4,0)
parserImport :: Parser (LImportDecl GhcPs)
#else
parserImport :: Parser (LImportDecl RdrName)
#endif
parserImport :: Parser (LImportDecl GhcPs)
parserImport = forall a. P a -> Parser a
Parser P (LImportDecl GhcPs)
Parse.fullImport

#if MIN_VERSION_ghc(8,4,0)
parserDeclaration :: Parser (OrdList (LHsDecl GhcPs))
#else
parserDeclaration :: Parser (OrdList (LHsDecl RdrName))
#endif
parserDeclaration :: Parser (OrdList (LHsDecl GhcPs))
parserDeclaration = forall a. P a -> Parser a
Parser P (OrdList (LHsDecl GhcPs))
Parse.fullDeclaration

#if MIN_VERSION_ghc(8,4,0)
parserExpression :: Parser (LHsExpr GhcPs)
#else
parserExpression :: Parser (LHsExpr RdrName)
#endif
parserExpression :: Parser (LHsExpr GhcPs)
parserExpression = forall a. P a -> Parser a
Parser P (LHsExpr GhcPs)
Parse.fullExpression

#if MIN_VERSION_ghc(8,4,0)
parserTypeSignature :: Parser (SrcLoc.Located (OrdList (LHsDecl GhcPs)))
#else
parserTypeSignature :: Parser (SrcLoc.Located (OrdList (LHsDecl RdrName)))
#endif
parserTypeSignature :: Parser (Located (OrdList (LHsDecl GhcPs)))
parserTypeSignature = forall a. P a -> Parser a
Parser P (Located (OrdList (LHsDecl GhcPs)))
Parse.fullTypeSignature

#if MIN_VERSION_ghc(9,6,0)
parserModule :: Parser (SrcLoc.Located (HsModule GhcPs))
#elif MIN_VERSION_ghc(9,0,0)
parserModule :: Parser (SrcLoc.Located HsModule)
#elif MIN_VERSION_ghc(8,4,0)
parserModule :: Parser (SrcLoc.Located (HsModule GhcPs))
#else
parserModule :: Parser (SrcLoc.Located (HsModule RdrName))
#endif
parserModule :: Parser (Located HsModule)
parserModule = forall a. P a -> Parser a
Parser P (Located HsModule)
Parse.fullModule

-- | Run a GHC parser on a string. Return success or failure with
-- associated information for both.
runParser :: DynFlags -> Parser a -> String -> ParseOutput a
runParser :: forall a. DynFlags -> Parser a -> String -> ParseOutput a
runParser DynFlags
flags (Parser P a
parser) String
str =
  -- Create an initial parser state.
  let filename :: String
filename = String
"<interactive>"
      location :: RealSrcLoc
location = FastString -> Int -> Int -> RealSrcLoc
SrcLoc.mkRealSrcLoc (String -> FastString
mkFastString String
filename) Int
1 Int
1
      buffer :: StringBuffer
buffer = String -> StringBuffer
stringToStringBuffer String
str
#if MIN_VERSION_ghc(9,2,0)
      parseState :: PState
parseState = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> ParserOpts
initParserOpts DynFlags
flags) StringBuffer
buffer RealSrcLoc
location in
#else
      parseState = mkPState flags buffer location in
#endif
    -- Convert a GHC parser output into our own.
    forall a. ParseResult a -> ParseOutput a
toParseOut (forall a. P a -> PState -> ParseResult a
unP P a
parser PState
parseState)
  where
    toParseOut :: ParseResult a -> ParseOutput a
#if MIN_VERSION_ghc(9,4,0)
    toParseOut (PFailed pstate) =
      let realSpan = SrcLoc.psRealSpan $ last_loc pstate
          errMsg = printErrorBag (getMessages $ errors pstate)
          ln = srcLocLine $ SrcLoc.realSrcSpanStart realSpan
          col = srcLocCol $ SrcLoc.realSrcSpanStart realSpan
        in Failure errMsg $ Loc ln col
#elif MIN_VERSION_ghc(9,2,0)
    toParseOut :: forall a. ParseResult a -> ParseOutput a
toParseOut (PFailed PState
pstate) =
      let realSpan :: RealSrcSpan
realSpan = PsSpan -> RealSrcSpan
SrcLoc.psRealSpan forall a b. (a -> b) -> a -> b
$ PState -> PsSpan
last_loc PState
pstate
          errMsg :: String
errMsg = Bag PsError -> String
printErrorBag (PState -> Bag PsError
errors PState
pstate)
          ln :: Int
ln = RealSrcLoc -> Int
srcLocLine forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
SrcLoc.realSrcSpanStart RealSrcSpan
realSpan
          col :: Int
col = RealSrcLoc -> Int
srcLocCol forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
SrcLoc.realSrcSpanStart RealSrcSpan
realSpan
        in forall a. String -> StringLoc -> ParseOutput a
Failure String
errMsg forall a b. (a -> b) -> a -> b
$ Int -> Int -> StringLoc
Loc Int
ln Int
col
#elif MIN_VERSION_ghc(9,0,0)
    toParseOut (PFailed pstate) =
      let realSpan = SrcLoc.psRealSpan $ last_loc pstate
          errMsg = printErrorBag $ snd $ (messages pstate) flags
          ln = srcLocLine $ SrcLoc.realSrcSpanStart realSpan
          col = srcLocCol $ SrcLoc.realSrcSpanStart realSpan
        in Failure errMsg $ Loc ln col
#elif MIN_VERSION_ghc(8,10,0)
    toParseOut (PFailed pstate) =
      let realSpan = last_loc pstate
          errMsg = printErrorBag $ snd $ (messages pstate) flags
          ln = srcLocLine $ SrcLoc.realSrcSpanStart realSpan
          col = srcLocCol $ SrcLoc.realSrcSpanStart realSpan
        in Failure errMsg $ Loc ln col
#elif MIN_VERSION_ghc(8,4,0)
    toParseOut (PFailed _ spn@(RealSrcSpan realSpan) err) =
      let errMsg = printErrorBag $ unitBag $ mkPlainErrMsg flags spn err
          ln = srcLocLine $ SrcLoc.realSrcSpanStart realSpan
          col = srcLocCol $ SrcLoc.realSrcSpanStart realSpan
        in Failure errMsg $ Loc ln col
#else
    toParseOut (PFailed spn@(RealSrcSpan realSpan) err) =
      let errMsg = printErrorBag $ unitBag $ mkPlainErrMsg flags spn err
          ln = srcLocLine $ SrcLoc.realSrcSpanStart realSpan
          col = srcLocCol $ SrcLoc.realSrcSpanStart realSpan
        in Failure errMsg $ Loc ln col
#endif

#if MIN_VERSION_ghc(8,10,0)
#elif MIN_VERSION_ghc(8,4,0)
    toParseOut (PFailed _ spn err) =
      let errMsg = printErrorBag $ unitBag $ mkPlainErrMsg flags spn err
        in Failure errMsg $ Loc 0 0
#else
    toParseOut (PFailed spn err) =
      let errMsg = printErrorBag $ unitBag $ mkPlainErrMsg flags spn err
        in Failure errMsg $ Loc 0 0
#endif

    toParseOut (POk PState
_parseState a
result) =
      forall a. a -> ParseOutput a
Parsed a
result

    -- Convert the bag of errors into an error string.
#if MIN_VERSION_ghc(9,8,0)
    printErrorBag bag = joinLines . map (renderWithContext defaultSDocContext . formatBulleted . diagnosticMessage (defaultDiagnosticOpts @PsMessage) . errMsgDiagnostic) $ bagToList bag
#elif MIN_VERSION_ghc(9,6,0)
    printErrorBag bag = joinLines . map (renderWithContext defaultSDocContext . formatBulleted defaultSDocContext . diagnosticMessage (defaultDiagnosticOpts @PsMessage) . errMsgDiagnostic) $ bagToList bag
#elif MIN_VERSION_ghc(9,4,0)
    printErrorBag bag = joinLines . map (show . formatBulleted defaultSDocContext . diagnosticMessage . errMsgDiagnostic) $ bagToList bag
#elif MIN_VERSION_ghc(9,2,0)
    printErrorBag :: Bag PsError -> String
printErrorBag Bag PsError
bag = [String] -> String
joinLines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. PsError -> MsgEnvelope DecoratedSDoc
pprError) forall a b. (a -> b) -> a -> b
$ forall a. Bag a -> [a]
bagToList Bag PsError
bag
#else
    printErrorBag bag = joinLines . map show $ bagToList bag
#endif

-- Taken from http://blog.shaynefletcher.org/2019/06/have-ghc-parsing-respect-dynamic-pragmas.html
parsePragmasIntoDynFlags :: DynFlags -> FilePath -> String -> IO (Maybe DynFlags)
parsePragmasIntoDynFlags :: DynFlags -> String -> String -> IO (Maybe DynFlags)
parsePragmasIntoDynFlags DynFlags
flags String
filepath String
str =
  IO (Maybe DynFlags) -> IO (Maybe DynFlags)
catchErrors forall a b. (a -> b) -> a -> b
$ do
#if MIN_VERSION_ghc(9,4,0)
    let opts = snd $ getOptions (initParserOpts flags) (stringToStringBuffer str) filepath
#else
    let opts :: [Located String]
opts = DynFlags -> StringBuffer -> String -> [Located String]
getOptions DynFlags
flags (String -> StringBuffer
stringToStringBuffer String
str) String
filepath
#endif
    (DynFlags
flags', [Located String]
_, [Warn]
_) <- forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
flags [Located String]
opts
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just DynFlags
flags'
  where
    catchErrors :: IO (Maybe DynFlags) -> IO (Maybe DynFlags)
    catchErrors :: IO (Maybe DynFlags) -> IO (Maybe DynFlags)
catchErrors IO (Maybe DynFlags)
act =
      forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
handleGhcException forall {a} {a}. Show a => a -> IO (Maybe a)
reportErr (forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError forall {a} {a}. Show a => a -> IO (Maybe a)
reportErr IO (Maybe DynFlags)
act)
    reportErr :: a -> IO (Maybe a)
reportErr a
e = do
      String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"error : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
e
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- Not the same as 'unlines', due to trailing \n
joinLines :: [String] -> String
joinLines :: [String] -> String
joinLines = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"

-- | Split an input string into chunks based on indentation.
-- A chunk is a line and all lines immediately following that are indented
-- beyond the indentation of the first line. This parses Haskell layout
-- rules properly, and allows using multiline expressions via indentation.
--
-- Quasiquotes are allowed via a post-processing step.
layoutChunks :: String -> [Located String]
layoutChunks :: String -> [Located String]
layoutChunks = [Located String] -> [Located String]
joinQuasiquotes forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> [Located String]
go Int
1
  where
    go :: LineNumber -> String -> [Located String]
    go :: Int -> String -> [Located String]
go Int
ln = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Located a -> a
unloc) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
strip) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [Located String]
layoutLines Int
ln forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

    -- drop spaces on left and right
    strip :: ShowS
strip = ShowS
dropRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dropLeft
      where
        dropLeft :: ShowS
dropLeft = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
whitespace)
        dropRight :: ShowS
dropRight = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
whitespace) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
        whitespace :: String
whitespace = String
" \t\n"

    layoutLines :: LineNumber -> [String] -> [Located String]
    -- Empty string case.  If there's no input, output is empty.
    layoutLines :: Int -> [String] -> [Located String]
layoutLines Int
_ [] = []

    -- Use the indent of the first line to find the end of the first block.
    layoutLines Int
lineIdx xs :: [String]
xs@(String
firstLine:[String]
rest) =
      let firstIndent :: Int
firstIndent = String -> Int
indentLevel String
firstLine
          blockEnded :: String -> Bool
blockEnded String
ln = String -> Int
indentLevel String
ln forall a. Ord a => a -> a -> Bool
<= Int
firstIndent in
        case forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex String -> Bool
blockEnded [String]
rest of
          -- If the first block doesn't end, return the whole string, since
          -- that just means the block takes up the entire string.
          Maybe Int
Nothing -> [forall a. Int -> a -> Located a
Located Int
lineIdx forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [String]
xs]

          -- We found the end of the block. Split this bit out and recurse.
          Just Int
idx ->
            let ([String]
before, [String]
after) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
idx [String]
rest in
              forall a. Int -> a -> Located a
Located Int
lineIdx ([String] -> String
joinLines forall a b. (a -> b) -> a -> b
$ String
firstLineforall a. a -> [a] -> [a]
:[String]
before) forall a. a -> [a] -> [a]
: Int -> String -> [Located String]
go (Int
lineIdx forall a. Num a => a -> a -> a
+ Int
idx forall a. Num a => a -> a -> a
+ Int
1) ([String] -> String
joinLines [String]
after)

    -- Compute indent level of a string as number of leading spaces.
    indentLevel :: String -> Int
    indentLevel :: String -> Int
indentLevel (Char
' ':String
str) = Int
1 forall a. Num a => a -> a -> a
+ String -> Int
indentLevel String
str

    -- Count a tab as two spaces.
    indentLevel (Char
'\t':String
str) = Int
2 forall a. Num a => a -> a -> a
+ String -> Int
indentLevel String
str

    -- Count empty lines as a large indent level, so they're always with the previous expression.
    indentLevel String
"" = Int
100000

    indentLevel String
_ = Int
0


-- | Drop comments from Haskell source.
-- Simply gets rid of them, does not replace them in any way.
removeComments :: String -> String
removeComments :: ShowS
removeComments = ShowS
removeOneLineComments forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ShowS
removeMultilineComments Int
0 Int
0
  where
    removeOneLineComments :: ShowS
removeOneLineComments String
str =
      case String
str of
        -- Don't remove comments after cmd directives
        Char
':':Char
'!':String
remaining ->String
":!" forall a. [a] -> [a] -> [a]
++ ShowS
takeLine String
remaining forall a. [a] -> [a] -> [a]
++ ShowS
dropLine String
remaining

        -- Handle strings.
        Char
'"':String
remaining ->
          let quoted :: String
quoted = ShowS
takeString String
remaining
              len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
quoted in
            Char
'"'forall a. a -> [a] -> [a]
:String
quoted forall a. [a] -> [a] -> [a]
++ ShowS
removeOneLineComments (forall a. Int -> [a] -> [a]
drop Int
len String
remaining)

        Char
'-':Char
'-':String
remaining -> ShowS
dropLine String
remaining
        Char
x:String
xs -> Char
xforall a. a -> [a] -> [a]
:ShowS
removeOneLineComments String
xs
        [] -> []
      where
        dropLine :: ShowS
dropLine = ShowS
removeOneLineComments forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n')

    removeMultilineComments :: Int -> Int -> String -> String
    removeMultilineComments :: Int -> Int -> ShowS
removeMultilineComments Int
nesting Int
pragmaNesting String
str =
      case String
str of
        -- Don't remove comments after cmd directives
        Char
':':Char
'!':String
remaining ->String
":!" forall a. [a] -> [a] -> [a]
++ ShowS
takeLine String
remaining forall a. [a] -> [a] -> [a]
++
          Int -> Int -> ShowS
removeMultilineComments Int
nesting Int
pragmaNesting (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
remaining)

        -- Handle strings.
        Char
'"':String
remaining ->
          if Int
nesting forall a. Eq a => a -> a -> Bool
== Int
0
          then
            let quoted :: String
quoted = ShowS
takeString String
remaining
                len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
quoted in
              Char
'"'forall a. a -> [a] -> [a]
:String
quoted forall a. [a] -> [a] -> [a]
++ Int -> Int -> ShowS
removeMultilineComments Int
nesting Int
pragmaNesting (forall a. Int -> [a] -> [a]
drop Int
len String
remaining)
          else
            Int -> Int -> ShowS
removeMultilineComments Int
nesting Int
pragmaNesting String
remaining
        Char
'{':Char
'-':Char
'#':String
remaining ->
          if Int
nesting forall a. Eq a => a -> a -> Bool
== Int
0
          then String
"{-#" forall a. [a] -> [a] -> [a]
++ Int -> Int -> ShowS
removeMultilineComments Int
nesting (Int
pragmaNesting forall a. Num a => a -> a -> a
+ Int
1) String
remaining
          else Int -> Int -> ShowS
removeMultilineComments Int
nesting Int
pragmaNesting String
remaining
        Char
'#':Char
'-':Char
'}':String
remaining ->
          if Int
nesting forall a. Eq a => a -> a -> Bool
== Int
0
          then if Int
pragmaNesting forall a. Ord a => a -> a -> Bool
> Int
0
               then Char
'#'forall a. a -> [a] -> [a]
:Char
'-'forall a. a -> [a] -> [a]
:Char
'}'forall a. a -> [a] -> [a]
:Int -> Int -> ShowS
removeMultilineComments Int
nesting (Int
pragmaNesting forall a. Num a => a -> a -> a
- Int
1) String
remaining
               else Char
'#'forall a. a -> [a] -> [a]
:Char
'-'forall a. a -> [a] -> [a]
:Char
'}'forall a. a -> [a] -> [a]
:Int -> Int -> ShowS
removeMultilineComments Int
nesting Int
pragmaNesting String
remaining
          else Int -> Int -> ShowS
removeMultilineComments Int
nesting Int
pragmaNesting String
remaining
        Char
'{':Char
'-':String
remaining -> Int -> Int -> ShowS
removeMultilineComments (Int
nesting forall a. Num a => a -> a -> a
+ Int
1) Int
pragmaNesting String
remaining
        Char
'-':Char
'}':String
remaining ->
          if Int
nesting forall a. Ord a => a -> a -> Bool
> Int
0
          then Int -> Int -> ShowS
removeMultilineComments (Int
nesting forall a. Num a => a -> a -> a
- Int
1) Int
pragmaNesting String
remaining
          else Char
'-'forall a. a -> [a] -> [a]
:Char
'}'forall a. a -> [a] -> [a]
:Int -> Int -> ShowS
removeMultilineComments Int
nesting Int
pragmaNesting String
remaining
        Char
x:String
xs ->
          if Int
nesting forall a. Ord a => a -> a -> Bool
> Int
0
          then Int -> Int -> ShowS
removeMultilineComments Int
nesting Int
pragmaNesting String
xs
          else Char
xforall a. a -> [a] -> [a]
:Int -> Int -> ShowS
removeMultilineComments Int
nesting Int
pragmaNesting String
xs
        [] -> []

    takeLine :: ShowS
takeLine = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n')

    -- Take a part of a string that ends in an unescaped quote.
    takeString :: ShowS
takeString String
str = case String
str of
      escaped :: String
escaped@(Char
'\\':Char
'"':String
_) -> String
escaped
      Char
'"':String
_ -> String
"\""
      Char
x:String
xs -> Char
xforall a. a -> [a] -> [a]
:ShowS
takeString String
xs
      [] -> []


-- | Post processing step to combine quasiquoted blocks into single blocks.
-- This is necessary because quasiquoted blocks don't follow normal indentation rules.
joinQuasiquotes :: [Located String] -> [Located String]
joinQuasiquotes :: [Located String] -> [Located String]
joinQuasiquotes = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Located String] -> [Located String]
joinQuasiquotes' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
  where
    -- This operates by finding |] and then joining blocks until a line
    -- that has some corresponding [...|. This is still a hack, but close to
    -- good enough.
    joinQuasiquotes' :: [Located String] -> [Located String]
joinQuasiquotes' [] = []
    joinQuasiquotes' (Located String
block:[Located String]
blocks) =
      if String
"|]" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` forall a. Located a -> a
unloc Located String
block
      then
        let ([Located String]
pieces, [Located String]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String -> Bool
hasQuasiquoteStart forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Located a -> a
unloc) [Located String]
blocks
        in case [Located String]
rest of
          [] -> Located String
block forall a. a -> [a] -> [a]
: [Located String] -> [Located String]
joinQuasiquotes' [Located String]
blocks
          Located String
startBlock:[Located String]
blocks' ->
            [Located String] -> Located String
concatBlocks (Located String
block forall a. a -> [a] -> [a]
: [Located String]
pieces forall a. [a] -> [a] -> [a]
++ [Located String
startBlock]) forall a. a -> [a] -> [a]
: [Located String] -> [Located String]
joinQuasiquotes [Located String]
blocks'
      else Located String
block forall a. a -> [a] -> [a]
: [Located String] -> [Located String]
joinQuasiquotes' [Located String]
blocks

    -- Combine a lit of reversed blocks into a single, non-reversed block.
    concatBlocks :: [Located String] -> Located String
    concatBlocks :: [Located String] -> Located String
concatBlocks [Located String]
blocks = forall a. Int -> a -> Located a
Located (forall a. Located a -> Int
line forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [Located String]
blocks) forall a b. (a -> b) -> a -> b
$ [String] -> String
joinLines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a -> a
unloc forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Located String]
blocks

    -- Does this string have a [...| in it?
    hasQuasiquoteStart :: String -> Bool
    hasQuasiquoteStart :: String -> Bool
hasQuasiquoteStart String
str =
      case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'[') String
str of
        (String
_, String
"") -> Bool
False
        (String
_, Char
_:String
rest) ->
          case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'|') String
rest of
            (String
_, String
"") -> Bool
False
            (String
chars, String
_) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isIdentChar String
chars

    isIdentChar :: Char -> Bool
    isIdentChar :: Char -> Bool
isIdentChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\''