{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

{- |  This module implements parsing of additional arguments embedded in a
      comment when Stack is invoked as a script interpreter

  ===Specifying arguments in script interpreter mode
  @/stack/@ can execute a Haskell source file using @/runghc/@ and if required
  it can also install and setup the compiler and any package dependencies
  automatically.

  For using a Haskell source file as an executable script on a Unix like OS,
  the first line of the file must specify @stack@ as the interpreter using a
  shebang directive e.g.

  > #!/usr/bin/env stack

  Additional arguments can be specified in a haskell comment following the
  @#!@ line. The contents inside the comment must be a single valid stack
  command line, starting with @stack@ as the command and followed by the
  options to use for executing this file.

  The comment must be on the line immediately following the @#!@ line. The
  comment must start in the first column of the line. When using a block style
  comment the command can be split on multiple lines.

  Here is an example of a single line comment:

  > #!/usr/bin/env stack
  > -- stack --resolver lts-3.14 --install-ghc runghc --package random

  Here is an example of a multi line block comment:

@
  #!\/usr\/bin\/env stack
  {\- stack
    --resolver lts-3.14
    --install-ghc
    runghc
    --package random
  -\}
@

  When the @#!@ line is not present, the file can still be executed
  using @stack \<file name\>@ command if the file starts with a valid stack
  interpreter comment. This can be used to execute the file on Windows for
  example.

  Nested block comments are not supported.
-}
module Data.Attoparsec.Interpreter
  ( interpreterArgsParser -- for unit tests

  , getInterpreterArgs
  ) where

import           Data.Attoparsec.Args ( EscapingMode (..), argsParser )
import           Data.Attoparsec.Text ( (<?>) )
import qualified Data.Attoparsec.Text as P
import           Data.Char ( isSpace )
import           Conduit ( decodeUtf8C, withSourceFile )
import           Data.Conduit.Attoparsec ( ParseError (..), Position (..), sinkParserEither )
import           Data.List ( intercalate )
import           Data.List.NonEmpty ( singleton )
import           Data.Text ( pack )
import           RIO.NonEmpty ( nonEmpty )
import           Stack.Constants ( stackProgName )
import           Stack.Prelude
import           System.FilePath ( takeExtension )
import           System.IO ( hPutStrLn )

-- | Parser to extract the Stack command line embedded inside a comment

-- after validating the placement and formatting rules for a valid

-- interpreter specification.

interpreterArgsParser :: Bool -> String -> P.Parser String
interpreterArgsParser :: Bool -> [Char] -> Parser [Char]
interpreterArgsParser Bool
isLiterate [Char]
progName = [Char] -> Parser [Char] -> Parser [Char]
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
P.option [Char]
"" Parser [Char]
sheBangLine Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser [Char]
interpreterComment
 where
  sheBangLine :: Parser [Char]
sheBangLine =   Text -> Parser Text
P.string Text
"#!"
               Parser Text -> Parser [Char] -> Parser [Char]
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Char -> Parser Text () -> Parser [Char]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
P.manyTill Parser Text Char
P.anyChar Parser Text ()
P.endOfLine

  commentStart :: Parser Text a -> Parser Text
commentStart Parser Text a
psr =   (Parser Text a
psr Parser Text a -> [Char] -> Parser Text a
forall i a. Parser i a -> [Char] -> Parser i a
<?> ([Char]
progName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" options comment"))
                    Parser Text a -> Parser Text () -> Parser Text ()
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
P.skipSpace
                    Parser Text () -> Parser Text -> Parser Text
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Parser Text
P.string ([Char] -> Text
pack [Char]
progName) Parser Text -> [Char] -> Parser Text
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
progName)

  -- Treat newlines as spaces inside the block comment

  anyCharNormalizeSpace :: Parser Text Char
anyCharNormalizeSpace = let normalizeSpace :: Char -> Char
normalizeSpace Char
c = if Char -> Bool
isSpace Char
c then Char
' ' else Char
c
                            in  (Char -> Char) -> (Char -> Bool) -> Parser Text Char
forall a. (Char -> a) -> (a -> Bool) -> Parser a
P.satisfyWith Char -> Char
normalizeSpace ((Char -> Bool) -> Parser Text Char)
-> (Char -> Bool) -> Parser Text Char
forall a b. (a -> b) -> a -> b
$ Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True

  comment :: Parser Text a -> Parser Text b -> Parser [Char]
