{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings #-}

module IHaskell.Eval.Parser (
    parseString,
    CodeBlock(..),
    StringLoc(..),
    DirectiveType(..),
    LineNumber,
    ColumnNumber,
    ErrMsg,
    layoutChunks,
    parseDirective,
    getModuleName,
    Located(..),
    PragmaType(..),
    ) where

import           IHaskellPrelude

import           Control.Monad.Trans.State
import           Data.Char (toLower)
import           Data.List (maximumBy, inits)
import           Prelude (head, tail)

import           GHC hiding (Located, Parsed)

import           Language.Haskell.GHC.Parser
import           IHaskell.Eval.Util
import           StringUtils (strip, split)

-- | A block of code to be evaluated. Each block contains a single element - one declaration,
-- statement, expression, etc. If parsing of the block failed, the block is instead a ParseError,
-- which has the error location and error message.
data CodeBlock = Expression String              -- ^ A Haskell expression.
               | Declaration String             -- ^ A data type or function declaration.
               | Statement String               -- ^ A Haskell statement (as if in a `do` block).
               | Import String                  -- ^ An import statement.
               | TypeSignature String           -- ^ A lonely type signature (not above a function
                                                -- declaration).
               | Directive DirectiveType String -- ^ An IHaskell directive.
               | Module String                  -- ^ A full Haskell module, to be compiled and loaded.
               | ParseError StringLoc ErrMsg    -- ^ An error indicating that parsing the code block
                                                -- failed.
               | Pragma PragmaType [String]     -- ^ A list of GHC pragmas (from a {-# LANGUAGE ... #-}
                                                -- block)
  deriving (LineNumber -> CodeBlock -> ShowS
[CodeBlock] -> ShowS
CodeBlock -> [Char]
(LineNumber -> CodeBlock -> ShowS)
-> (CodeBlock -> [Char])
-> ([CodeBlock] -> ShowS)
-> Show CodeBlock
forall a.
(LineNumber -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: LineNumber -> CodeBlock -> ShowS
showsPrec :: LineNumber -> CodeBlock -> ShowS
$cshow :: CodeBlock -> [Char]
show :: CodeBlock -> [Char]
$cshowList :: [CodeBlock] -> ShowS
showList :: [CodeBlock] -> ShowS
Show, CodeBlock -> CodeBlock -> Bool
(CodeBlock -> CodeBlock -> Bool)
-> (CodeBlock -> CodeBlock -> Bool) -> Eq CodeBlock
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CodeBlock -> CodeBlock -> Bool
== :: CodeBlock -> CodeBlock -> Bool
$c/= :: CodeBlock -> CodeBlock -> Bool
/= :: CodeBlock -> CodeBlock -> Bool
Eq)

-- | Directive types. Each directive is associated with a string in the directive code block.
data DirectiveType = GetType      -- ^ Get the type of an expression via ':type' (or unique prefixes)
                   | GetInfo      -- ^ Get info about the identifier via ':info' (or unique prefixes)
                   | SetDynFlag   -- ^ Enable or disable an extensions, packages etc. via `:set`.
                                  -- Emulates GHCi's `:set`
                   | LoadFile     -- ^ Load a Haskell module.
                   | SetOption    -- ^ Set IHaskell kernel option `:option`.
                   | SetExtension -- ^ `:extension Foo` is a shortcut for `:set -XFoo`
                   | ShellCmd     -- ^ Execute a shell command.
                   | GetHelp      -- ^ General help via ':?' or ':help'.
                   | SearchHoogle -- ^ Search for something via Hoogle.
                   | GetDoc       -- ^ Get documentation for an identifier via Hoogle.
                   | GetKind      -- ^ Get the kind of a type via ':kind'.
                   | GetKindBang  -- ^ Get the kind and normalised type via ':kind!'.
                   | LoadModule   -- ^ Load and unload modules via ':module'.
                   | SPrint       -- ^ Print without evaluating via ':sprint'.
                   | Reload       -- ^ Reload.
  deriving (LineNumber -> DirectiveType -> ShowS
[DirectiveType] -> ShowS
DirectiveType -> [Char]
(LineNumber -> DirectiveType -> ShowS)
-> (DirectiveType -> [Char])
-> ([DirectiveType] -> ShowS)
-> Show DirectiveType
forall a.
(LineNumber -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: LineNumber -> DirectiveType -> ShowS
showsPrec :: LineNumber -> DirectiveType -> ShowS
$cshow :: DirectiveType -> [Char]
show :: DirectiveType -> [Char]
$cshowList :: [DirectiveType] -> ShowS
showList :: [DirectiveType] -> ShowS
Show, DirectiveType -> DirectiveType -> Bool
(DirectiveType -> DirectiveType -> Bool)
-> (DirectiveType -> DirectiveType -> Bool) -> Eq DirectiveType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DirectiveType -> DirectiveType -> Bool
== :: DirectiveType -> DirectiveType -> Bool
$c/= :: DirectiveType -> DirectiveType -> Bool
/= :: DirectiveType -> DirectiveType -> Bool
Eq)

-- | Pragma types. Only LANGUAGE pragmas are currently supported. Other pragma types are kept around
-- as a string for error reporting.
data PragmaType = PragmaLanguage
                | PragmaUnsupported String
  deriving (LineNumber -> PragmaType -> ShowS
[PragmaType] -> ShowS
PragmaType -> [Char]
(LineNumber -> PragmaType -> ShowS)
-> (PragmaType -> [Char])
-> ([PragmaType] -> ShowS)
-> Show PragmaType
forall a.
(LineNumber -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: LineNumber -> PragmaType -> ShowS
showsPrec :: LineNumber -> PragmaType -> ShowS
$cshow :: PragmaType -> [Char]
show :: PragmaType -> [Char]
$cshowList :: [PragmaType] -> ShowS
showList :: [PragmaType] -> ShowS
Show, PragmaType -> PragmaType -> Bool
(PragmaType -> PragmaType -> Bool)
-> (PragmaType -> PragmaType -> Bool) -> Eq PragmaType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PragmaType -> PragmaType -> Bool
== :: PragmaType -> PragmaType -> Bool
$c/= :: PragmaType -> PragmaType -> Bool
/= :: PragmaType -> PragmaType -> Bool
Eq)

-- | Parse a string into code blocks.
parseString :: String -> StateT DynFlags IO [Located CodeBlock]
parseString :: [Char] -> StateT DynFlags IO [Located CodeBlock]
parseString [Char]
codeString = do
  -- Try to parse this as a single module.
  DynFlags
flags' <- StateT DynFlags IO DynFlags
forall (m :: * -> *) s. Monad m => StateT s m s
get
  DynFlags
flags <- do
    Maybe DynFlags
result <- IO (Maybe DynFlags) -> StateT DynFlags IO (Maybe DynFlags)
forall a. IO a -> StateT DynFlags IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe DynFlags) -> StateT DynFlags IO (Maybe DynFlags))
-> IO (Maybe DynFlags) -> StateT DynFlags IO (Maybe DynFlags)
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Char] -> [Char] -> IO (Maybe DynFlags)
parsePragmasIntoDynFlags DynFlags
flags' [Char]
"<interactive>" [Char]
codeString
    DynFlags -> StateT DynFlags IO DynFlags
forall a. a -> StateT DynFlags IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> StateT DynFlags IO DynFlags)
-> DynFlags -> StateT DynFlags IO DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe DynFlags -> DynFlags
forall a. a -> Maybe a -> a
fromMaybe DynFlags
flags' Maybe DynFlags
result
  DynFlags -> StateT DynFlags IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put DynFlags
flags
  case DynFlags
-> Parser (Located (HsModule GhcPs))
-> [Char]
-> ParseOutput (Located (HsModule GhcPs))
forall a. DynFlags -> Parser a -> [Char] -> ParseOutput a
runParser DynFlags
flags Parser (Located (HsModule GhcPs))
parserModule [Char]
codeString of
    Parsed Located (HsModule GhcPs)
mdl
      | Just XRec GhcPs ModuleName
_ <- HsModule GhcPs -> Maybe (XRec GhcPs ModuleName)
forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodName (Located (HsModule GhcPs) -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc Located (HsModule GhcPs)
mdl) -> [Located CodeBlock] -> StateT DynFlags IO [Located CodeBlock]
forall a. a -> StateT DynFlags IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [LineNumber -> CodeBlock -> Located CodeBlock
forall a. LineNumber -> a -> Located a
Located LineNumber
1 (CodeBlock -> Located CodeBlock) -> CodeBlock -> Located CodeBlock
forall a b. (a -> b) -> a -> b
$ [Char] -> CodeBlock
Module [Char]
codeString]
    ParseOutput (Located (HsModule GhcPs))
_ -> do
      -- Split input into chunks based on indentation.
      let chunks :: [Located [Char]]
chunks = [Char] -> [Located [Char]]
layoutChunks ([Char] -> [Located [Char]]) -> [Char] -> [Located [Char]]
forall a b. (a -> b) -> a -> b
$ ShowS
removeComments [Char]
codeString
      [Located CodeBlock]
result <- [Located CodeBlock] -> [Located CodeBlock]
joinFunctions ([Located CodeBlock] -> [Located CodeBlock])
-> StateT DynFlags IO [Located CodeBlock]
-> StateT DynFlags IO [Located CodeBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Located CodeBlock]
-> [Located [Char]] -> StateT DynFlags IO [Located CodeBlock]
processChunks [] [Located [Char]]
chunks

      -- Return to previous flags. When parsing, flags can be set to make sure parsing works properly. But
      -- we don't want those flags to be set during evaluation until the right time.
      DynFlags -> StateT DynFlags IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put DynFlags
flags
      [Located CodeBlock] -> StateT DynFlags IO [Located CodeBlock]
forall a. a -> StateT DynFlags IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Located CodeBlock]
result

  where
    parseChunk :: String -> LineNumber -> StateT DynFlags IO (Located CodeBlock)
    parseChunk :: [Char] -> LineNumber -> StateT DynFlags IO (Located CodeBlock)
