{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Attoparsec.Interpreter
( interpreterArgsParser
, getInterpreterArgs
) where
import Data.Attoparsec.Args
import Data.Attoparsec.Text ((<?>))
import qualified Data.Attoparsec.Text as P
import Data.Char (isSpace)
import Conduit
import Data.Conduit.Attoparsec
import Data.List (intercalate)
import Data.Text (pack)
import Stack.Prelude
import System.FilePath (takeExtension)
import System.IO (hPutStrLn)
interpreterArgsParser :: Bool -> String -> P.Parser String
interpreterArgsParser :: Bool -> [Char] -> Parser [Char]
interpreterArgsParser Bool
isLiterate [Char]
progName = forall (f :: * -> *) a. Alternative f => a -> f a -> f a
P.option [Char]
"" Parser [Char]
sheBangLine 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
"#!"
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
P.manyTill Parser Char
P.anyChar Parser ()
P.endOfLine
commentStart :: Parser Text a -> Parser Text
commentStart Parser Text a
psr = (Parser Text a
psr forall i a. Parser i a -> [Char] -> Parser i a
<?> ([Char]
progName forall a. [a] -> [a] -> [a]
++ [Char]
" options comment"))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
P.skipSpace
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Parser Text
P.string ([Char] -> Text
pack [Char]
progName) forall i a. Parser i a -> [Char] -> Parser i a
<?> forall a. Show a => a -> [Char]
show [Char]
progName)
anyCharNormalizeSpace :: Parser Char
anyCharNormalizeSpace = let normalizeSpace :: Char -> Char
normalizeSpace Char
c = if Char -> Bool
isSpace Char
c then Char
' ' else Char
c
in forall a. (Char -> a) -> (a -> Bool) -> Parser a
P.satisfyWith Char -> Char
normalizeSpace forall a b. (a -> b) -> a -> b
$ 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 = forall {a}. Parser Text a -> Parser Text
commentStart Parser Text a
start
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((Parser Text b
end forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"")
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser Char
P.space forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
P.manyTill Parser Char
anyCharNormalizeSpace Parser Text b
end forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"-}")))
horizontalSpace :: Parser Char
horizontalSpace = (Char -> Bool) -> Parser Char
P.satisfy Char -> Bool
P.isHorizontalSpace
lineComment :: Parser [Char]
lineComment = forall {a} {b}. Parser Text a -> Parser Text b -> Parser [Char]
comment Parser Text
"--" (Parser ()
P.endOfLine forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall t. Chunk t => Parser t ()
P.endOfInput)
literateLineComment :: Parser [Char]
literateLineComment = forall {a} {b}. Parser Text a -> Parser Text b -> Parser [Char]
comment
(Parser Text
">" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char
horizontalSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
"--")
(Parser ()
P.endOfLine forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall t. Chunk t => Parser t ()
P.endOfInput)
blockComment :: Parser [Char]
blockComment = 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
">" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char
horizontalSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
"{-")
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f ()
P.skipMany ((Text
"" forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser Char
horizontalSpace) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser ()
P.endOfLine forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
">"))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Parser Text
P.string ([Char] -> Text
pack [Char]
progName) forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
progName)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a b. MonadPlus m => m a -> m b -> m [a]
P.manyTill' ((Char -> Bool) -> Parser Char
P.satisfy (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
P.isEndOfLine)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char
' ' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Parser ()
P.endOfLine forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [Char]
literateBlockComment
else Parser [Char]
lineComment forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [Char]
blockComment
getInterpreterArgs :: String -> IO [String]
getInterpreterArgs :: [Char] -> IO [[Char]]
getInterpreterArgs [Char]
file = do
Either ParseError [Char]
eArgStr <- forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile [Char]
file forall {m :: * -> *}.
MonadThrow m =>
ConduitT () ByteString m () -> m (Either ParseError [Char])
parseFile
case Either ParseError [Char]
eArgStr of
Left ParseError
err -> forall {a}. IsString a => [Char] -> IO [a]
handleFailure forall a b. (a -> b) -> a -> b
$ ParseError -> [Char]
decodeError ParseError
err
Right [Char]
str -> [Char] -> IO [[Char]]
parseArgStr [Char]
str
where
parseFile :: ConduitT () ByteString m () -> m (Either ParseError [Char])
parseFile ConduitT () ByteString m ()
src =
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString m ()
src
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
decodeUtf8C
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| 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 forall a. Eq a => a -> a -> Bool
== [Char]
".lhs"
stackWarn :: [Char] -> IO ()
stackWarn [Char]
s = Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ [Char]
stackProgName forall a. [a] -> [a] -> [a]
++ [Char]
": WARNING! " forall a. [a] -> [a] -> [a]
++ [Char]
s
handleFailure :: [Char] -> IO [a]
handleFailure [Char]
err = do
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"
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a
"runghc"]
parseArgStr :: [Char] -> IO [[Char]]
parseArgStr [Char]
str =
case 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 -> forall {a}. IsString a => [Char] -> IO [a]
handleFailure ([Char]
"Error parsing command specified in the "
forall a. [a] -> [a] -> [a]
++ [Char]
"Stack options comment: " forall a. [a] -> [a] -> [a]
++ [Char]
err)
Right [] -> forall {a}. IsString a => [Char] -> IO [a]
handleFailure [Char]
"Empty argument list in Stack options comment"
Right [[Char]]
args -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]]
args
decodeError :: ParseError -> [Char]
decodeError ParseError
e =
case ParseError
e of
ParseError [[Char]]
ctxs [Char]
_ (Position Int
l Int
col Int
_) ->
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
ctxs
then [Char]
"Parse error"
else ([Char]
"Expecting " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" or " [[Char]]
ctxs)
forall a. [a] -> [a] -> [a]
++ [Char]
" at line " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
l forall a. [a] -> [a] -> [a]
++ [Char]
", column " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
col
ParseError
DivergentParser -> [Char]
"Divergent parser"