module Data.Attoparsec.Interpreter
( interpreterArgsParser
, getInterpreterArgs
) where
import Control.Applicative
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 qualified Data.Conduit.Binary as CB
import Data.Conduit.Text(decodeUtf8)
import Data.List (intercalate)
import Data.Text (pack)
import Stack.Constants
import System.IO (IOMode (ReadMode), withBinaryFile, stderr, hPutStrLn)
interpreterArgsParser :: String -> P.Parser String
interpreterArgsParser progName = P.option "" sheBangLine *> interpreterComment
where
sheBangLine = P.string "#!"
*> P.manyTill P.anyChar P.endOfLine
commentStart str = (P.string str <?> (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 <?> "-}")))
lineComment = comment "--" (P.endOfLine <|> P.endOfInput)
blockComment = comment "{-" (P.string "-}")
interpreterComment = lineComment <|> blockComment
getInterpreterArgs :: String -> IO [String]
getInterpreterArgs file = do
eArgStr <- withBinaryFile file ReadMode parseFile
case eArgStr of
Left err -> handleFailure $ decodeError err
Right str -> parseArgStr str
where
parseFile h =
CB.sourceHandle h
=$= decodeUtf8
$$ sinkParserEither (interpreterArgsParser stackProgName)
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
ParseError ctxs _ (Position line col) ->
if length ctxs == 0
then "Parse error"
else ("Expecting " ++ (intercalate " or " ctxs))
++ " at line " ++ (show line) ++ ", column " ++ (show col)
DivergentParser -> "Divergent parser"