parseChunk [Char]
chunk LineNumber
ln = LineNumber -> CodeBlock -> Located CodeBlock
forall a. LineNumber -> a -> Located a
Located LineNumber
ln (CodeBlock -> Located CodeBlock)
-> StateT DynFlags IO CodeBlock
-> StateT DynFlags IO (Located CodeBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT DynFlags IO CodeBlock
handleChunk
      where
        handleChunk :: StateT DynFlags IO CodeBlock
handleChunk
          | [Char] -> Bool
isDirective [Char]
chunk = CodeBlock -> StateT DynFlags IO CodeBlock
forall a. a -> StateT DynFlags IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CodeBlock -> StateT DynFlags IO CodeBlock)
-> CodeBlock -> StateT DynFlags IO CodeBlock
forall a b. (a -> b) -> a -> b
$ [Char] -> LineNumber -> CodeBlock
parseDirective [Char]
chunk LineNumber
ln
          | [Char] -> Bool
isPragma [Char]
chunk = CodeBlock -> StateT DynFlags IO CodeBlock
forall a. a -> StateT DynFlags IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CodeBlock -> StateT DynFlags IO CodeBlock)
-> CodeBlock -> StateT DynFlags IO CodeBlock
forall a b. (a -> b) -> a -> b
$ [Char] -> LineNumber -> CodeBlock
parsePragma [Char]
chunk LineNumber
ln
          | Bool
