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

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

import           IHaskellPrelude

import           Data.Char (toLower)
import           Data.List (maximumBy, inits)
import           Prelude (head, tail)

#if MIN_VERSION_ghc(8,4,0)
import           GHC hiding (Located, Parsed)
#else
import           GHC hiding (Located)
#endif

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 (Int -> CodeBlock -> ShowS
[CodeBlock] -> ShowS
CodeBlock -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CodeBlock] -> ShowS
$cshowList :: [CodeBlock] -> ShowS
show :: CodeBlock -> [Char]
$cshow :: CodeBlock -> [Char]
showsPrec :: Int -> CodeBlock -> ShowS
$cshowsPrec :: Int -> CodeBlock -> ShowS
Show, CodeBlock -> CodeBlock -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CodeBlock -> CodeBlock -> Bool
$c/= :: CodeBlock -> CodeBlock -> Bool
== :: CodeBlock -> CodeBlock -> Bool
$c== :: 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 (Int -> DirectiveType -> ShowS
[DirectiveType] -> ShowS
DirectiveType -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [DirectiveType] -> ShowS
$cshowList :: [DirectiveType] -> ShowS
show :: DirectiveType -> [Char]
$cshow :: DirectiveType -> [Char]
showsPrec :: Int -> DirectiveType -> ShowS
$cshowsPrec :: Int -> DirectiveType -> ShowS
Show, DirectiveType -> DirectiveType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DirectiveType -> DirectiveType -> Bool
$c/= :: DirectiveType -> DirectiveType -> Bool
== :: DirectiveType -> DirectiveType -> Bool
$c== :: 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 (Int -> PragmaType -> ShowS
[PragmaType] -> ShowS
PragmaType -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PragmaType] -> ShowS
$cshowList :: [PragmaType] -> ShowS
show :: PragmaType -> [Char]
$cshow :: PragmaType -> [Char]
showsPrec :: Int -> PragmaType -> ShowS
$cshowsPrec :: Int -> PragmaType -> ShowS
Show, PragmaType -> PragmaType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PragmaType -> PragmaType -> Bool
$c/= :: PragmaType -> PragmaType -> Bool
== :: PragmaType -> PragmaType -> Bool
$c== :: PragmaType -> PragmaType -> Bool
Eq)

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

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

    processChunks :: GhcMonad m => [Located CodeBlock] -> [Located String] -> m [Located CodeBlock]
    processChunks :: forall (m :: * -> *).
GhcMonad m =>
[Located CodeBlock] -> [Located [Char]] -> m [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.
        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Located CodeBlock]
accum

        -- If we have more remaining, parse the current chunk and recurse.
        Located Int
ln [Char]
chunk:[Located [Char]]
remain -> do
          Located CodeBlock
block <- forall (m :: * -> *).
GhcMonad m =>
[Char] -> Int -> m (Located CodeBlock)
parseChunk [Char]
chunk Int
ln
          forall (m :: * -> *). GhcMonad m => CodeBlock -> m ()
activateExtensions forall a b. (a -> b) -> a -> b
$ forall a. Located a -> a
unloc Located CodeBlock
block
          forall (m :: * -> *).
GhcMonad m =>
[Located CodeBlock] -> [Located [Char]] -> m [Located CodeBlock]
processChunks (Located CodeBlock
block 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 = forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
":" 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 = forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
"{-#" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
strip

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

-- | Parse a single chunk of code, as indicated by the layout of the code.
parseCodeChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock
parseCodeChunk :: forall (m :: * -> *). GhcMonad m => [Char] -> Int -> m CodeBlock
parseCodeChunk [Char]
code Int
startLine = do
  DynFlags
flags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  let
      -- Try each parser in turn.
      rawResults :: [ParseOutput CodeBlock]
rawResults = 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 = forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock
statementToExpression DynFlags
flags) [ParseOutput CodeBlock]
rawResults
  case 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.
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [([Char], Int, Int)] -> CodeBlock
bestError forall a b. (a -> b) -> a -> b
$ forall a. [ParseOutput a] -> [([Char], Int, Int)]
failures [ParseOutput CodeBlock]
results

    -- If one of the parsers succeeded
    CodeBlock
result:[CodeBlock]
_ -> 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 forall a. a -> [a] -> [a]
: forall a. [ParseOutput a] -> [a]
successes [ParseOutput a]
rest
    successes (ParseOutput a
_:[ParseOutput a]
rest) = forall a. [ParseOutput a] -> [a]
successes [ParseOutput a]
rest

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

    bestError :: [(ErrMsg, LineNumber, ColumnNumber)] -> CodeBlock
    bestError :: [([Char], Int, Int)] -> CodeBlock
bestError [([Char], Int, Int)]
errors = StringLoc -> [Char] -> CodeBlock
ParseError (Int -> Int -> StringLoc
Loc (Int
ln forall a. Num a => a -> a -> a
+ Int
startLine forall a. Num a => a -> a -> a
- Int
1) Int
col) [Char]
msg
      where
        ([Char]
msg, Int
ln, Int
col) = forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy forall {a} {a} {a} {a}.
(Ord a, Ord a) =>
(a, a, a) -> (a, a, a) -> Ordering
compareLoc [([Char], Int, Int)]
errors
        compareLoc :: (a, a, a) -> (a, a, a) -> Ordering
