hesh (empty) → 1.0.0

raw patch · 7 files changed

+598/−0 lines, 7 filesdep +Cabaldep +aesondep +basesetup-changed

Dependencies added: Cabal, aeson, base, bytestring, cartel, cmdtheline, containers, cryptohash, directory, filemanip, filepath, hackage-db, haskell-src-exts, hesh, parsec, process, template-haskell, text, time, transformers, uniplate

Files

• LICENSE +7/−0
• Setup.hs +2/−0
• hesh.cabal +57/−0
• hesh/Main.hs +274/−0
• lib/Hesh.hs +6/−0
• lib/Hesh/Process.hs +109/−0
• lib/Hesh/Shell.hs +143/−0

@@ -0,0 +1,7 @@+Copyright (C) 2015 Chris Forno++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,57 @@+name:                hesh+version:             1.0.0+synopsis:            the Haskell Extensible Shell: Haskell for Bash-style scripts+description:         Hesh makes writing scripts in Haskell easier by providing Bash-style syntax for running commands, implicit module imports, and automatic dependency inference and Cabal file generation. It allows shebang execution of scripts.+homepage:            https://github.com/jekor/hesh+bug-reports:         https://github.com/jekor/hesh/issues+license:             MIT+license-file:        LICENSE+author:              Chris Forno+maintainer:          jekor@jekor.com+copyright:           2015 Chris Forno+category:            Development+build-type:          Simple+cabal-version:       >=1.10+tested-with:         GHC == 7.8.4++source-repository    head+  type:              git+  location:          git://github.com/jekor/hesh.git++executable hesh+  main-is:             Main.hs+  build-depends:       aeson,+                       base >= 4.7 && < 6,+                       bytestring,+                       Cabal,+                       cartel < 0.11,+                       cmdtheline,+                       containers,+                       cryptohash,+                       directory,+                       filepath,+                       hackage-db >= 1.8,+                       haskell-src-exts,+                       hesh == 1.0.0,+                       parsec >= 3,+                       process,+                       text,+                       time,+                       uniplate+  hs-source-dirs:      hesh+  default-language:    Haskell2010+  ghc-options:         -threaded++library+  hs-source-dirs:      lib+  exposed-modules:     Hesh+                       Hesh.Process+                       Hesh.Shell+  build-depends:       base >= 4.7 && < 6,+                       filemanip,+                       parsec >= 3,+                       process,+                       template-haskell,+                       text,+                       transformers+  default-language:    Haskell2010