otherwise = [Char] -> LineNumber -> StateT DynFlags IO CodeBlock
parseCodeChunk [Char]
chunk LineNumber
ln

    processChunks :: [Located CodeBlock] -> [Located String] -> StateT DynFlags IO [Located CodeBlock]
    processChunks :: [Located CodeBlock]
-> [Located [Char]] -> StateT DynFlags IO [Located CodeBlock]
processChunks [Located CodeBlock]
accum [Located [Char]]
remaining =
      case [Located [Char]]
remaining of
        -- If we have no more remaining lines, return the accumulated results.
        [] -> [Located CodeBlock] -> StateT DynFlags IO [Located CodeBlock]
forall a. a -> StateT DynFlags IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Located CodeBlock] -> StateT DynFlags IO [Located CodeBlock])
-> [Located CodeBlock] -> StateT DynFlags IO [Located CodeBlock]
forall a b. (a -> b) -> a -> b
$ [Located CodeBlock] -> [Located CodeBlock]
forall a. [a] -> [a]
reverse [Located CodeBlock]
accum

        -- If we have more remaining, parse the current chunk and recurse.
        Located LineNumber
ln [Char]
chunk:[Located [Char]]
remain -> do
          Located CodeBlock
block <- [Char] -> LineNumber -> StateT DynFlags IO (Located CodeBlock)
parseChunk [Char]
chunk LineNumber
ln
          CodeBlock -> StateT DynFlags IO ()
activateExtensions (CodeBlock -> StateT DynFlags IO ())
-> CodeBlock -> StateT DynFlags IO ()
forall a b. (a -> b) -> a -> b
$ Located CodeBlock -> CodeBlock
forall a. Located a -> a
unloc Located CodeBlock
block
          [Located CodeBlock]
-> [Located [Char]] -> StateT DynFlags IO [Located CodeBlock]
processChunks (Located CodeBlock
block Located CodeBlock -> [Located CodeBlock] -> [Located CodeBlock]
forall a. a -> [a] -> [a]
: [Located CodeBlock]
accum) [Located [Char]]
remain

    -- Test whether a given chunk is a directive.
    isDirective :: String -> Bool
    isDirective :: [Char] -> Bool
isDirective = [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
":" ([Char] -> Bool) -> ShowS -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
strip

    -- Test if a chunk is a pragma.
    isPragma :: String -> Bool
    isPragma :: [Char] -> Bool
isPragma = [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
"{-#" ([Char] -> Bool) -> ShowS -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
strip

activateExtensions :: CodeBlock -> StateT DynFlags IO ()
activateExtensions :: CodeBlock -> StateT DynFlags IO ()
activateExtensions (Directive DirectiveType
SetExtension [Char]
ext) = StateT DynFlags IO (Maybe [Char]) -> StateT DynFlags IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT DynFlags IO (Maybe [Char]) -> StateT DynFlags IO ())
-> StateT DynFlags IO (Maybe [Char]) -> StateT DynFlags IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> StateT DynFlags IO (Maybe [Char])
setExtension [Char]
ext
activateExtensions (Directive DirectiveType
SetDynFlag [Char]
flags) =
  case [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"-X" [Char]
flags of
    Just [Char]
ext -> StateT DynFlags IO (Maybe [Char]) -> StateT DynFlags IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT DynFlags IO (Maybe [Char]) -> StateT DynFlags IO ())
-> StateT DynFlags IO (Maybe [Char]) -> StateT DynFlags IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> StateT DynFlags IO (Maybe [Char])
setExtension [Char]
ext
    Maybe [Char]
Nothing  -> () -> StateT DynFlags IO ()
forall a. a -> StateT DynFlags IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
activateExtensions (Pragma PragmaType
PragmaLanguage [[Char]]
exts) = StateT DynFlags IO (Maybe [Char]) -> StateT DynFlags IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT DynFlags IO (Maybe [Char]) -> StateT DynFlags IO ())
-> StateT DynFlags IO (Maybe [Char]) -> StateT DynFlags IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> StateT DynFlags IO (Maybe [Char])
setAll [[Char]]
exts
  where
    setAll :: [String] -> StateT DynFlags IO (Maybe String)
    setAll :: [[Char]] -> StateT DynFlags IO (Maybe [Char])
