Skip to content

Commit 68bfcff

Browse files
snoybergborsboom
snoyberg
authored and
borsboom
committed
Ability to act as a script interpreter
1 parent bea77a6 commit 68bfcff

4 files changed

Lines changed: 86 additions & 14 deletions

File tree

‎ChangeLog.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@
77
* `stack upload` without arguments doesn't do anything [#439](https://github.com/commercialhaskell/stack/issues/439)
88
* Print latest version of packages on conflicts [#450](https://github.com/commercialhaskell/stack/issues/450)
99
* Flag to avoid rerunning tests that haven't changed [#451](https://github.com/commercialhaskell/stack/issues/451)
10+
* stack can act as a script interpreter (see [Script interpreter] (https://github.com/commercialhaskell/stack/wiki/Script-interpreter) and [Reddit discussion](http://www.reddit.com/r/haskell/comments/3bd66h/stack_runghc_turtle_as_haskell_script_solution/))
1011

1112
## 0.1.1.0
1213

‎src/Data/Attoparsec/Args.hs‎

Lines changed: 60 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,22 @@
1+
{-# LANGUAGE OverloadedStrings #-}
12
-- | Parsing argument-like things.
23

3-
module Data.Attoparsec.Args (EscapingMode(..), argsParser) where
4+
module Data.Attoparsec.Args (EscapingMode(..), argsParser, withInterpreterArgs) where
45

56
import Control.Applicative
67
import Data.Attoparsec.Text ((<?>))
78
import qualified Data.Attoparsec.Text as P
89
import Data.Attoparsec.Types (Parser)
10+
import Data.ByteString (ByteString)
11+
import qualified Data.ByteString as S
12+
import Data.Conduit
13+
import qualified Data.Conduit.Binary as CB
14+
import qualified Data.Conduit.List as CL
915
import Data.Text (Text)
16+
import Data.Text.Encoding (decodeUtf8')
17+
import System.Directory (doesFileExist)
18+
import System.Environment (getArgs, withArgs)
19+
import System.IO (IOMode (ReadMode), withBinaryFile)
1020

1121
-- | Mode for parsing escape characters.
1222
data EscapingMode
@@ -28,3 +38,52 @@ argsParser mode = many (P.skipSpace *> (quoted <|> unquoted)) <*
2838
escaped = P.char '\\' *> P.anyChar
2939
nonquote = P.satisfy (not . (=='"'))
3040
naked = P.satisfy (not . flip elem ("\" " :: String))
41+
42+
-- | Use 'withArgs' on result of 'getInterpreterArgs'.
43+
withInterpreterArgs :: String -> ([String] -> Bool -> IO a) -> IO a
44+
withInterpreterArgs progName inner = do
45+
(args, isInterpreter) <- getInterpreterArgs progName
46+
withArgs args $ inner args isInterpreter
47+
48+
-- | Check if command-line looks like it's being used as a script interpreter,
49+
-- and if so look for a @-- progName ...@ comment that contains additional
50+
-- arguments.
51+
getInterpreterArgs :: String -> IO ([String], Bool)
52+
getInterpreterArgs progName = do
53+
args0 <- getArgs
54+
case args0 of
55+
(x:_) -> do
56+
isFile <- doesFileExist x
57+
if isFile
58+
then do
59+
margs <-
60+
withBinaryFile x ReadMode $ \h ->
61+
CB.sourceHandle h
62+
$= CB.lines
63+
$= CL.map killCR
64+
$$ sinkInterpreterArgs progName
65+
return $ case margs of
66+
Nothing -> (args0, True)
67+
Just args -> (args ++ "--" : args0, True)
68+
else return (args0, False)
69+
_ -> return (args0, False)
70+
where
71+
killCR bs
72+
| S.null bs || S.last bs /= 13 = bs
73+
| otherwise = S.init bs
74+
75+
sinkInterpreterArgs :: Monad m => String -> Sink ByteString m (Maybe [String])
76+
sinkInterpreterArgs progName =
77+
await >>= maybe (return Nothing) checkShebang
78+
where
79+
checkShebang bs
80+
| "#!" `S.isPrefixOf` bs = fmap (maybe Nothing parseArgs) await
81+
| otherwise = return (parseArgs bs)
82+
83+
parseArgs bs =
84+
case decodeUtf8' bs of
85+
Left _ -> Nothing
86+
Right t ->
87+
case P.parseOnly (argsParser Escaping) t of
88+
Right ("--":progName':rest) | progName' == progName -> Just rest
89+
_ -> Nothing

‎src/main/Main.hs‎

Lines changed: 24 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ import Control.Monad
1616
import Control.Monad.IO.Class
1717
import Control.Monad.Logger
1818
import Control.Monad.Reader (ask)
19+
import Data.Attoparsec.Args (withInterpreterArgs)
1920
import qualified Data.ByteString.Lazy as L
2021
import Data.Char (toLower)
2122
import Data.List
@@ -67,7 +68,7 @@ import System.Process.Read
6768

6869
-- | Commandline dispatcher.
6970
main :: IO ()
70-
main =
71+
main = withInterpreterArgs stackProgName $ \args isInterpreter ->
7172
do -- Line buffer the output by default, particularly for non-terminal runs.
7273
-- See https://github.com/commercialhaskell/stack/pull/360
7374
hSetBuffering stdout LineBuffering
@@ -77,14 +78,13 @@ main =
7778
plugins <- findPlugins (T.pack stackProgName)
7879
tryRunPlugin plugins
7980
progName <- getProgName
80-
args <- getArgs
8181
isTerminal <- hIsTerminalDevice stdout
8282
execExtraHelp args
8383
dockerHelpOptName
8484
(Docker.dockerOptsParser True)
8585
("Only showing --" ++ Docker.dockerCmdName ++ "* options.")
8686
let versionString' = $(simpleVersion Meta.version)
87-
(level,run) <-
87+
eGlobalRun <- try $
8888
simpleOptions
8989
versionString'
9090
"stack - The Haskell Tool Stack"
@@ -237,15 +237,27 @@ main =
237237
<*> many (strArgument (metavar "ARGS"))))
238238
)
239239
-- commandsFromPlugins plugins pluginShouldHaveRun) https://github.com/commercialhaskell/stack/issues/322
240-
when (globalLogLevel level == LevelDebug) $ putStrLn versionString'
241-
run level `catch` \e -> do
242-
-- This special handler stops "stack: " from being printed before the
243-
-- exception
244-
case fromException e of
245-
Just ec -> exitWith ec
246-
Nothing -> do
247-
L.hPut stderr $ toLazyByteString $ fromShow e <> copyByteString "\n"
248-
exitFailure
240+
case eGlobalRun of
241+
Left (exitCode :: ExitCode) -> do
242+
when isInterpreter $
243+
putStrLn $ concat
244+
[ "\nIf you are trying to use "
245+
, stackProgName
246+
, " as a script interpreter, a\n'-- "
247+
, stackProgName
248+
, " [options] runghc [options]' comment is required."
249+
, "\nSee https://github.com/commercialhaskell/stack/wiki/Script-interpreter" ]
250+
throwIO exitCode
251+
Right (global,run) -> do
252+
when (globalLogLevel global == LevelDebug) $ putStrLn versionString'
253+
run global `catch` \e -> do
254+
-- This special handler stops "stack: " from being printed before the
255+
-- exception
256+
case fromException e of
257+
Just ec -> exitWith ec
258+
Nothing -> do
259+
L.hPut stderr $ toLazyByteString $ fromShow e <> copyByteString "\n"
260+
exitFailure
249261
where
250262
dockerHelpOptName = Docker.dockerCmdName ++ "-help"
251263

‎stack.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -85,6 +85,7 @@ library
8585
System.Process.Log
8686
System.Process.Run
8787
Network.HTTP.Download.Verified
88+
Data.Attoparsec.Args
8889
other-modules: Network.HTTP.Download
8990
Control.Concurrent.Execute
9091
Path.Find
@@ -96,7 +97,6 @@ library
9697
Data.Binary.VersionTagged
9798
Data.Set.Monad
9899
Data.Maybe.Extra
99-
Data.Attoparsec.Args
100100
build-depends: Cabal >= 1.18.1.5
101101
, aeson >= 0.8.0.2
102102
, async >= 2.0.2

0 commit comments

Comments
 (0)