comment Parser Text a
start Parser Text b
end = Parser Text a -> Parser Text
forall {a}. Parser Text a -> Parser Text
commentStart Parser Text a
start
    Parser Text -> Parser [Char] -> Parser [Char]
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((Parser Text b
end Parser Text b -> Parser [Char] -> Parser [Char]
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> Parser [Char]
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"")
        Parser [Char] -> Parser [Char] -> Parser [Char]
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser Text Char
P.space Parser Text Char -> Parser [Char] -> Parser [Char]
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser Text Char -> Parser Text b -> Parser [Char]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
P.manyTill Parser Text Char
anyCharNormalizeSpace Parser Text b
end Parser [Char] -> [Char] -> Parser [Char]
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"-}")))

  horizontalSpace :: Parser Text Char
horizontalSpace = (Char -> Bool) -> Parser Text Char
P.satisfy Char -> Bool
P.isHorizontalSpace

  lineComment :: Parser [Char]
lineComment =  Parser Text -> Parser Text () -> Parser [Char]
forall {a} {b}. Parser Text a -> Parser Text b -> Parser [Char]
comment Parser Text
"--" (Parser Text ()
P.endOfLine Parser Text () -> Parser Text () -> Parser Text ()
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text ()
forall t. Chunk t => Parser t ()
P.endOfInput)
  literateLineComment :: Parser [Char]
literateLineComment = Parser Text -> Parser Text () -> Parser [Char]
forall {a} {b}. Parser Text a -> Parser Text b -> Parser [Char]
comment
    (Parser Text
">" Parser Text -> Parser Text Char -> Parser Text Char
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Char
horizontalSpace Parser Text Char -> Parser Text -> Parser Text
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
"--")
    (Parser Text ()
P.endOfLine Parser Text () -> Parser Text () -> Parser Text ()
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text ()
forall t. Chunk t => Parser t ()
P.endOfInput)
  blockComment :: Parser [Char]
blockComment = Parser Text -> Parser Text -> Parser [Char]
forall {a} {b}. Parser Text a -> Parser Text b -> Parser [Char]
comment Parser Text
"{-" (Text -> Parser Text
P.string Text
"-}")

  literateBlockComment :: Parser [Char]
literateBlockComment =
    (Parser Text
">" Parser Text -> Parser Text Char -> Parser Text Char
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Char
horizontalSpace Parser Text Char -> Parser Text -> Parser Text
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
"{-")
    Parser Text -> Parser Text () -> Parser Text ()
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text -> Parser Text ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
P.skipMany ((Text
"" Text -> Parser Text Char -> Parser Text
forall a b. a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser Text Char
horizontalSpace) Parser Text -> Parser Text -> Parser Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser Text ()
P.endOfLine Parser Text () -> Parser Text -> Parser Text
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
">"))
    Parser Text () -> Parser Text -> Parser Text
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Parser Text
P.string ([Char] -> Text
pack [Char]
progName) Parser Text -> [Char] -> Parser Text
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
progName)
    Parser Text -> Parser [Char] -> Parser [Char]
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Char -> Parser Text -> Parser [Char]
forall (m :: * -> *) a b. MonadPlus m => m a -> m b -> m [a]
P.manyTill' ((Char -> Bool) -> Parser Text Char
P.satisfy (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
P.isEndOfLine)
                     Parser Text Char -> Parser Text Char -> Parser Text Char
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char
' ' Char -> Parser Text -> Parser Text Char
forall a b. a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Parser Text ()
P.endOfLine Parser Text () -> Parser Text -> Parser Text
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
">" Parser Text -> [Char] -> Parser Text
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
">"))) Parser Text
"-}"

  interpreterComment :: Parser [Char]
interpreterComment = if Bool
isLiterate
                         then Parser [Char]
literateLineComment Parser [Char] -> Parser [Char] -> Parser [Char]
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [Char]
literateBlockComment
                         else Parser [Char]
lineComment Parser [Char] -> Parser [Char] -> Parser [Char]
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [Char]
blockComment

-- | Extract Stack arguments from a correctly placed and correctly formatted

-- comment when it is being used as an interpreter

getInterpreterArgs :: String -> IO (NonEmpty String)
getInterpreterArgs :: [Char] -> IO (NonEmpty [Char])
getInterpreterArgs [Char]
file = do
  Either ParseError [Char]
eArgStr <- [Char]
-> (ConduitM () ByteString IO () -> IO (Either ParseError [Char]))
-> IO (Either ParseError [Char])
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile [Char]
file ConduitM () ByteString IO () -> IO (Either ParseError [Char])
forall {m :: * -> *}.
MonadThrow m =>
ConduitT () ByteString m () -> m (Either ParseError [Char])
parseFile
  case Either ParseError [Char]