setAll [[Char]]
exts' = do
      [Maybe [Char]]
errs <- ([Char] -> StateT DynFlags IO (Maybe [Char]))
-> [[Char]] -> StateT DynFlags IO [Maybe [Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Char] -> StateT DynFlags IO (Maybe [Char])
setExtension [[Char]]
exts'
      Maybe [Char] -> StateT DynFlags IO (Maybe [Char])
forall a. a -> StateT DynFlags IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> StateT DynFlags IO (Maybe [Char]))
-> Maybe [Char] -> StateT DynFlags IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Maybe [Char]] -> Maybe [Char]
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [Maybe [Char]]
errs
activateExtensions CodeBlock
_ = () -> StateT DynFlags IO ()
forall a. a -> StateT DynFlags IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Parse a single chunk of code, as indicated by the layout of the code.
parseCodeChunk :: String -> LineNumber -> StateT DynFlags IO CodeBlock
parseCodeChunk :: [Char] -> LineNumber -> StateT DynFlags IO CodeBlock
parseCodeChunk [Char]
code LineNumber
startLine = do
  DynFlags
flags <- StateT DynFlags IO DynFlags
forall (m :: * -> *) s. Monad m => StateT s m s
get
  let
      -- Try each parser in turn.
      rawResults :: [ParseOutput CodeBlock]
rawResults = (([Char] -> CodeBlock, [Char] -> ParseOutput [Char])
 -> ParseOutput CodeBlock)
-> [([Char] -> CodeBlock, [Char] -> ParseOutput [Char])]
-> [ParseOutput CodeBlock]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
-> ([Char] -> CodeBlock, [Char] -> ParseOutput [Char])
-> ParseOutput CodeBlock
tryParser [Char]
code) (DynFlags -> [([Char] -> CodeBlock, [Char] -> ParseOutput [Char])]
parsers DynFlags
flags)

      -- Convert statements into expressions where we can
      results :: [ParseOutput CodeBlock]
results = (ParseOutput CodeBlock -> ParseOutput CodeBlock)
-> [ParseOutput CodeBlock] -> [ParseOutput CodeBlock]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock
statementToExpression DynFlags
flags) [ParseOutput CodeBlock]
rawResults
  case [ParseOutput CodeBlock] -> [CodeBlock]
forall a. [ParseOutput a] -> [a]
successes [ParseOutput CodeBlock]
results of
    -- If none of them succeeded, choose the best error message to display. Only one of the error
    -- messages is actually relevant.
    [] -> CodeBlock -> StateT DynFlags IO CodeBlock
forall a. a -> StateT DynFlags IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CodeBlock -> StateT DynFlags IO CodeBlock)
-> CodeBlock -> StateT DynFlags IO CodeBlock
forall a b. (a -> b) -> a -> b
$ [([Char], LineNumber, LineNumber)] -> CodeBlock
bestError ([([Char], LineNumber, LineNumber)] -> CodeBlock)
-> [([Char], LineNumber, LineNumber)] -> CodeBlock
forall a b. (a -> b) -> a -> b
$ [ParseOutput CodeBlock] -> [([Char], LineNumber, LineNumber)]
forall a. [ParseOutput a] -> [([Char], LineNumber, LineNumber)]
failures [ParseOutput CodeBlock]
results

    -- If one of the parsers succeeded
    CodeBlock
result:[CodeBlock]
_ -> CodeBlock -> StateT DynFlags IO CodeBlock
forall a. a -> StateT DynFlags IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CodeBlock
result

  where
    successes :: [ParseOutput a] -> [a]
    successes :: forall a. [ParseOutput a] -> [a]
successes [] = []
    successes (Parsed a
a:[ParseOutput a]
rest) = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [ParseOutput a] -> [a]
forall a. [ParseOutput a] -> [a]
successes [ParseOutput a]
rest
    successes (ParseOutput a
_:[ParseOutput a]
rest) = [ParseOutput a] -> [a]
forall a. [ParseOutput a] -> [a]
successes [ParseOutput a]
rest

    failures :: [ParseOutput a] -> [(ErrMsg, LineNumber, ColumnNumber)]
    failures :: forall a. [ParseOutput a] -> [([Char], LineNumber, LineNumber)]