@@ -0,0 +1,274 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++import Cartel (empty)+import qualified Cartel as Cartel+import Control.Applicative ((<$>), (<*>))+import Control.Monad (mapM_, liftM, when)+import Control.Exception (catch, throw, SomeException)+import Crypto.Hash (hash, digestToHexByteString, Digest, MD5)+import Data.Aeson (Value(..), ToJSON(..), FromJSON(..), encode, decode)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.Generics.Uniplate.Data (universeBi, transformBi)+import Data.List (intercalate, find, filter, nub, any, takeWhile, isPrefixOf)+import qualified Data.Map.Strict as Map+import Data.Map.Lazy (foldrWithKey)+import Data.Maybe (fromMaybe, catMaybes)+import qualified Data.Text as Text+import Data.Text.Encoding (encodeUtf8, decodeUtf8)+import qualified Data.Text.IO as TIO+import Data.Time.LocalTime (getZonedTime)+import qualified Data.Version as V+import Distribution.Hackage.DB (readHackage, hackagePath)+import Distribution.PackageDescription (condLibrary, condTreeData, exposedModules)+import Distribution.Text (display)+import Distribution.Version (versionBranch)+import GHC.Generics (Generic)+import Language.Haskell.Exts (parseFileContents, ParseResult(..), fromParseResult)+import Language.Haskell.Exts.Syntax (Module(..), ModuleName(..), ImportDecl(..), QName(..), Name(..), Exp(..), Stmt(..), Type(..), SrcLoc(..), QOp(..))+import Language.Haskell.Exts.Pretty (prettyPrint)+import System.Console.CmdTheLine (Term, TermInfo(..), OptInfo(..), PosInfo(..), flag, value, pos, posAny, optInfo, posInfo, defTI)+import System.Console.CmdTheLine.Term (run)+import System.Console.CmdTheLine.Util (fileExists)+import System.Directory (getTemporaryDirectory, createDirectoryIfMissing)+import System.Exit (ExitCode(..), exitFailure)+import System.FilePath ((</>), (<.>), replaceFileName, takeBaseName)+import System.IO (hPutStrLn, stderr, writeFile)+import System.Process (ProcessHandle, waitForProcess, createProcess, CreateProcess(..), shell, proc, StdStream(..))++import Hesh.Process (pipeOps)+import Hesh.Shell (expandSyntax)++waitForSuccess :: String -> ProcessHandle -> IO ()+waitForSuccess cmd p = do+  code <- waitForProcess p+  when (code /= ExitSuccess) $ do+    hPutStrLn stderr $ cmd ++ ": exited with code " ++ show code+    exitFailure++callCommandInDir :: String -> FilePath -> IO ()+callCommandInDir cmd dir = do+  -- GHC is noisy on stdout. It should go to stderr instead.+  -- TODO: Move this into a more appropriate place. It just+  -- happens to work here.+  (_, _, _, p) <- createProcess (shell cmd) { cwd = Just dir, std_out = UseHandle stderr }+  waitForSuccess cmd p++callCommand :: FilePath -> [String] -> IO ()+callCommand path args = do+  (_, _, _, p) <- createProcess (proc path args)+  waitForSuccess path p++catchAny :: IO a -> (SomeException -> IO a) -> IO a+catchAny = catch++-- Read a value from a cache (JSON-encoded file), writing it out if+-- the cached value doesn't exist or is invalid.+fromFileCache :: (FromJSON a, ToJSON a) => FilePath -> a -> IO a+fromFileCache path value = do+  catchAny readCached (\_ -> BL.writeFile path (encode value) >> return value)+ where readCached = do+         d <- BL.readFile path+         case decode d of+           Just x -> return x+           Nothing -> error "Failed to parse JSON."++modulesPath :: IO FilePath+modulesPath = do+  hPath <- hackagePath+  return $ replaceFileName hPath "modules.json"++qualifiedNamesFromModule :: Module -> [(String, String)]+qualifiedNamesFromModule m = [ (mName, name) | Qual (ModuleName mName) (Ident name) <- universeBi m ]++-- This is a helper until Haskell has better defaulting (something like+-- https://ghc.haskell.org/trac/haskell-prime/wiki/Defaulting).+-- It saves adding "IO ()" type declarations in a number of common contexts.+defaultToUnit :: Module -> Module+defaultToUnit = transformBi defaultExpToUnit+ where defaultExpToUnit :: Exp -> Exp+       defaultExpToUnit (Do stmts) = Do (map defaultStmtToUnit stmts)+       defaultExpToUnit exp = exp+       defaultStmtToUnit (Qualifier exp) = Qualifier (defaultQualifiedExpToUnit exp)+       defaultStmtToUnit stmt = stmt+       defaultQualifiedExpToUnit exp = if canDefaultToUnit exp then defaultToUnit exp else exp+       -- do [sh| ... |] => do [sh| ... |] :: IO ()+       canDefaultToUnit (QuasiQuote f _) = f `elem` ["sh", "Hesh.sh"]+       -- do cmd "..." [...] => do cmd "..." [...] :: IO ()+       canDefaultToUnit (App (App (Var f) _) _) = f `elem` functionNames "cmd"+       -- do ... /> "..." => ... /> "..." :: IO ()+       canDefaultToUnit (InfixApp exp1 (QVarOp op) exp2) = op `elem` (concatMap operatorNames pipeOps)+       canDefaultToUnit _ = False+       defaultToUnit exp = ExpTypeSig (SrcLoc "" 0 0) exp (TyVar (Ident "IO ()"))+       functionNames name = [ UnQual (Ident name)+                            , Qual (ModuleName "Hesh") (Ident name) ]+       operatorNames name = [ UnQual (Symbol name)+                            , UnQual (Ident ("(" ++ name ++ ")"))+                            , Qual (ModuleName "Hesh") (Ident ("(" ++ name ++ ")")) ]++importsFromModule :: Module -> [(String, Maybe String)]+importsFromModule (Module _ _ _ _ _ imports _) = map importName imports+ where importName (ImportDecl _ (ModuleName m) _ _ _ _ Nothing _) = (m, Nothing)+       importName (ImportDecl _ (ModuleName m) _ _ _ _ (Just (ModuleName n)) _) = (m, Just n)++importDeclQualified :: String -> ImportDecl+importDeclQualified m = ImportDecl (SrcLoc "" 0 0) (ModuleName m) True False False Nothing Nothing Nothing++importDeclUnqualified :: String -> ImportDecl+importDeclUnqualified m = ImportDecl (SrcLoc "" 0 0) (ModuleName m) False False False Nothing Nothing Nothing++packageFromModules modules m+  | m == "Hesh" || isPrefixOf "Hesh." m = [PackageConstraint "hesh" [1, 0, 0] [1, 0, 0]]+  | otherwise = Map.findWithDefault (error ("Module \"" ++ m ++ "\" not found in Hackage list.")) (Text.pack m) modules++main = run (term, termInfo)++term = hesh <$> flagStdin <*> flagNoSugar <*> optionFile <*> arguments++termInfo = defTI { termName = "hesh", version = "1.0.0" }++flagStdin :: Term Bool+flagStdin = value . flag $ (optInfo [ "stdin", "s" ]) { optName = "STDIN", optDoc = "If this option is present, or if no arguments remain after option processing, then the script is read from standard input." }++flagNoSugar :: Term Bool+flagNoSugar = value . flag $ (optInfo [ "no-sugar", "n" ]) { optName = "NOSUGAR", optDoc = "Don't expand syntax shortcuts." }++optionFile :: Term String+optionFile = value (pos 0 "" posInfo { posName = "FILE" })++arguments = value (posAny [] posInfo { posName = "ARGS" })++hesh useStdin noSugar _ args' = do+  -- In order to work in shebang mode and to provide a more familiar+  -- commandline interface, we support taking the input filename as an+  -- argument (rather than just relying on the script being provided+  -- on stdin). If no commandline argument is provided, we assume the+  -- script is on stdin.+  let scriptName = if useStdin || (args' == []) then "script" else takeBaseName (head args')+  (source'', args) <- if useStdin || (args' == [])+                        then (\x -> (x, args')) `fmap` TIO.getContents+                        else (\x -> (x, tail args')) `fmap` TIO.readFile (head args')+  -- Remove any leading shebang line.+  let source' = if Text.isPrefixOf "#!" source''+                 then Text.dropWhile (/= '\n') source''+                 else source''+      source = if noSugar+                 then source'+                 else Text.pack (expandSyntax (Text.unpack source'))+      md5 = hash $ encodeUtf8 source :: Digest MD5+  --+  -- First, create a directory for the script. One option would be to+  -- create the directory in the current directory, but that would+  -- depend on running the script from its directory, another is to+  -- create it in the script's directory, but we don't know that we+  -- have write permissions to that (if it's even a writable+  -- directory). An always writeable option is to use a temporary+  -- directory, however, this has the disadvantage that it'll could be+  -- cleaned up automatically and slow down start time for later calls+  -- of the script. Additionally, how do we name the directory to+  -- avoid collisions? If we just use the script name there's a high+  -- chance of collisions. If we use a hash of the script we have to+  -- rebuild the directory every time the script changes (viable for+  -- production but not during development).+  --+  -- We could compromise flexibility and safety by providing a command+  -- line parameter for the directory. For maximum safety, we'll use a+  -- hash of the script contents for now.+  --+  dir <- (</> ("hesh-" ++ (Text.unpack $ decodeUtf8 $ digestToHexByteString md5))) `liftM` getTemporaryDirectory+  hPutStrLn stderr ("Building in " ++ dir)+  createDirectoryIfMissing False dir+  -- First, get the module -> package+version lookup table.+  p <- modulesPath+  modules <- fromFileCache p =<< modulePackages+  -- Now, parse the script.+  let ast = defaultToUnit (parseScript source)+      -- Find all qualified module names to add module names to the import list (qualified).+      names = qualifiedNamesFromModule ast+      -- Find any import references.+      imports = importsFromModule ast+      -- Remove aliased modules from the names.+      aliases = catMaybes (map snd imports)+      fqNames = filter (`notElem` aliases) (map fst names)+      -- Insert qualified module usages back into the import list.+      (Module a b c d e importDecls f) = ast+      expandedImports = importDecls ++ map importDeclQualified fqNames ++ if noSugar then [] else [importDeclUnqualified "Hesh"]+      expandedAst = Module a b c d e expandedImports f+      -- From the imports, build a list of necessary packages.+      packages = map (packageFromModules modules) (map fst imports ++ fqNames ++ if noSugar then [] else ["Hesh"])+  writeFile (dir </> "Main.hs") (prettyPrint expandedAst)+  now <- getZonedTime+  -- Cartel expects us to provide the version of the Cartel library+  -- but doesn't export the version for us, so we use 0.+  writeFile (dir </> scriptName <.> "cabal") $ Cartel.renderString "" now (V.Version [0] []) (cartel (map constrainedPackage packages) scriptName)+  -- Cabal will complain without a LICENSE file.+  writeFile (dir </> "LICENSE") ""+  callCommandInDir "cabal install --only-dependencies" dir+  callCommandInDir "cabal build" dir+  -- Finally, run the script.+  -- Should we exec() here?+  -- TODO: Set the program name appropriately.+  callCommand (dir </> "dist/build" </> scriptName </> scriptName) args++-- PackageConstraint -> Package+-- Always prefer base, otherwise arbitrarily take the first module.+constrainedPackage ps = Cartel.Package (Text.unpack (packageName package)) Nothing+ where package = case find (\p -> packageName p == (Text.pack "base")) ps of+                   Just p' -> p'+                   Nothing -> head ps++cartel packages name = Cartel.empty { Cartel.cProperties = properties+                                    , Cartel.cExecutables = [executable] }+ where properties = Cartel.empty+         { Cartel.prName         = name+         , Cartel.prVersion      = Cartel.Version [0,1]+         , Cartel.prCabalVersion = (1,18)+         , Cartel.prBuildType    = Cartel.Simple+         , Cartel.prLicense      = Cartel.AllRightsReserved+         , Cartel.prLicenseFile  = "LICENSE"+         , Cartel.prCategory     = "shell"+         }+       executable = Cartel.Executable name fields+       fields = [ Cartel.ExeMainIs "Main.hs"+                , Cartel.ExeInfo (Cartel.DefaultLanguage Cartel.Haskell2010)+                , Cartel.ExeInfo (Cartel.BuildDepends ([Cartel.Package "base" Nothing] ++ packages))+                ]++-- We make the simplifying assumption that a module only appears in a+-- contiguous version range.+data PackageConstraint = PackageConstraint { packageName :: Text.Text+                                           , packageMinVersion :: [Int]+                                           , packageMaxVersion :: [Int]+                                           } deriving Generic++instance ToJSON PackageConstraint+instance FromJSON PackageConstraint++modulePackages = foldrWithKey buildConstraints Map.empty `liftM` readHackage+ where buildConstraints name versions constraints = foldrWithKey (buildConstraints' name) constraints versions+       buildConstraints' name version meta constraints = foldr (\m cs -> Map.alter (alterConstraint (Text.pack name) (versionBranch version)) m cs) constraints (map (Text.pack . display) (exposedModules' meta))+       alterConstraint packageName' version constraint =+         case constraint of+           Nothing -> Just [PackageConstraint packageName' version version]+           Just constraints ->+             -- TODO: This could probably be more efficient.+             case find (\c -> packageName c == packageName') constraints of+               -- If the package is already listed, update the constraint.+               Just _ -> Just (map (updateConstraint packageName' version) constraints)+               -- If not, add a new constraint.+               Nothing -> Just $ constraints ++ [PackageConstraint packageName' version version]+       updateConstraint name version constraint = if packageName constraint == name+                                                    then if version < packageMinVersion constraint+                                                           then constraint { packageMinVersion = version }+                                                           else if version < packageMaxVersion constraint+                                                                  then constraint { packageMaxVersion = version }+                                                                  else constraint+                                                    else constraint+       exposedModules' = fromMaybe [] . fmap (exposedModules . condTreeData) . condLibrary++parseScript :: Text.Text -> Module+parseScript source =+  case parseFileContents (Text.unpack source) of+    ParseOk m -> m+    r@(ParseFailed _ _) -> fromParseResult r