compareLoc (a
_, a
line1, a
col1) (a
_, a
line2, a
col2) = forall a. Ord a => a -> a -> Ordering
compare a
line1 a
line2 forall a. Semigroup a => a -> a -> a
<> 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)) = 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 forall a. DynFlags -> Parser a -> [Char] -> ParseOutput a
runParser DynFlags
flags Parser (LHsExpr 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      -> forall a. a -> ParseOutput a
Parsed ([Char] -> CodeBlock
blockType [Char]
res)
        Failure [Char]
err StringLoc
loc -> forall a. [Char] -> StringLoc -> ParseOutput a
Failure [Char]
err StringLoc
loc
        ParseOutput [Char]
_               -> 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, forall a. Parser a -> [Char] -> ParseOutput [Char]
unparser Parser (LImportDecl GhcPs)
parserImport)
      , ([Char] -> CodeBlock
TypeSignature, forall a. Parser a -> [Char] -> ParseOutput [Char]
unparser Parser (Located (OrdList (LHsDecl GhcPs)))
parserTypeSignature)
      , ([Char] -> CodeBlock
Statement, forall a. Parser a -> [Char] -> ParseOutput [Char]
unparser Parser (Maybe (LStmt GhcPs (LHsExpr GhcPs)))
parserStatement)
      , ([Char] -> CodeBlock
Declaration, forall a. Parser a -> [Char] -> ParseOutput [Char]
unparser Parser (OrdList (LHsDecl GhcPs))
parserDeclaration)
      ]
      where
        unparser :: Parser a -> String -> ParseOutput String
        unparser :: forall a. Parser a -> [Char] -> ParseOutput [Char]
unparser Parser a
psr [Char]
cd =
          case forall a. DynFlags -> Parser a -> [Char] -> ParseOutput a
runParser DynFlags
flags Parser a
psr [Char]
cd of
            Parsed a
_         -> forall a. a -> ParseOutput a
Parsed [Char]
cd
            Partial a
_ ([Char], [Char])
strs   -> forall a. a -> ([Char], [Char]) -> ParseOutput a
Partial [Char]
cd ([Char], [Char])
strs
            Failure [Char]
err StringLoc
loc  -> 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 forall a b. (a -> b) -> a -> b
$ forall a. Located a -> a
unloc forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [Located CodeBlock]
blocks
    then forall a. Int -> a -> Located a
Located Int
lnum ([CodeBlock] -> CodeBlock
conjoin forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a -> a
unloc [Located CodeBlock]
decls) forall a. a -> [a] -> [a]
: [Located CodeBlock] -> [Located CodeBlock]
joinFunctions [Located CodeBlock]
rest
    else forall a. [a] -> a
head [Located CodeBlock]
blocks forall a. a -> [a] -> [a]
: [Located CodeBlock] -> [Located CodeBlock]
joinFunctions (forall a. [a] -> [a]
tail [Located CodeBlock]
blocks)
  where
    decls :: [Located CodeBlock]
decls = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (CodeBlock -> Bool
signatureOrDecl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Located a -> a
unloc) [Located CodeBlock]
blocks
    rest :: [Located CodeBlock]
rest = forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Located CodeBlock]
decls) [Located CodeBlock]
blocks
    lnum :: Int
lnum = forall a. Located a -> Int
line forall a b. (a -> b) -> a -> b
$ forall a. [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
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Expected declaration or signature"

    conjoin :: [CodeBlock] -> CodeBlock
    conjoin :: [CodeBlock] -> CodeBlock
conjoin = [Char] -> CodeBlock
Declaration forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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] -> Int -> CodeBlock
parsePragma [Char]
pragma Int
_ln =
  let commaToSpace :: Char -> Char
      commaToSpace :: Char -> Char
commaToSpace Char
',' = Char
' '
      commaToSpace Char
x = Char
x
      pragmas :: [[Char]]
pragmas = [Char] -> [[Char]]
words forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'#') forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
commaToSpace forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
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
      | forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
x 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] -> Int -> CodeBlock
parseDirective (Char
':':Char
'!':[Char]
directive) Int
_ln = DirectiveType -> [Char] -> CodeBlock
Directive DirectiveType
ShellCmd forall a b. (a -> b) -> a -> b
$ Char
'!' forall a. a -> [a] -> [a]
: [Char]
directive
parseDirective (Char
':':[Char]
directive) Int
ln =
  case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find 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 (Int -> Int -> StringLoc
Loc Int
ln Int
1) forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown directive: '" forall a. [a] -> [a] -> [a]
++ [Char]
directiveStart 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a. [a] -> [a]
tail (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]
_ Int
_ = 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' <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  DynFlags
flags <- do
    Maybe DynFlags
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DynFlags -> [Char] -> [Char] -> IO (Maybe DynFlags)
parsePragmasIntoDynFlags DynFlags
flags' [Char]
"<interactive>" [Char]
moduleSrc
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe DynFlags
flags' Maybe DynFlags
result
  ()
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags DynFlags
flags
  let output :: ParseOutput (Located HsModule)
output = forall a. DynFlags -> Parser a -> [Char] -> ParseOutput a
runParser DynFlags
flags Parser (Located HsModule)
parserModule [Char]
moduleSrc
  case ParseOutput (Located HsModule)
output of
    Failure{} -> forall a. HasCallStack => [Char] -> a
error [Char]
"Module parsing failed."
    Parsed Located HsModule
mdl ->
      case forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsModule -> Maybe (LocatedA ModuleName)
hsmodName (forall l e. GenLocated l e -> e
unLoc Located HsModule
mdl) of
        Maybe ModuleName
Nothing   -> forall a. HasCallStack => [Char] -> a
error [Char]
"Module must have a name."
        Just ModuleName
name -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [[Char]]
split [Char]
"." forall a b. (a -> b) -> a -> b
$ ModuleName -> [Char]
moduleNameString ModuleName
name
    ParseOutput (Located HsModule)
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"getModuleName failed, output was neither Parsed nor Failure"