failures [] = []
    failures (Failure [Char]
msg (Loc LineNumber
ln LineNumber
col):[ParseOutput a]
rest) = ([Char]
msg, LineNumber
ln, LineNumber
col) ([Char], LineNumber, LineNumber)
-> [([Char], LineNumber, LineNumber)]
-> [([Char], LineNumber, LineNumber)]
forall a. a -> [a] -> [a]
: [ParseOutput a] -> [([Char], LineNumber, LineNumber)]
forall a. [ParseOutput a] -> [([Char], LineNumber, LineNumber)]
failures [ParseOutput a]
rest
    failures (ParseOutput a
_:[ParseOutput a]
rest) = [ParseOutput a] -> [([Char], LineNumber, LineNumber)]
forall a. [ParseOutput a] -> [([Char], LineNumber, LineNumber)]
failures [ParseOutput a]
rest

    bestError :: [(ErrMsg, LineNumber, ColumnNumber)] -> CodeBlock
    bestError :: [([Char], LineNumber, LineNumber)] -> CodeBlock
bestError [([Char], LineNumber, LineNumber)]
errors = StringLoc -> [Char] -> CodeBlock
ParseError (LineNumber -> LineNumber -> StringLoc
Loc (LineNumber
ln LineNumber -> LineNumber -> LineNumber
forall a. Num a => a -> a -> a
+ LineNumber
startLine LineNumber -> LineNumber -> LineNumber
forall a. Num a => a -> a -> a
- LineNumber
1) LineNumber
col) [Char]
msg
      where
        ([Char]
msg, LineNumber
ln, LineNumber
col) = (([Char], LineNumber, LineNumber)
 -> ([Char], LineNumber, LineNumber) -> Ordering)
-> [([Char], LineNumber, LineNumber)]
-> ([Char], LineNumber, LineNumber)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ([Char], LineNumber, LineNumber)
-> ([Char], LineNumber, LineNumber) -> Ordering
forall {a} {a} {a} {a}.
(Ord a, Ord a) =>
(a, a, a) -> (a, a, a) -> Ordering
compareLoc [([Char], LineNumber, LineNumber)]
errors
        compareLoc :: (a, a, a) -> (a, a, a) -> Ordering
compareLoc (a
_, a
line1, a
col1) (a
_, a
line2, a
col2) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
line1 a
line2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
col1 a
col2

    statementToExpression :: DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock
    statementToExpression :: DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock
statementToExpression DynFlags
flags (Parsed (Statement [Char]
stmt)) = CodeBlock -> ParseOutput CodeBlock
forall a. a -> ParseOutput a
Parsed CodeBlock
result
      where
        result :: CodeBlock
result = if DynFlags -> [Char] -> Bool
isExpr DynFlags
flags [Char]
stmt
                   then [Char] -> CodeBlock
Expression [Char]
stmt
                   else [Char] -> CodeBlock
Statement [Char]
stmt
    statementToExpression DynFlags
_ ParseOutput CodeBlock
other = ParseOutput CodeBlock
other

    -- Check whether a string is a valid expression.
    isExpr :: DynFlags -> String -> Bool
    isExpr :: DynFlags -> [Char] -> Bool
isExpr DynFlags
flags [Char]
str =
      case DynFlags
