{-# 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

import GHC hiding (Located, Parsed, parser)
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
(Int -> StringLoc -> ShowS)
-> (StringLoc -> String)
-> ([StringLoc] -> ShowS)
-> Show StringLoc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StringLoc -> ShowS
showsPrec :: Int -> StringLoc -> ShowS
$cshow :: StringLoc -> String
show :: StringLoc -> String
$cshowList :: [StringLoc] -> ShowS
showList :: [StringLoc] -> ShowS
Show, StringLoc -> StringLoc -> Bool
(StringLoc -> StringLoc -> Bool)
-> (StringLoc -> StringLoc -> Bool) -> Eq StringLoc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StringLoc -> StringLoc -> Bool
== :: StringLoc -> StringLoc -> Bool
$c/= :: StringLoc -> StringLoc -> Bool
/= :: 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
(ParseOutput a -> ParseOutput a -> Bool)
-> (ParseOutput a -> ParseOutput a -> Bool) -> Eq (ParseOutput a)
forall a. Eq a => ParseOutput a -> ParseOutput a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: ParseOutput a -> ParseOutput a -> Bool
Eq, Int -> ParseOutput a -> ShowS
[ParseOutput a] -> ShowS
ParseOutput a -> String
(Int -> ParseOutput a -> ShowS)
-> (ParseOutput a -> String)
-> ([ParseOutput a] -> ShowS)
-> Show (ParseOutput a)
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
$cshowsPrec :: forall a. Show a => Int -> ParseOutput a -> ShowS
showsPrec :: Int -> ParseOutput a -> ShowS
$cshow :: forall a. Show a => ParseOutput a -> String
show :: ParseOutput a -> String
$cshowList :: forall a. Show a => [ParseOutput a] -> ShowS
showList :: [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
(Located a -> Located a -> Bool)
-> (Located a -> Located a -> Bool) -> Eq (Located a)
forall a. Eq a => Located a -> Located a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Located a -> Located a -> Bool
Eq, Int -> Located a -> ShowS
[Located a] -> ShowS
Located a -> String
(Int -> Located a -> ShowS)
-> (Located a -> String)
-> ([Located a] -> ShowS)
-> Show (Located a)
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
$cshowsPrec :: forall a. Show a => Int -> Located a -> ShowS
showsPrec :: Int -> Located a -> ShowS
$cshow :: forall a. Show a => Located a -> String
show :: Located a -> String
$cshowList :: forall a. Show a => [Located a] -> ShowS
showList :: [Located a] -> ShowS
Show, (forall a b. (a -> b) -> Located a -> Located b)
-> (forall a b. a -> Located b -> Located a) -> Functor Located
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
$cfmap :: forall a b. (a -> b) -> Located a -> Located b
fmap :: forall a b. (a -> b) -> Located a -> Located b
$c<$ :: forall a b. a -> Located b -> Located a
<$ :: forall a b. a -> Located b -> Located a
Functor)


data Parser a = Parser (P a)

-- Our parsers.
parserStatement :: Parser (Maybe (LStmt GhcPs (LHsExpr GhcPs)))
parserStatement :: Parser (Maybe (LStmt GhcPs (LHsExpr GhcPs)))
parserStatement = P (Maybe
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> Parser
     (Maybe
        (GenLocated
           SrcSpanAnnA
           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
forall a. P a -> Parser a
Parser P (Maybe (LStmt GhcPs (LHsExpr GhcPs)))
P (Maybe
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
Parse.fullStatement

parserImport :: Parser (LImportDecl GhcPs)
parserImport :: Parser (LImportDecl GhcPs)
parserImport = P (GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Parser (GenLocated SrcSpanAnnA (ImportDecl GhcPs))
forall a. P a -> Parser a
Parser P (LImportDecl GhcPs)
P (GenLocated SrcSpanAnnA (ImportDecl GhcPs))
Parse.fullImport

parserDeclaration :: Parser (OrdList (LHsDecl GhcPs))
parserDeclaration :: Parser (OrdList (LHsDecl GhcPs))
parserDeclaration = P (OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> Parser (OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. P a -> Parser a
Parser P (OrdList (LHsDecl GhcPs))
P (OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
Parse.fullDeclaration

parserExpression :: Parser (LHsExpr GhcPs)
parserExpression :: Parser (LHsExpr GhcPs)
parserExpression = P (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Parser (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. P a -> Parser a
Parser P (LHsExpr GhcPs)
P (GenLocated SrcSpanAnnA (HsExpr GhcPs))
Parse.fullExpression

parserTypeSignature :: Parser (SrcLoc.Located (OrdList (LHsDecl GhcPs)))
parserTypeSignature :: Parser (Located (OrdList (LHsDecl GhcPs)))
parserTypeSignature = P (Located (OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> Parser
     (Located (OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
forall a. P a -> Parser a
Parser P (Located (OrdList (LHsDecl GhcPs)))
P (Located (OrdList (GenLocated SrcSpanAnnA (HsDecl 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)
#else
parserModule :: Parser (SrcLoc.Located (HsModule GhcPs))
#endif
parserModule :: Parser (Located (HsModule GhcPs))
parserModule = P (Located (HsModule GhcPs)) -> Parser (Located (HsModule GhcPs))
forall a. P a -> Parser a
Parser P (Located (HsModule GhcPs))
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.
    ParseResult a -> ParseOutput a
forall a. ParseResult a -> ParseOutput a
toParseOut (P a -> PState -> ParseResult a
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 :: forall a. ParseResult a -> ParseOutput a
toParseOut (PFailed PState
pstate) =
      let realSpan :: RealSrcSpan
realSpan = PsSpan -> RealSrcSpan
SrcLoc.psRealSpan (PsSpan -> RealSrcSpan) -> PsSpan -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ PState -> PsSpan
last_loc PState
pstate
          errMsg :: String
errMsg = Bag (MsgEnvelope PsMessage) -> String
forall {b}.
(DiagnosticOpts b ~ NoDiagnosticOpts, Diagnostic b) =>
Bag (MsgEnvelope b) -> String
printErrorBag (Messages PsMessage -> Bag (MsgEnvelope PsMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages (Messages PsMessage -> Bag (MsgEnvelope PsMessage))
-> Messages PsMessage -> Bag (MsgEnvelope PsMessage)
forall a b. (a -> b) -> a -> b
$ PState -> Messages PsMessage
errors PState
pstate)
          ln :: Int
ln = RealSrcLoc -> Int
srcLocLine (RealSrcLoc -> Int) -> RealSrcLoc -> Int
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
SrcLoc.realSrcSpanStart RealSrcSpan
realSpan
          col :: Int
col = RealSrcLoc -> Int
srcLocCol (RealSrcLoc -> Int) -> RealSrcLoc -> Int
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
SrcLoc.realSrcSpanStart RealSrcSpan
realSpan
        in String -> StringLoc -> ParseOutput a
forall a. String -> StringLoc -> ParseOutput a
Failure String
errMsg (StringLoc -> ParseOutput a) -> StringLoc -> ParseOutput a
forall a b. (a -> b) -> a -> b
$ Int -> Int -> StringLoc
Loc Int
ln Int
col
#elif MIN_VERSION_ghc(9,2,0)
    toParseOut (PFailed pstate) =
      let realSpan = SrcLoc.psRealSpan $ last_loc pstate
          errMsg = printErrorBag (errors pstate)
          ln = srcLocLine $ SrcLoc.realSrcSpanStart realSpan
          col = srcLocCol $ SrcLoc.realSrcSpanStart realSpan
        in Failure errMsg $ Loc ln 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
#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)
#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) =
      a -> ParseOutput a
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 (MsgEnvelope b) -> String
printErrorBag Bag (MsgEnvelope b)
bag = [String] -> String
joinLines ([String] -> String)
-> ([MsgEnvelope b] -> [String]) -> [MsgEnvelope b] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MsgEnvelope b -> String) -> [MsgEnvelope b] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (SDoc -> String)
-> (MsgEnvelope b -> SDoc) -> MsgEnvelope b -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
defaultSDocContext (DecoratedSDoc -> SDoc)
-> (MsgEnvelope b -> DecoratedSDoc) -> MsgEnvelope b -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiagnosticOpts b -> b -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage (forall a. Diagnostic a => DiagnosticOpts a
defaultDiagnosticOpts @PsMessage) (b -> DecoratedSDoc)
-> (MsgEnvelope b -> b) -> MsgEnvelope b -> DecoratedSDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope b -> b
forall e. MsgEnvelope e -> e
errMsgDiagnostic) ([MsgEnvelope b] -> String) -> [MsgEnvelope b] -> String
forall a b. (a -> b) -> a -> b
$ Bag (MsgEnvelope b) -> [MsgEnvelope b]
forall a. Bag a -> [a]
bagToList Bag (MsgEnvelope b)
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 = joinLines . map (show . pprError) $ bagToList 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 (IO (Maybe DynFlags) -> IO (Maybe DynFlags))
-> IO (Maybe DynFlags) -> IO (Maybe DynFlags)
forall a b. (a -> b) -> a -> b
$ do
#if MIN_VERSION_ghc(9,4,0)
    let opts :: [Located String]
opts = (Messages PsMessage, [Located String]) -> [Located String]
forall a b. (a, b) -> b
snd ((Messages PsMessage, [Located String]) -> [Located String])
-> (Messages PsMessage, [Located String]) -> [Located String]
forall a b. (a -> b) -> a -> b
$ ParserOpts
-> StringBuffer -> String -> (Messages PsMessage, [Located String])
getOptions (DynFlags -> ParserOpts
initParserOpts DynFlags
flags) (String -> StringBuffer
stringToStringBuffer String
str) String
filepath
#else
    let opts = getOptions flags (stringToStringBuffer str) filepath
#endif
    (DynFlags
flags', [Located String]
_, [Warn]
_) <- DynFlags
-> [Located String] -> IO (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
flags [Located String]
opts
    Maybe DynFlags -> IO (Maybe DynFlags)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DynFlags -> IO (Maybe DynFlags))
-> Maybe DynFlags -> IO (Maybe DynFlags)
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe DynFlags
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 =
      (GhcException -> IO (Maybe DynFlags))
-> IO (Maybe DynFlags) -> IO (Maybe DynFlags)
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
handleGhcException GhcException -> IO (Maybe DynFlags)
forall {a} {a}. Show a => a -> IO (Maybe a)
reportErr ((SourceError -> IO (Maybe DynFlags))
-> IO (Maybe DynFlags) -> IO (Maybe DynFlags)
forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> IO (Maybe DynFlags)
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"error : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
e
      Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

-- Not the same as 'unlines', due to trailing \n
joinLines :: [String] -> String
joinLines :: [String] -> String
joinLines = String -> [String] -> String
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 ([Located String] -> [Located String])
-> (String -> [Located String]) -> String -> [Located String]
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 = (Located String -> Bool) -> [Located String] -> [Located String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (Located String -> Bool) -> Located String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool)
-> (Located String -> String) -> Located String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located String -> String
forall a. Located a -> a
unloc) ([Located String] -> [Located String])
-> (String -> [Located String]) -> String -> [Located String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located String -> Located String)
-> [Located String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS -> Located String -> Located String
forall a b. (a -> b) -> Located a -> Located b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
strip) ([Located String] -> [Located String])
-> (String -> [Located String]) -> String -> [Located String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [Located String]
layoutLines Int
ln ([String] -> [Located String])
-> (String -> [String]) -> String -> [Located String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

    -- drop spaces on left and right
    strip :: ShowS
strip = ShowS
dropRight ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dropLeft
      where
        dropLeft :: ShowS
dropLeft = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
whitespace)
        dropRight :: ShowS
dropRight = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
whitespace) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
firstIndent in
        case (String -> Bool) -> [String] -> Maybe Int
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 -> [Int -> String -> Located String
forall a. Int -> a -> Located a
Located Int
lineIdx (String -> Located String) -> String -> Located String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
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) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
idx [String]
rest in
              Int -> String -> Located String
forall a. Int -> a -> Located a
Located Int
lineIdx ([String] -> String
joinLines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
firstLineString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
before) Located String -> [Located String] -> [Located String]
forall a. a -> [a] -> [a]
: Int -> String -> [Located String]
go (Int
lineIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
idx Int -> Int -> Int
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 Int -> Int -> Int
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 Int -> Int -> Int
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 ShowS -> ShowS -> ShowS
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
":!" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
takeLine String
remaining String -> ShowS
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 = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
quoted in
            Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:String
quoted String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
removeOneLineComments (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
len String
remaining)

        Char
'-':Char
'-':String
remaining -> ShowS
dropLine String
remaining
        Char
x:String
xs -> Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:ShowS
removeOneLineComments String
xs
        [] -> []
      where
        dropLine :: ShowS
dropLine = ShowS
removeOneLineComments ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
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
":!" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
takeLine String
remaining String -> ShowS
forall a. [a] -> [a] -> [a]
++
          Int -> Int -> ShowS
removeMultilineComments Int
nesting Int
pragmaNesting ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
remaining)

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

    takeLine :: ShowS
takeLine = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
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
xChar -> ShowS
forall 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 = [Located String] -> [Located String]
forall a. [a] -> [a]
reverse ([Located String] -> [Located String])
-> ([Located String] -> [Located String])
-> [Located String]
-> [Located String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Located String] -> [Located String]
joinQuasiquotes' ([Located String] -> [Located String])
-> ([Located String] -> [Located String])
-> [Located String]
-> [Located String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Located String] -> [Located String]
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
"|]" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` Located String -> String
forall a. Located a -> a
unloc Located String
block
      then
        let ([Located String]
pieces, [Located String]
rest) = (Located String -> Bool)
-> [Located String] -> ([Located String], [Located String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String -> Bool
hasQuasiquoteStart (String -> Bool)
-> (Located String -> String) -> Located String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located String -> String
forall a. Located a -> a
unloc) [Located String]
blocks
        in case [Located String]
rest of
          [] -> Located String
block Located String -> [Located String] -> [Located String]
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 Located String -> [Located String] -> [Located String]
forall a. a -> [a] -> [a]
: [Located String]
pieces [Located String] -> [Located String] -> [Located String]
forall a. [a] -> [a] -> [a]
++ [Located String
startBlock]) Located String -> [Located String] -> [Located String]
forall a. a -> [a] -> [a]
: [Located String] -> [Located String]
joinQuasiquotes [Located String]
blocks'
      else Located String
block Located String -> [Located String] -> [Located String]
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 = Int -> String -> Located String
forall a. Int -> a -> Located a
Located (Located String -> Int
forall a. Located a -> Int
line (Located String -> Int) -> Located String -> Int
forall a b. (a -> b) -> a -> b
$ [Located String] -> Located String
forall a. HasCallStack => [a] -> a
last [Located String]
blocks) (String -> Located String) -> String -> Located String
forall a b. (a -> b) -> a -> b
$ [String] -> String
joinLines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Located String -> String) -> [Located String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> String
forall a. Located a -> a
unloc ([Located String] -> [String]) -> [Located String] -> [String]
forall a b. (a -> b) -> a -> b
$ [Located String] -> [Located String]
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 (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'[') String
str of
        (String
_, String
"") -> Bool
False
        (String
_, Char
_:String
rest) ->
          case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'|') String
rest of
            (String
_, String
"") -> Bool
False
            (String
chars, String
_) -> (Char -> Bool) -> String -> Bool
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''