@@ -0,0 +1,6 @@+module Hesh ( sh, cmd, (|>), (/>), (!>), (&>), (</), (.=)+            , passThrough+            ) where++import Hesh.Process+import Hesh.Shell

@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleInstances #-}++module Hesh.Process ( (|>), (/>), (!>), (&>), (</), pipeOps+                    , cmd, passThrough, (.=)+                    ) where++import Control.Exception (finally)+import Control.Monad (liftM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Char (isSpace)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text.IO+import System.Exit (ExitCode(..))+import System.IO (openFile, IOMode(..), hGetContents, hClose, hPutStrLn, stderr)+import System.Process (proc, createProcess, CreateProcess(..), ProcessHandle, waitForProcess, StdStream(..), CmdSpec(..), readProcess)++pipeOps = ["|>", "/>", "!>", "&>", "</"]++class PipeResult a where+  (|>) :: (MonadIO m) => m CreateProcess -> m CreateProcess -> m a+  (/>) :: (MonadIO m) => m CreateProcess -> FilePath -> m a+  (!>) :: (MonadIO m) => m CreateProcess -> FilePath -> m a+  (&>) :: (MonadIO m) => m CreateProcess -> FilePath -> m a+  (</) :: (MonadIO m) => m CreateProcess -> FilePath -> m a++instance PipeResult CreateProcess where+  (|>) = pipe+  (</) = redirect [Stdin]+  (/>) = redirect [Stdout]+  (!>) = redirect [Stderr]+  (&>) = redirect [Stdout, Stderr]++instance PipeResult () where+  p1 |> p2 = passThrough (p1 |> p2)+  p /> path = passThrough (p /> path)+  p !> path = passThrough (p !> path)+  p &> path = passThrough (p &> path)+  p </ path = passThrough (p </ path)++-- cmd is like proc but operates on the resulting process depending on+-- its calling context.+class ProcResult a where+  cmd :: (MonadIO m) => FilePath -> [String] -> m a++instance ProcResult CreateProcess where+  cmd path args = return (proc path args)++instance ProcResult () where+  cmd path args = passThrough (cmd path args)++instance ProcResult String where+  cmd path args = stdoutToString (cmd path args)++-- TODO: Use something like withCreateProcess to handle exceptions.+waitForSuccess :: CreateProcess -> ProcessHandle -> IO ()+waitForSuccess p h = do+  exit <- waitForProcess h+  case exit of+    ExitSuccess -> return ()+    ExitFailure code -> let (RawCommand command _) = cmdspec p in+                          error ("Command " ++ command ++ " exited with failure code: " ++ show code)  ++passThrough :: (MonadIO m) => m CreateProcess -> m ()+passThrough p' = do+  p <- p'+  (_, _, _, pHandle) <- liftIO (createProcess p)+  liftIO (waitForSuccess p pHandle)++stdoutToString :: (MonadIO m) => m CreateProcess -> m String+stdoutToString p' = do+  p <- p'+  (_, Just pStdout, _, pHandle) <- liftIO (createProcess p { std_out = CreatePipe })+  output <- liftIO (hGetContents pStdout)+  liftIO (waitForSuccess p pHandle)+  -- Strip any trailing newline. These are almost always added to+  -- programs since shells don't add their own newlines, and it's a+  -- surprise to get these when reading a program's output.+  if last output == '\n'+    then return (init output)+    else return output++pipe :: (MonadIO m) => m CreateProcess -> m CreateProcess -> m CreateProcess+pipe p1' p2' = do+  p1 <- p1'; p2 <- p2'+  (_, Just p1Stdout, _, _) <- liftIO (createProcess p1 { std_out = CreatePipe })+  -- TODO: Provide a way to fail on p1 failure (pipefail).+  return (p2 { std_in = UseHandle p1Stdout })++data StdHandle = Stdin | Stdout | Stderr deriving (Eq)++redirect :: (MonadIO m) => [StdHandle] -> m CreateProcess -> FilePath -> m CreateProcess+redirect handles p' path = do+  p <- p'+  f <- liftIO (openFile path (if handles == [Stdin] then ReadMode else WriteMode))+  return (case handles of+             [Stdin] -> p { std_in = UseHandle f }+             [Stdout] -> p { std_out = UseHandle f }+             [Stderr] -> p { std_err = UseHandle f }+             [Stdout, Stderr] -> p { std_out = UseHandle f, std_err = UseHandle f })+  -- TODO: Close handle(s).++-- I'm not sure that I want this to stick around, so I'm not+-- documenting it. If it's common enough, it's worth keeping. If not,+-- it might just be confusing.+(.=) :: (MonadIO m) => m String -> m String -> m Bool+(.=) lhs' rhs' = do+  lhs <- lhs'+  rhs <- rhs'+  return (lhs == rhs)

