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.FilePath (takeExtension)
import System.IO (IOMode (ReadMode), withBinaryFile, 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 <- 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 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
ParseError ctxs _ (Position line col) ->
if null ctxs
then "Parse error"
else ("Expecting " ++ intercalate " or " ctxs)
++ " at line " ++ show line ++ ", column " ++ show col
DivergentParser -> "Divergent parser"