-> Parser (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [Char]
-> ParseOutput (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. DynFlags -> Parser a -> [Char] -> ParseOutput a
runParser DynFlags
flags Parser (LHsExpr GhcPs)
Parser (GenLocated SrcSpanAnnA (HsExpr GhcPs))
parserExpression [Char]
str of
        Parsed{} -> Bool
True
        ParseOutput (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_        -> Bool
False

    tryParser :: String -> (String -> CodeBlock, String -> ParseOutput String) -> ParseOutput CodeBlock
    tryParser :: [Char]
-> ([Char] -> CodeBlock, [Char] -> ParseOutput [Char])
-> ParseOutput CodeBlock
tryParser [Char]
string ([Char] -> CodeBlock
blockType, [Char] -> ParseOutput [Char]
psr) =
      case [Char] -> ParseOutput [Char]
psr [Char]
string of
        Parsed [Char]
res      -> CodeBlock -> ParseOutput CodeBlock
forall a. a -> ParseOutput a
Parsed ([Char] -> CodeBlock
blockType [Char]
res)
        Failure [Char]
err StringLoc
loc -> [Char] -> StringLoc -> ParseOutput CodeBlock
forall a. [Char] -> StringLoc -> ParseOutput a
Failure [Char]
err StringLoc
loc
        ParseOutput [Char]
_               -> [Char] -> ParseOutput CodeBlock
forall a. HasCallStack => [Char] -> a
error [Char]
"tryParser failed, output was neither Parsed nor Failure"

    parsers :: DynFlags -> [(String -> CodeBlock, String -> ParseOutput String)]
    parsers :: DynFlags -> [([Char] -> CodeBlock, [Char] -> ParseOutput [Char])]
parsers DynFlags
flags =
      [ ([Char] -> CodeBlock
Import, Parser (GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> [Char] -> ParseOutput [Char]
forall a. Parser a -> [Char] -> ParseOutput [Char]
unparser Parser (LImportDecl GhcPs)
Parser (GenLocated SrcSpanAnnA (ImportDecl GhcPs))
parserImport)
      , ([Char] -> CodeBlock
TypeSignature, Parser (Located (OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> [Char] -> ParseOutput [Char]
forall a. Parser a -> [Char] -> ParseOutput [Char]
unparser Parser (Located (OrdList (LHsDecl GhcPs)))
Parser (Located (OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
parserTypeSignature)
      , ([Char] -> CodeBlock
Statement, Parser
  (Maybe
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [Char] -> ParseOutput [Char]
forall a. Parser a -> [Char] -> ParseOutput [Char]
unparser Parser (Maybe (LStmt GhcPs (LHsExpr GhcPs)))
Parser
  (Maybe
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
parserStatement)
      , ([Char] -> CodeBlock
Declaration, Parser (OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> [Char] -> ParseOutput [Char]
forall a. Parser a -> [Char] -> ParseOutput [Char]
unparser Parser (OrdList (LHsDecl GhcPs))
Parser (OrdList (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
parserDeclaration)
      ]
      where
        unparser :: Parser a -> String -> ParseOutput String
        unparser :: forall a. Parser a -> [Char] -> ParseOutput [Char]
unparser Parser a
psr [Char]
cd =
          case DynFlags -> Parser a -> [Char] -> ParseOutput a
forall a. DynFlags -> Parser a -> [Char] -> ParseOutput a
runParser DynFlags
flags Parser a
psr [Char]
cd of
            Parsed a
_         -> [Char] -> ParseOutput [Char]
forall a. a -> ParseOutput a
Parsed [Char]
cd
            Partial a
_ ([Char], [Char])
strs   -> [Char] -> ([Char], [Char]) -> ParseOutput [Char]
forall a. a -> ([Char], [Char]) -> ParseOutput a
Partial [Char]
cd ([Char], [Char])
strs
            Failure [Char]
err StringLoc
loc  -> [Char] -> StringLoc -> ParseOutput [Char]
forall a. [Char] -> StringLoc -> ParseOutput a
Failure [Char]
err StringLoc
loc

-- | Find consecutive declarations of the same function and join them into a single declaration.
-- These declarations may also include a type signature, which is also joined with the subsequent
-- declarations.
joinFunctions :: [Located CodeBlock] -> [Located CodeBlock]
joinFunctions :: [Located CodeBlock] -> [Located CodeBlock]
joinFunctions [] = []
joinFunctions [Located CodeBlock]
blocks =
  if CodeBlock -> Bool
signatureOrDecl (CodeBlock -> Bool) -> CodeBlock -> Bool
forall a b. (a -> b) -> a -> b
$ Located CodeBlock -> CodeBlock
forall a. Located a -> a
unloc (Located CodeBlock -> CodeBlock) -> Located CodeBlock -> CodeBlock
forall a b. (a -> b) -> a -> b
$ [Located CodeBlock] -> Located CodeBlock
forall a. HasCallStack => [a] -> a
head [Located CodeBlock]
blocks
    then LineNumber -> CodeBlock -> Located CodeBlock
forall a. LineNumber -> a -> Located a
Located LineNumber
lnum ([CodeBlock] -> CodeBlock
conjoin ([CodeBlock] -> CodeBlock) -> [CodeBlock] -> CodeBlock
forall a b. (a -> b) -> a -> b
$ (Located CodeBlock -> CodeBlock)
-> [Located CodeBlock] -> [CodeBlock]
forall a b. (a -> b) -> [a] -> [b]
map Located CodeBlock -> CodeBlock
forall a. Located a -> a
unloc [Located CodeBlock]
decls) Located CodeBlock -> [Located CodeBlock] -> [Located CodeBlock]
forall a. a -> [a] -> [a]
: [Located CodeBlock] -> [Located CodeBlock]
joinFunctions [Located CodeBlock]
rest
    else [Located CodeBlock] -> Located CodeBlock
forall a. HasCallStack => [a] -> a
head [Located CodeBlock]
blocks Located CodeBlock -> [Located CodeBlock] -> [Located CodeBlock]
forall a. a -> [a] -> [a]
: [Located CodeBlock] -> [Located CodeBlock]
joinFunctions ([Located CodeBlock] -> [Located CodeBlock]
forall a. HasCallStack => [a] -> [a]
tail [Located CodeBlock]
blocks)
  where
    decls :: [Located CodeBlock]
decls = (Located CodeBlock -> Bool)
-> [Located CodeBlock] -> [Located CodeBlock]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (CodeBlock -> Bool
signatureOrDecl (CodeBlock -> Bool)
-> (Located CodeBlock -> CodeBlock) -> Located CodeBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located CodeBlock -> CodeBlock
forall a. Located a -> a
unloc) [Located CodeBlock]
blocks
    rest :: [Located CodeBlock]
rest = LineNumber -> [Located CodeBlock] -> [Located CodeBlock]
forall a. LineNumber -> [a] -> [a]
drop ([Located CodeBlock] -> LineNumber
forall a. [a] -> LineNumber
forall (t :: * -> *) a. Foldable t => t a -> LineNumber
length [Located CodeBlock]
decls) [Located CodeBlock]
blocks
    lnum :: LineNumber
lnum = Located CodeBlock -> LineNumber
forall a. Located a -> LineNumber
line (Located CodeBlock -> LineNumber)
-> Located CodeBlock -> LineNumber
forall a b. (a -> b) -> a -> b
$ [Located CodeBlock] -> Located CodeBlock
forall a. HasCallStack => [a] -> a
head [Located CodeBlock]
decls

    signatureOrDecl :: CodeBlock -> Bool
signatureOrDecl (Declaration [Char]
_) = Bool
True
    signatureOrDecl (TypeSignature [Char]
_) = Bool
True
    signatureOrDecl CodeBlock
_ = Bool
False

    str :: CodeBlock -> [Char]
str (Declaration [Char]
s) = [Char]
s
    str (TypeSignature [Char]
s) = [Char]
s
    str CodeBlock
_ = ShowS
forall a. HasCallStack => [Char] -> a
error [Char]
"Expected declaration or signature"

    conjoin :: [CodeBlock] -> CodeBlock
    conjoin :: [CodeBlock] -> CodeBlock
conjoin = [Char] -> CodeBlock
Declaration ([Char] -> CodeBlock)
-> ([CodeBlock] -> [Char]) -> [CodeBlock] -> CodeBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char])
-> ([CodeBlock] -> [[Char]]) -> [CodeBlock] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CodeBlock -> [Char]) -> [CodeBlock] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map CodeBlock -> [Char]
str

-- | Parse a pragma of the form {-# LANGUAGE ... #-}
parsePragma :: String       -- ^ Pragma string.
            -> Int          -- ^ Line number at which the directive appears.
            -> CodeBlock    -- ^ Pragma code block or a parse error.
parsePragma :: [Char] -> LineNumber -> CodeBlock
parsePragma [Char]
pragma LineNumber
_ln =
  let commaToSpace :: Char -> Char
      commaToSpace :: Char -> Char
commaToSpace Char
',' = Char
' '
      commaToSpace Char
x = Char
x
      pragmas :: [[Char]]
pragmas = [Char] -> [[Char]]
words ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
commaToSpace ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ LineNumber -> ShowS
forall a. LineNumber -> [a] -> [a]
drop LineNumber
3 [Char]
pragma
  in case [[Char]]
pragmas of
    --empty string pragmas are unsupported
    [] -> PragmaType -> [[Char]] -> CodeBlock
Pragma ([Char] -> PragmaType
PragmaUnsupported [Char]
"") []
    [Char]
x:[[Char]]
xs
      | (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
x [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"language"
      -> PragmaType -> [[Char]] -> CodeBlock
Pragma PragmaType
PragmaLanguage [[Char]]
xs
    [Char]
x:[[Char]]
xs -> PragmaType -> [[Char]] -> CodeBlock
Pragma ([Char] -> PragmaType
PragmaUnsupported [Char]
x) [[Char]]
xs

-- | Parse a directive of the form :directiveName.
parseDirective :: String       -- ^ Directive string.
               -> Int          -- ^ Line number at which the directive appears.
               -> CodeBlock    -- ^ Directive code block or a parse error.
parseDirective :: [Char] -> LineNumber -> CodeBlock
parseDirective (Char
':':Char
'!':[Char]
directive) LineNumber
_ln = DirectiveType -> [Char] -> CodeBlock
Directive DirectiveType
ShellCmd ([Char] -> CodeBlock) -> [Char] -> CodeBlock
forall a b. (a -> b) -> a -> b
$ Char
'!' Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
directive
parseDirective (Char
':':[Char]
directive) LineNumber
ln =
  case ((DirectiveType, [Char]) -> Bool)
-> [(DirectiveType, [Char])] -> Maybe (DirectiveType, [Char])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (DirectiveType, [Char]) -> Bool
forall {a}. (a, [Char]) -> Bool
rightDirective [(DirectiveType, [Char])]
directives of
    Just (DirectiveType
directiveType, [Char]
_) -> DirectiveType -> [Char] -> CodeBlock
Directive DirectiveType
directiveType [Char]
arg
      where arg :: [Char]
arg = [[Char]] -> [Char]
unwords [[Char]]
restLine
            [Char]
_:[[Char]]
restLine = [Char] -> [[Char]]
words [Char]
directive
    Maybe (DirectiveType, [Char])
Nothing ->
      let directiveStart :: [Char]
directiveStart =
                            case [Char] -> [[Char]]
words [Char]
directive of
                              []      -> [Char]
""
                              [Char]
first:[[Char]]
_ -> [Char]
first
      in StringLoc -> [Char] -> CodeBlock
ParseError (LineNumber -> LineNumber -> StringLoc
Loc LineNumber
ln LineNumber
1) ([Char] -> CodeBlock) -> [Char] -> CodeBlock
forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown directive: '" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
directiveStart [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"'."
  where
    rightDirective :: (a, [Char]) -> Bool
rightDirective (a
_, [Char]
dirname) =
      case [Char] -> [[Char]]
words [Char]
directive of
        []    -> Bool
False
        [Char]
dir:[[Char]]
_ -> [Char]
dir [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]] -> [[Char]]
forall a. HasCallStack => [a] -> [a]
tail ([Char] -> [[Char]]
forall a. [a] -> [[a]]
inits [Char]
dirname)
    directives :: [(DirectiveType, [Char])]
directives =
      [ (DirectiveType
LoadModule, [Char]
"module")
      , (DirectiveType
GetType, [Char]
"type")
      , (DirectiveType
GetKind, [Char]
"kind")
      , (DirectiveType
GetKindBang, [Char]
"kind!")
      , (DirectiveType
GetInfo, [Char]
"info")
      , (DirectiveType
SearchHoogle, [Char]
"hoogle")
      , (DirectiveType
GetDoc, [Char]
"documentation")
      , (DirectiveType
SetDynFlag, [Char]
"set")
      , (DirectiveType
LoadFile, [Char]
"load")
      , (DirectiveType
SetOption, [Char]
"option")
      , (DirectiveType
SetExtension, [Char]
"extension")
      , (DirectiveType
GetHelp, [Char]
"?")
      , (DirectiveType
GetHelp, [Char]
"help")
      , (DirectiveType
Reload, [Char]
"reload")
      , (DirectiveType
SPrint, [Char]
"sprint")
      ]
parseDirective [Char]
_ LineNumber
_ = [Char] -> CodeBlock
forall a. HasCallStack => [Char] -> a
error [Char]
"Directive must start with colon!"

-- | Parse a module and return the name declared in the 'module X where' line. That line is
-- required, and if it does not exist, this will error. Names with periods in them are returned
-- piece by piece.
getModuleName :: GhcMonad m => String -> m [String]
getModuleName :: forall (m :: * -> *). GhcMonad m => [Char] -> m [[Char]]
getModuleName [Char]
moduleSrc = do
  DynFlags
flags' <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  DynFlags
flags <- do
    Maybe DynFlags
result <- IO (Maybe DynFlags) -> m (Maybe DynFlags)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe DynFlags) -> m (Maybe DynFlags))
-> IO (Maybe DynFlags) -> m (Maybe DynFlags)
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Char] -> [Char] -> IO (Maybe DynFlags)
parsePragmasIntoDynFlags DynFlags
flags' [Char]
"<interactive>" [Char]
moduleSrc
    DynFlags -> m DynFlags
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> m DynFlags) -> DynFlags -> m DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe DynFlags -> DynFlags
forall a. a -> Maybe a -> a
fromMaybe DynFlags
flags' Maybe DynFlags
result
  ()
_ <- DynFlags -> m ()
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
setSessionDynFlags DynFlags
flags
  let output :: ParseOutput (Located (HsModule GhcPs))
output = DynFlags
-> Parser (Located (HsModule GhcPs))
-> [Char]
-> ParseOutput (Located (HsModule GhcPs))
forall a. DynFlags -> Parser a -> [Char] -> ParseOutput a
runParser DynFlags
flags Parser (Located (HsModule GhcPs))
parserModule [Char]
moduleSrc
  case ParseOutput (Located (HsModule GhcPs))
output of
    Failure{} -> [Char] -> m [[Char]]
forall a. HasCallStack => [Char] -> a
error [Char]
"Module parsing failed."
    Parsed Located (HsModule GhcPs)
mdl ->
      case GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> Maybe (GenLocated SrcSpanAnnA ModuleName) -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsModule GhcPs -> Maybe (XRec GhcPs ModuleName)
forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodName (Located (HsModule GhcPs) -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc Located (HsModule GhcPs)
mdl) of
        Maybe ModuleName
Nothing   -> [Char] -> m [[Char]]
forall a. HasCallStack => [Char] -> a
error [Char]
"Module must have a name."
        Just ModuleName
name -> [[Char]] -> m [[Char]]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]] -> m [[Char]]) -> [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [[Char]]
split [Char]
"." ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ModuleName -> [Char]
moduleNameString ModuleName
name
    ParseOutput (Located (HsModule GhcPs))
_ -> [Char] -> m [[Char]]
forall a. HasCallStack => [Char] -> a
error [Char]
"getModuleName failed, output was neither Parsed nor Failure"