eArgStr of
    Left ParseError
err -> [Char] -> IO (NonEmpty [Char])
forall {a}. IsString a => [Char] -> IO (NonEmpty a)
handleFailure ([Char] -> IO (NonEmpty [Char])) -> [Char] -> IO (NonEmpty [Char])
forall a b. (a -> b) -> a -> b
$ ParseError -> [Char]
decodeError ParseError
err
    Right [Char]
str -> [Char] -> IO (NonEmpty [Char])
parseArgStr [Char]
str
 where
  parseFile :: ConduitT () ByteString m () -> m (Either ParseError [Char])
parseFile ConduitT () ByteString m ()
src =
       ConduitT () Void m (Either ParseError [Char])
-> m (Either ParseError [Char])
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
     (ConduitT () Void m (Either ParseError [Char])
 -> m (Either ParseError [Char]))
-> ConduitT () Void m (Either ParseError [Char])
-> m (Either ParseError [Char])
forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString m ()
src
    ConduitT () ByteString m ()
-> ConduitT ByteString Void m (Either ParseError [Char])
-> ConduitT () Void m (Either ParseError [Char])
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Text m ()
forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
decodeUtf8C
    ConduitT ByteString Text m ()
-> ConduitT Text Void m (Either ParseError [Char])
-> ConduitT ByteString Void m (Either ParseError [Char])
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Parser [Char] -> ConduitT Text Void m (Either ParseError [Char])
forall a (m :: * -> *) b o.
(AttoparsecInput a, Monad m) =>
Parser a b -> ConduitT a o m (Either ParseError b)
sinkParserEither (Bool -> [Char] -> Parser [Char]
interpreterArgsParser Bool
isLiterate [Char]
stackProgName)

  isLiterate :: Bool
isLiterate = [Char] -> [Char]
takeExtension [Char]
file [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".lhs"

  -- FIXME We should print anything only when explicit verbose mode is

  -- specified by the user on command line. But currently the

  -- implementation does not accept or parse any command line flags in

  -- interpreter mode. We can only invoke the interpreter as

  -- "stack <file name>" strictly without any options.

  stackWarn :: [Char] -> IO ()
stackWarn [Char]
s = Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
stackProgName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": WARNING! " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s

  handleFailure :: [Char] -> IO (NonEmpty a)
handleFailure [Char]
err = do
    ([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> IO ()
stackWarn ([Char] -> [[Char]]
lines [Char]
err)
    [Char] -> IO ()
stackWarn [Char]
"Missing or unusable Stack options specification"
    [Char] -> IO ()
stackWarn [Char]
"Using runghc without any additional Stack options"
    NonEmpty a -> IO (NonEmpty a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty a -> IO (NonEmpty a)) -> NonEmpty a -> IO (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ a -> NonEmpty a
forall a. a -> NonEmpty a
singleton a
"runghc"

  parseArgStr :: [Char] -> IO (NonEmpty [Char])
parseArgStr [Char]
str =
    case Parser [[Char]] -> Text -> Either [Char] [[Char]]
forall a. Parser a -> Text -> Either [Char] a
P.parseOnly (EscapingMode -> Parser [[Char]]
argsParser EscapingMode
Escaping) ([Char] -> Text
pack [Char]
str) of
      Left [Char]
err -> [Char] -> IO (NonEmpty [Char])
forall {a}. IsString a => [Char] -> IO (NonEmpty a)
handleFailure ([Char]
"Error parsing command specified in the "
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Stack options comment: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err)
      Right [[Char]]
args -> IO (NonEmpty [Char])
-> (NonEmpty [Char] -> IO (NonEmpty [Char]))
-> Maybe (NonEmpty [Char])
-> IO (NonEmpty [Char])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        ([Char] -> IO (NonEmpty [Char])
forall {a}. IsString a => [Char] -> IO (NonEmpty a)
handleFailure [Char]
"Empty argument list in Stack options comment")
        NonEmpty [Char] -> IO (NonEmpty [Char])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ([[Char]] -> Maybe (NonEmpty [Char])
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [[Char]]
args)

  decodeError :: ParseError -> [Char]
decodeError ParseError
e =
    case ParseError
e of
      ParseError [[Char]]
ctxs [Char]
_ (Position Int
l Int
col Int
_) ->
        if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
ctxs
        then [Char]
"Parse error"
        else ([Char]
"Expecting " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" or " [[Char]]
ctxs)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" at line " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", column " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
col
      ParseError
DivergentParser -> [Char]
"Divergent parser"