{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
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 Data.Conduit
import Data.Conduit.Attoparsec
import Data.Conduit.Text (decodeUtf8)
import Data.List (intercalate)
import Data.Text (pack)
import Stack.Constants
import Stack.Prelude
import System.FilePath (takeExtension)
import System.IO (stderr, hPutStrLn)
interpreterArgsParser :: Bool -> String -> P.Parser String
interpreterArgsParser isLiterate progName = P.option "" sheBangLine *> interpreterComment
where
sheBangLine = P.string "#!"
*> P.manyTill P.anyChar P.endOfLine
commentStart psr = (psr <?> (progName ++ " options comment"))
*> P.skipSpace
*> (P.string (pack progName) <?> show progName)
anyCharNormalizeSpace = let normalizeSpace c = if isSpace c then ' ' else c
in P.satisfyWith normalizeSpace $ const True
comment start end = commentStart start
*> ((end >> return "")
<|> (P.space *> (P.manyTill anyCharNormalizeSpace end <?> "-}")))
horizontalSpace = P.satisfy P.isHorizontalSpace
lineComment = comment "--" (P.endOfLine <|> P.endOfInput)
literateLineComment = comment
(">" *> horizontalSpace *> "--")
(P.endOfLine <|> P.endOfInput)
blockComment = comment "{-" (P.string "-}")
literateBlockComment =
(">" *> horizontalSpace *> "{-")
*> P.skipMany (("" <$ horizontalSpace) <|> (P.endOfLine *> ">"))
*> (P.string (pack progName) <?> progName)
*> P.manyTill' (P.satisfy (not . P.isEndOfLine)
<|> (' ' <$ (P.endOfLine *> ">" <?> ">"))) "-}"
interpreterComment = if isLiterate
then literateLineComment <|> literateBlockComment
else lineComment <|> blockComment
getInterpreterArgs :: String -> IO [String]
getInterpreterArgs file = do
eArgStr <- withSourceFile file parseFile
case eArgStr of
Left err -> handleFailure $ decodeError err
Right str -> parseArgStr str
where
parseFile src =
runConduit
$ src
.| decodeUtf8
.| sinkParserEither (interpreterArgsParser isLiterate stackProgName)
isLiterate = takeExtension file == ".lhs"
stackWarn s = hPutStrLn stderr $ stackProgName ++ ": WARNING! " ++ s
handleFailure err = do
mapM_ stackWarn (lines err)
stackWarn "Missing or unusable stack options specification"
stackWarn "Using runghc without any additional stack options"
return ["runghc"]
parseArgStr str =
case P.parseOnly (argsParser Escaping) (pack str) of
Left err -> handleFailure ("Error parsing command specified in the "
++ "stack options comment: " ++ err)
Right [] -> handleFailure "Empty argument list in stack options comment"
Right args -> return args
decodeError e =
case e of
#if MIN_VERSION_conduit_extra(1,2,0)
ParseError ctxs _ (Position line col _) ->
#else
ParseError ctxs _ (Position line col) ->
#endif
if null ctxs
then "Parse error"
else ("Expecting " ++ intercalate " or " ctxs)
++ " at line " ++ show line ++ ", column " ++ show col
DivergentParser -> "Divergent parser"