@@ -0,0 +1,143 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++module Hesh.Shell (sh, expandSyntax) where++import Control.Applicative ((<$>), (*>), (<*))+import Data.Char (isSpace, isAlphaNum)+import Language.Haskell.TH (Q, location, Name, mkName, newName, stringL, litE, varE, listE, varP)+import Language.Haskell.TH.Quote (QuasiQuoter(..), dataToExpQ)+import Language.Haskell.TH.Syntax (Exp(..), Lit(..), Loc(..))+import System.Environment (getEnv)+import System.FilePath.Glob (namesMatching)+import System.Process (proc)+import Text.Parsec (parse)+import Text.Parsec.Char (space, spaces, char, string, noneOf, satisfy, lower, upper)+import Text.Parsec.Combinator (eof, sepEndBy1, many1, between)+import Text.Parsec.Pos (SourcePos, newPos)+import Text.Parsec.Prim (setPosition, many, (<|>), (<?>), try)+import Text.Parsec.String (Parser)++import qualified Hesh.Process++sh :: QuasiQuoter+sh = QuasiQuoter heshExp undefined undefined undefined++heshExp :: String -> Q Exp+heshExp s = do+  l <- location'+  case parse (setPosition l *> topLevel tokensP) "unknown" s of+    Left err -> error ("parse error: " ++ show err)+    Right tokens -> cmdExp tokens []++-- We need to be able to expand some arguments in the IO monad, so+-- each argument is expanded and bound until we finally evaluate the+-- command.+cmdExp :: [String] -> [Name] -> Q Exp+cmdExp [] vars = [| let tokens = concat $(listE (map varE (reverse vars)))+                    in Hesh.Process.cmd (head tokens) (tail tokens) |]+cmdExp (t:ts) vars = do+  case parse fragmentsP "unknown" t of+    Left err -> error ("parse error while parsing token \"" ++ t ++ "\": " ++ show err)+    Right fragments -> do+      -- We have a list of fragments. We need to expand all of the+      -- environment variables in the IO monad. The easiest way seems+      -- to be to just build a list of variables and use return for any+      -- non-monadic expansions.+      x <- newName "x"+      [| ($(fragmentsExp fragments [])) >>= \ $(varP x) -> $(cmdExp ts (x:vars)) |]++data Fragment = FragmentString String | FragmentIdentifier String | FragmentEnvVar String++-- This uses a similar recursive monad statement binding technique as cmdExp+fragmentsExp :: [Fragment] -> [Name] -> Q Exp+fragmentsExp [] vars = [| return [concat $(listE (map varE (reverse vars)))] |]+fragmentsExp (f:fs) vars = do+  x <- newName "y"+  [| $(fragmentExp f) >>= \ $(varP x) -> $(fragmentsExp fs (x:vars)) |]++fragmentExp :: Fragment -> Q Exp+fragmentExp (FragmentString s) = [| return $(litE (stringL s)) |]+fragmentExp (FragmentIdentifier i) = [| return $(varE (mkName i)) |]+fragmentExp (FragmentEnvVar e) = [| getEnv $(litE (stringL e)) |]++fragmentsP :: Parser [Fragment]+fragmentsP = many (try (variableP >>= \x -> case x of+                                              Left i -> return (FragmentIdentifier i)+                                              Right e -> return (FragmentEnvVar e))+               <|> (many1 (onlyEscapedP '$') >>= return . FragmentString))++-- Variables must match valid Haskell identifier names.+-- Any variable beginning with an uppercase character is assumed to be an environment variable.+-- Use of undefined variables throws an error.+-- Left => normal variable (can be referenced immediately)+-- Right => environment variable (must be looked up at runtime)+variableP :: Parser (Either String String)+variableP = do+  char '$'+  (try (between (char '{') (char '}') variable) <|> variable)+ where variable = (try identifier <|> envVariable)+       -- This doesn't cover all possible environment variable names, but it removes ambiguity.+       identifier = do+         x <- lower+         xs <- many (satisfy (\c -> isAlphaNum c || c == '\''))+         return (Left (x:xs))+       envVariable = do+         x <- upper+         xs <- many (satisfy (\c -> isAlphaNum c || c == '_'))+         return (Right (x:xs))++tokensP :: Parser [String]+tokensP = do+  spaces+  tokens <- sepEndBy1 token spaces+  return tokens+ where token = do parts <- many1 (try quotedP <|> unquotedP)+                  return (concat parts)++quotedP = do+  char '"'+  xs <- many (onlyEscapedP '"')+  char '"'+  return xs+ <?> "quoted string"++unquotedP = many1 (satisfy (\c -> not (isSpace c) && c /= '"'))++onlyEscapedP :: Char -> Parser Char+onlyEscapedP c = try (string ['\\', c] >> return c) <|> satisfy (/= c)++topLevel :: Parser a -> Parser a+topLevel p = spaces *> p <* (spaces *> eof)++location' :: Q SourcePos+location' = aux <$> location+  where+    aux :: Loc -> SourcePos+    aux loc = uncurry (newPos (loc_filename loc)) (loc_start loc)++-- The following parsers are for use by hesh before passing the script to the compiler.++expandSyntax s = "{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}\n" ++ desugar s++desugar :: String -> String+desugar s =+  case parse sugarP "" s of+    Left err -> error ("parse error: " ++ show err)+    Right fragments -> concat fragments++sugarP :: Parser [String]+sugarP = many+  (   try shSugarP+  <|> try (string "$")+  <|> (many1 (noneOf "$"))+  )++-- syntactic sugar+-- $() => [sh| |]+shSugarP :: Parser String+shSugarP = do+  string "$("+  xs <- many (onlyEscapedP ')')+  char ')'+  return ("[sh|" ++ xs ++ "|]")