{-# 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 -> String -> Parser String
interpreterArgsParser Bool
isLiterate String
progName = String -> Parser String -> Parser String
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
P.option String
"" Parser String
sheBangLine Parser String -> Parser String -> Parser String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
interpreterComment
where
sheBangLine :: Parser String
sheBangLine = Text -> Parser Text
P.string Text
"#!"
Parser Text -> Parser String -> Parser String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Char -> Parser Text () -> Parser String
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 -> String -> Parser Text a
forall i a. Parser i a -> String -> Parser i a
<?> (String
progName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" options comment"))
Parser Text a -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
P.skipSpace
Parser Text () -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Parser Text
P.string (String -> Text
pack String
progName) Parser Text -> String -> Parser Text
forall i a. Parser i a -> String -> Parser i a
<?> String -> String
forall a. Show a => a -> String
show String
progName)
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 String
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 String -> Parser String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((Parser Text b
end Parser Text b -> Parser String -> Parser String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"")
Parser String -> Parser String -> Parser String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser Text Char
P.space Parser Text Char -> Parser String -> Parser String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser Text Char -> Parser Text b -> Parser String
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
P.manyTill Parser Text Char
anyCharNormalizeSpace Parser Text b
end Parser String -> String -> Parser String
forall i a. Parser i a -> String -> Parser i a
<?> String
"-}")))
horizontalSpace :: Parser Text Char
horizontalSpace = (Char -> Bool) -> Parser Text Char
P.satisfy Char -> Bool
P.isHorizontalSpace
lineComment :: Parser String
lineComment = Parser Text -> Parser Text () -> Parser String
forall a b. Parser Text a -> Parser Text b -> Parser String
comment Parser Text
"--" (Parser Text ()
P.endOfLine Parser Text () -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text ()
forall t. Chunk t => Parser t ()
P.endOfInput)
literateLineComment :: Parser String
literateLineComment = Parser Text -> Parser Text () -> Parser String
forall a b. Parser Text a -> Parser Text b -> Parser String
comment
(Parser Text
">" Parser Text -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Char
horizontalSpace Parser Text Char -> Parser Text -> Parser Text
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text ()
forall t. Chunk t => Parser t ()
P.endOfInput)
blockComment :: Parser String
blockComment = Parser Text -> Parser Text -> Parser String
forall a b. Parser Text a -> Parser Text b -> Parser String
comment Parser Text
"{-" (Text -> Parser Text
P.string Text
"-}")
literateBlockComment :: Parser String
literateBlockComment =
(Parser Text
">" Parser Text -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Char
horizontalSpace Parser Text Char -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
"{-")
Parser Text -> Parser Text () -> Parser Text ()
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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser Text Char
horizontalSpace) Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser Text ()
P.endOfLine Parser Text () -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
">"))
Parser Text () -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Parser Text
P.string (String -> Text
pack String
progName) Parser Text -> String -> Parser Text
forall i a. Parser i a -> String -> Parser i a
<?> String
progName)
Parser Text -> Parser String -> Parser String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Char -> Parser Text -> Parser String
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char
' ' Char -> Parser Text -> Parser Text Char
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Parser Text ()
P.endOfLine Parser Text () -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
">" Parser Text -> String -> Parser Text
forall i a. Parser i a -> String -> Parser i a
<?> String
">"))) Parser Text
"-}"
interpreterComment :: Parser String
interpreterComment = if Bool
isLiterate
then Parser String
literateLineComment Parser String -> Parser String -> Parser String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser String
literateBlockComment
else Parser String
lineComment Parser String -> Parser String -> Parser String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser String
blockComment
getInterpreterArgs :: String -> IO [String]
getInterpreterArgs :: String -> IO [String]
getInterpreterArgs String
file = do
Either ParseError String
eArgStr <- String
-> (ConduitM () ByteString IO () -> IO (Either ParseError String))
-> IO (Either ParseError String)
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
String -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile String
file ConduitM () ByteString IO () -> IO (Either ParseError String)
forall (m :: * -> *).
MonadThrow m =>
ConduitM () ByteString m () -> m (Either ParseError String)
parseFile
case Either ParseError String
eArgStr of
Left ParseError
err -> String -> IO [String]
forall a. IsString a => String -> IO [a]
handleFailure (String -> IO [String]) -> String -> IO [String]
forall a b. (a -> b) -> a -> b
$ ParseError -> String
decodeError ParseError
err
Right String
str -> String -> IO [String]
parseArgStr String
str
where
parseFile :: ConduitM () ByteString m () -> m (Either ParseError String)
parseFile ConduitM () ByteString m ()
src =
ConduitT () Void m (Either ParseError String)
-> m (Either ParseError String)
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
(ConduitT () Void m (Either ParseError String)
-> m (Either ParseError String))
-> ConduitT () Void m (Either ParseError String)
-> m (Either ParseError String)
forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString m ()
src
ConduitM () ByteString m ()
-> ConduitM ByteString Void m (Either ParseError String)
-> ConduitT () Void m (Either ParseError String)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT ByteString Text m ()
forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
decodeUtf8C
ConduitT ByteString Text m ()
-> ConduitM Text Void m (Either ParseError String)
-> ConduitM ByteString Void m (Either ParseError String)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Parser String -> ConduitM Text Void m (Either ParseError String)
forall a (m :: * -> *) b o.
(AttoparsecInput a, Monad m) =>
Parser a b -> ConduitT a o m (Either ParseError b)
sinkParserEither (Bool -> String -> Parser String
interpreterArgsParser Bool
isLiterate String
stackProgName)
isLiterate :: Bool
isLiterate = String -> String
takeExtension String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".lhs"
stackWarn :: String -> IO ()
stackWarn String
s = Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
stackProgName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": WARNING! " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
handleFailure :: String -> IO [a]
handleFailure String
err = do
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
stackWarn (String -> [String]
lines String
err)
String -> IO ()
stackWarn String
"Missing or unusable stack options specification"
String -> IO ()
stackWarn String
"Using runghc without any additional stack options"
[a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a
"runghc"]
parseArgStr :: String -> IO [String]
parseArgStr String
str =
case Parser [String] -> Text -> Either String [String]
forall a. Parser a -> Text -> Either String a
P.parseOnly (EscapingMode -> Parser [String]
argsParser EscapingMode
Escaping) (String -> Text
pack String
str) of
Left String
err -> String -> IO [String]
forall a. IsString a => String -> IO [a]
handleFailure (String
"Error parsing command specified in the "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"stack options comment: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
Right [] -> String -> IO [String]
forall a. IsString a => String -> IO [a]
handleFailure String
"Empty argument list in stack options comment"
Right [String]
args -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
args
decodeError :: ParseError -> String
decodeError ParseError
e =
case ParseError
e of
ParseError [String]
ctxs String
_ (Position Int
line Int
col Int
_) ->
if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ctxs
then String
"Parse error"
else (String
"Expecting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" or " [String]
ctxs)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", column " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
col
ParseError
DivergentParser -> String
"Divergent parser"