├── .gitignore
├── LICENSE
├── Makefile
├── README.md
├── Setup.hs
├── examples
    ├── README.md
    ├── file-subset.hesh
    ├── secure-pg-backup.hesh
    └── translations
    │   ├── README.md
    │   ├── day
    │   ├── day.hesh
    │   ├── day.sh
    │   ├── draw-ruler
    │   ├── draw-ruler.bash
    │   ├── draw-ruler.hesh
    │   ├── vipe
    │   ├── vipe.bash
    │   └── vipe.hesh
├── hesh.cabal
├── hesh
    └── Main.hs
├── lib
    ├── Hesh.hs
    └── Hesh
    │   ├── Process.hs
    │   └── Shell.hs
└── manual
    ├── manual.md
    └── manual.pdf


/.gitignore:
--------------------------------------------------------------------------------
1 | .cabal-sandbox
2 | cabal.sandbox.config
3 | dist


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (C) 2015 Chris Forno
2 | 
3 | 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:
4 | 
5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
6 | 
7 | 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.


--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | manual/manual.% : manual/manual.md
2 | 	pandoc -s -o $@ $^
3 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # Hesh - The Haskell-Extensible Shell
 2 | 
 3 | Hesh makes writing scripts in Haskell easier. Here's an example:
 4 | 
 5 | ```haskell
 6 | #!/usr/bin/env hesh
 7 | -- Backup a PostgreSQL database to an encrypted file.
 8 | 
 9 | main = do
10 |   args <- System.Environment.getArgs
11 |   case args of
12 |     [database] -> do
13 |       today <- $(date +%Y-%m-%d)
14 |       let file = database ++ "-" ++ today ++ ".sql.gpg"
15 |       $(pg_dump $database) |> $(gpg -e -r $EMAIL) /> file
16 |     _ -> do
17 |       progName <- System.Environment.getProgName
18 |       $(echo "Usage: $progName <database>") /> "/dev/stderr"
19 | ```
20 | 
21 | For more details, see the [manual](manual/manual.pdf).
22 | 


--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/examples/README.md:
--------------------------------------------------------------------------------
1 | # Hesh Examples
2 | 
3 | This is a collection of real-world examples of scripts written in Hesh. To see how Hesh compares to Bash, see the [translations](translations) directory.
4 | 


--------------------------------------------------------------------------------
/examples/file-subset.hesh:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env hesh
 2 | 
 3 | -- Given a set of files, take a random subset that fit within the specified size.
 4 | -- This assumes a small deviation among file sizes and a target subset size
 5 | -- significantly larger than any single file size. (The algorithm is non-optimal.)
 6 | 
 7 | -- The original use for this script was to take a subset of a music collection
 8 | -- that would fit on a phone. For example, to take 4GB of music on the go:
 9 | -- find ~/music | ./file-subset 4GB | (while read f; do cp "$f" /mnt/phone/music/; done)
10 | 
11 | import Data.Char (isDigit, toUpper, toLower)
12 | import System.Posix.Files (getFileStatus, fileSize)
13 | import Text.ParserCombinators.ReadP (many1, satisfy, skipSpaces, option, optional, choice, char)
14 | import qualified Text.Read as Read
15 | 
16 | main = do
17 |   args <- System.Environment.getArgs
18 |   case args of
19 |     [bytes] -> do
20 |       let (Bytes b) = read bytes :: Bytes
21 |       -- Take the list of files on stdin. This makes the command easier to use
22 |       -- in pipelines.
23 |       files <- lines `fmap` getContents
24 |       -- There's 2 ways we could go about this. One is to do this:
25 |       -- > sizes <- mapM System.Directory.fileSize files
26 |       -- but that leads us to do more work than we need (we have to read the
27 |       -- size of every file). Instead, let's:
28 |       mapM_ putStrLn =<< takeWhileLessThanM b (\x -> fileSize `fmap` getFileStatus x) =<< System.Random.Shuffle.shuffleM files
29 |     _ -> error "Required argument <bytes> missing."
30 |  where takeWhileLessThanM n f xs = takeWhileLessThanM' [] n f xs
31 |        takeWhileLessThanM' r n f [] = return (reverse r)
32 |        takeWhileLessThanM' r n f (x:xs) = do
33 |          i <- fromIntegral `fmap` f x
34 |          if i < n
35 |            then takeWhileLessThanM' (x:r) (n - i) f xs
36 |            else return (reverse r)
37 | 
38 | -- Convert human-readable units into bytes.
39 |     
40 | -- This is a good example of when it's nice to have an expressive language.
41 | -- When I began writing this script I didn't immediately think about how the
42 | -- user would specify the size of the set of files. Without Haskell here, I
43 | -- would have had to write this as a separate executable. Although there is
44 | -- a case for doing so anyway, it moves us out of solving our original problem
45 | -- to have to do so right away.
46 |     
47 | units = ['K', 'M', 'G', 'T', 'P', 'E', 'Z', 'Y']
48 | 
49 | data Bytes = Bytes Integer
50 | 
51 | instance Read Bytes where
52 |   readPrec = Text.ParserCombinators.ReadPrec.lift (do
53 |     i <- many1 (satisfy isDigit)
54 |     skipSpaces
55 |     multiplier <- option 1 unitP
56 |     return (Bytes (read i * multiplier)))
57 |    where unitP = do
58 |            u <- option 0 (do u' <- satisfy (\c -> toUpper c `elem` units)
59 |                              let idx = Data.Maybe.fromJust (Data.List.elemIndex (toUpper u') units)
60 |                              return (idx + 1))
61 |            binary <- option ' ' (char 'i') -- binary unit
62 |            choice [char 'B', char 'b']
63 |            return (case binary of
64 |                      'i' -> 2 ^ (u * 10)
65 |                      _ -> 1000 ^ u)
66 | 


--------------------------------------------------------------------------------
/examples/secure-pg-backup.hesh:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env hesh
 2 | -- Backup a PostgreSQL database to an encrypted file.
 3 | 
 4 | main = do
 5 |   args <- System.Environment.getArgs
 6 |   case args of
 7 |     [database] -> do
 8 |       today <- $(date +%Y-%m-%d)
 9 |       let file = database ++ "-" ++ today ++ ".sql.gpg"
10 |       $(pg_dump $database) |> $(gpg -e -r $EMAIL) /> file
11 |     _ -> do
12 |       progName <- System.Environment.getProgName
13 |       $(echo "Usage: $progName <database>") /> "/dev/stderr"
14 | 


--------------------------------------------------------------------------------
/examples/translations/README.md:
--------------------------------------------------------------------------------
 1 | # Translated Examples
 2 | 
 3 | These are some scripts that have been translated from Bourne/Bash into Hesh. Each Hesh script tries to retain the style of its original except where it's more natural to write in a functional Haskell style. Included below are some example commands you can try for yourself.
 4 | 
 5 | ## draw-ruler
 6 | 
 7 | Draw a ruler on the terminal.
 8 | 
 9 | ```
10 | ./draw-ruler
11 | ```
12 | 
13 | ```
14 | ./draw-ruler __x__
15 | ```
16 | 
17 | ## vipe
18 | 
19 | Pipe a string through an editor.
20 | 
21 | ```
22 | echo "Edit me." | ./vipe | cat
23 | ```
24 | 
25 | ```
26 | ./vipe | cat
27 | ```
28 | 
29 | ## day
30 | 
31 | Show the date of a given day.
32 | 
33 | ```
34 | ./day wed
35 | ```
36 | 
37 | ```
38 | ./day wed last
39 | ```
40 | 


--------------------------------------------------------------------------------
/examples/translations/day:
--------------------------------------------------------------------------------
1 | day.hesh


--------------------------------------------------------------------------------
/examples/translations/day.hesh:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env hesh
 2 | 
 3 | -- Based on https://github.com/pixelb/scripts/blob/f93a55beae3baf97af64f8c833e27cd6e04fb983/scripts/day
 4 | 
 5 | -- Shows the date for "fri week" or "mon last" for e.g.
 6 | 
 7 | -- License: LGPLv2
 8 | 
 9 | usage = do
10 |   program <- System.Environment.getProgName
11 |   basename <- $(basename $program)
12 |   $(echo "Usage $basename mon|tue|... [next]|week|last")
13 |   System.Exit.exitFailure
14 | 
15 | main :: IO ()
16 | main = do
17 |   args <- System.Environment.getArgs
18 |   case args of
19 |     [day, which] -> printDay day which
20 |     [day] -> printDay day "next"
21 |     _ -> usage
22 |  where printDay day "week" = do
23 |          dayIsToday <- $(date +%D) .= $(date --date="next $day" +%D) -- assume we want the next week, not today
24 |          if dayIsToday
25 |            then printDate day "+2"
26 |            else printDate day "+1"
27 |        printDay day "last" = printDate day "-1"
28 |        printDay day "next" = do
29 |          dayIsToday <- $(date +%D) .= $(date --date="next $day" +%D)
30 |          if dayIsToday
31 |            then printDate day "+1"
32 |            else printDate day "+0"
33 |        printDay _ _ = usage
34 |        printDate day weeks = $(date --date="$day $weeks weeks" +%x)
35 | 


--------------------------------------------------------------------------------
/examples/translations/day.sh:
--------------------------------------------------------------------------------
 1 | #!/bin/sh
 2 | 
 3 | # https://github.com/pixelb/scripts/blob/f93a55beae3baf97af64f8c833e27cd6e04fb983/scripts/day
 4 | 
 5 | # Shows the date for "fri week" or "mon last" for e.g.
 6 | 
 7 | # License: LGPLv2
 8 | 
 9 | Usage () {
10 |     echo "Usage: `basename $0` mon|tue|... [next]|week|last" >&2
11 |     exit 1
12 | }
13 | 
14 | [ "$#" -eq "0" ] && Usage
15 | 
16 | day=$1
17 | which=$2
18 | [ -z "$which" ] && which=next
19 | 
20 | case $which in
21 | week)
22 |     if [ `date +%D` = `date --date="next $day" +%D` ]; then
23 |         weeks=+2 #assume we want the next week, not today
24 |     else
25 |         weeks=+1
26 |     fi ;;
27 | last)
28 |     weeks=-1;;
29 | next)
30 |     if [ `date +%D` = `date --date="next $day" +%D` ]; then
31 |         weeks=+1 #assume we want the next week, not today
32 |     else
33 |         weeks=+0
34 |     fi ;;
35 | *)
36 |     Usage;;
37 | esac
38 | 
39 | date --date="$day $weeks weeks" +%x
40 | 


--------------------------------------------------------------------------------
/examples/translations/draw-ruler:
--------------------------------------------------------------------------------
1 | draw-ruler.hesh


--------------------------------------------------------------------------------
/examples/translations/draw-ruler.bash:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env bash
 2 | 
 3 | # https://github.com/janmoesen/tilde/blob/2023cb49c82e83f143eae956516d05ed353ef6f1/bin/draw-ruler
 4 | 
 5 | # Draw a ruler across the screen. By default, it displays the column number of
 6 | # the 1st, 11th, 21st, … column, and a marker on every 5 in between. You can
 7 | # also specify a custom string to draw as the first parameter. Every "x" in the
 8 | # string will be replaced by the column number.
 9 | 
10 | # The string to repeat for the entire line. The letter "x" marks the start of
11 | # the column number. Other characters are printed as they are.
12 | str="${1:-x...·.....}";
13 | 
14 | num_columns="$(tput cols)";
15 | curr_column=1;
16 | while [ $curr_column -le $num_columns ]; do
17 | 	char="${str:$(((curr_column - 1) % ${#str})):1}";
18 | 	if [ "$char" = 'x' ]; then
19 | 		echo -n "$curr_column";
20 | 		let curr_column+=${#curr_column};
21 | 	else
22 | 		echo -n "$char";
23 | 		let curr_column++;
24 | 	fi;
25 | done;
26 | echo;
27 | 


--------------------------------------------------------------------------------
/examples/translations/draw-ruler.hesh:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env hesh
 2 | 
 3 | -- Based on https://github.com/janmoesen/tilde/blob/2023cb49c82e83f143eae956516d05ed353ef6f1/bin/draw-ruler
 4 | 
 5 | -- Draw a ruler across the screen. By default, it displays the column number of
 6 | -- the 1st, 11th, 21st, … column, and a marker on every 5 in between. You can
 7 | -- also specify a custom string to draw as the first parameter. Every "x" in the
 8 | -- string will be replaced by the column number.
 9 | 
10 | -- The string to repeat for the entire line. The letter "x" marks the start of
11 | -- the column number. Other characters are printed as they are.
12 | 
13 | main = do
14 |   args <- System.Environment.getArgs
15 |   let str = case args of
16 |               [] -> "x...·....."
17 |               (x:_) -> x
18 |   numColumns <- read `fmap` $(tput cols)
19 |   printColumn str numColumns 1
20 |   putStrLn ""
21 |  where printColumn str numColumns currColumn
22 |          | currColumn > numColumns = return ()
23 |          | otherwise = let char = (cycle str) !! (currColumn - 1)
24 |                            string = if char == 'x' then show currColumn else [char]
25 |                        in do putStr string
26 |                              printColumn str numColumns (currColumn + length string)
27 | 
28 | 


--------------------------------------------------------------------------------
/examples/translations/vipe:
--------------------------------------------------------------------------------
1 | vipe.hesh


--------------------------------------------------------------------------------
/examples/translations/vipe.bash:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env bash
 2 | 
 3 | # https://github.com/juliangruber/vipe/blob/b437a3ae7ac771b264d24b8cf55f4af91dcae034/vipe.sh
 4 | 
 5 | #
 6 | # vipe(1) - Pipe in and out of $EDITOR
 7 | #
 8 | # (c) 2014 Julian Gruber <julian@juliangruber.com>.
 9 | #
10 | # MIT licensed.
11 | #
12 | # Example:
13 | #
14 | #   $ echo foo | vipe | gist
15 | #   $ vipe | gist
16 | #
17 | # This is a lightweight bash only version. For the original impementation in
18 | # python, check https://github.com/madx/moreutils/blob/master/vipe
19 | #
20 | 
21 | # version
22 | 
23 | VERSION="0.0.0"
24 | 
25 | # usage
26 | 
27 | if [ "-h" = "${1}" ]; then
28 |   echo "usage: vipe [-hV]"
29 |   exit 0
30 | elif [ "-V" = "${1}" ]; then
31 |   echo "${VERSION}"
32 | fi
33 | 
34 | # temp file
35 | 
36 | t=/tmp/vipe.$$.txt
37 | touch $t
38 | 
39 | # read from stdin
40 | 
41 | if [ ! -t 0 ]; then
42 |   cat > $t
43 | fi
44 | 
45 | # spawn editor with stdio connected
46 | 
47 | ${EDITOR} $t < /dev/tty > /dev/tty || exit $?
48 | 
49 | # write to stdout
50 | 
51 | cat $t
52 | 
53 | # cleanup
54 | 
55 | rm $t
56 | 


--------------------------------------------------------------------------------
/examples/translations/vipe.hesh:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env hesh
 2 | 
 3 | {-# LANGUAGE ExtendedDefaultRules #-}
 4 | 
 5 | -- Based on https://github.com/juliangruber/vipe/blob/b437a3ae7ac771b264d24b8cf55f4af91dcae034/vipe.sh
 6 | 
 7 | --
 8 | -- vipe(1) - Pipe in and out of $EDITOR
 9 | --
10 | -- (c) 2014 Julian Gruber <julian@juliangruber.com>.
11 | -- MIT licensed.
12 | --
13 | -- Example:
14 | --
15 | --   $ echo foo | vipe | gist
16 | --   $ vipe | gist
17 | --
18 | -- This is a lightweight bash only version. For the original impementation in
19 | -- python, check https://github.com/madx/moreutils/blob/master/vipe
20 | --
21 | 
22 | -- version
23 | version = "0.0.0"
24 | 
25 | main = do
26 |   -- usage
27 |   args <- System.Environment.getArgs
28 |   case args of
29 |     ("-h":_) -> putStrLn "usage: vipe [-hV]"
30 |     ("-V":_) -> putStrLn version
31 |     _ -> do
32 |       -- temp file
33 |       pid <- System.Posix.Process.getProcessID
34 |       let t = "/tmp/vipe." ++ show pid ++ ".txt"
35 |       $(touch $t)
36 | 
37 |       -- read from stdin
38 |       isTTY <- System.IO.hIsTerminalDevice System.IO.stdin
39 |       Control.Monad.when (not isTTY) ($(cat) /> t)
40 | 
41 |       -- spawn editor with stdio connected
42 |       $($EDITOR $t) </ "/dev/tty" /> "/dev/tty"
43 | 
44 |       -- write to stdout
45 |       $(cat $t)
46 | 
47 |       -- cleanup
48 |       $(rm $t)
49 | 


--------------------------------------------------------------------------------
/hesh.cabal:
--------------------------------------------------------------------------------
 1 | name:                hesh
 2 | version:             1.14.0
 3 | synopsis:            the Haskell Extensible Shell: Haskell for Bash-style scripts
 4 | 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.
 5 | homepage:            https://github.com/jekor/hesh
 6 | bug-reports:         https://github.com/jekor/hesh/issues
 7 | license:             MIT
 8 | license-file:        LICENSE
 9 | author:              Chris Forno
10 | maintainer:          jekor@jekor.com
11 | copyright:           2015, 2016, 2017, 2018 Chris Forno
12 | category:            Development
13 | build-type:          Simple
14 | cabal-version:       >=1.10
15 | tested-with:         GHC == 8.0.2
16 | 
17 | source-repository    head
18 |   type:              git
19 |   location:          git://github.com/jekor/hesh.git
20 | 
21 | executable hesh
22 |   main-is:             Main.hs
23 |   build-depends:       aeson,
24 |                        base >= 4.7 && < 6,
25 |                        bytestring,
26 |                        Cabal,
27 |                        cartel >= 0.16,
28 |                        cmdargs,
29 |                        containers,
30 |                        cryptonite,
31 |                        data-default,
32 |                        directory,
33 |                        filepath,
34 |                        hackage-db >= 1.8 && < 2.0,
35 |                        haskell-src-exts < 1.18,
36 |                        hesh == 1.14.0,
37 |                        parsec >= 3,
38 |                        process,
39 |                        text,
40 |                        time,
41 |                        uniplate,
42 |                        unix,
43 |                        utf8-string
44 |   hs-source-dirs:      hesh
45 |   default-language:    Haskell2010
46 |   ghc-options:         -threaded
47 | 
48 | library
49 |   hs-source-dirs:      lib
50 |   exposed-modules:     Hesh
51 |                        Hesh.Process
52 |                        Hesh.Shell
53 |   build-depends:       base >= 4.7 && < 6,
54 |                        bytestring,
55 |                        exceptions,
56 |                        filemanip,
57 |                        parsec >= 3,
58 |                        process,
59 |                        template-haskell,
60 |                        text,
61 |                        transformers
62 |   default-language:    Haskell2010
63 | 


--------------------------------------------------------------------------------
/hesh/Main.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DeriveGeneric #-}
  2 | {-# LANGUAGE DeriveDataTypeable #-}
  3 | {-# LANGUAGE OverloadedStrings #-}
  4 | 
  5 | import qualified Cartel
  6 | import qualified Cartel.Ast
  7 | import qualified Cartel.Render
  8 | import Control.Applicative ((<$>), (<*>))
  9 | import Control.Monad (mapM_, liftM, when)
 10 | import Control.Exception (catch, throw, SomeException)
 11 | import Crypto.Hash (hash, Digest, MD5)
 12 | import Data.Aeson (Value(..), ToJSON(..), FromJSON(..), encode, decode)
 13 | import qualified Data.ByteString as BS
 14 | import qualified Data.ByteString.Char8 as B8
 15 | import qualified Data.ByteString.Lazy as BL
 16 | import qualified Data.ByteString.UTF8 as BU
 17 | import Data.Char (isDigit)
 18 | import Data.Data (Data)
 19 | import Data.Default (def)
 20 | import Data.Generics.Uniplate.Data (universeBi, transformBi)
 21 | import Data.List (intercalate, find, filter, nub, any, takeWhile, isPrefixOf, unionBy)
 22 | import qualified Data.Map.Strict as Map
 23 | import Data.Map.Lazy (foldrWithKey)
 24 | import Data.Maybe (fromMaybe, catMaybes, isJust)
 25 | import Data.Monoid (mempty)
 26 | import qualified Data.Text as Text
 27 | import Data.Text.Encoding (encodeUtf8, decodeUtf8)
 28 | import Data.Typeable (Typeable)
 29 | import qualified Data.Version as V
 30 | import Distribution.Hackage.DB (readHackage', hackagePath)
 31 | import Distribution.PackageDescription (condLibrary, condTreeData, exposedModules)
 32 | import Distribution.Text (display)
 33 | import GHC.Generics (Generic)
 34 | import Language.Haskell.Exts (parseFileContentsWithMode, ParseMode(..), defaultParseMode, Extension(..), KnownExtension(..), ParseResult(..), fromParseResult)
 35 | import Language.Haskell.Exts.Fixity (applyFixities, infix_, infixl_, infixr_)
 36 | import Language.Haskell.Exts.Syntax (Module(..), ModuleName(..), ModulePragma(..), ImportDecl(..), QName(..), Name(..), Exp(..), Stmt(..), Type(..), SrcLoc(..), QOp(..))
 37 | import Language.Haskell.Exts.Pretty (prettyPrintWithMode, defaultMode, PPHsMode(linePragmas))
 38 | import System.Console.CmdArgs (cmdArgs, (&=), help, typ, typDir, args, summary, name)
 39 | import System.Directory (getTemporaryDirectory, createDirectoryIfMissing, doesFileExist)
 40 | import System.Exit (ExitCode(..), exitFailure)
 41 | import System.FilePath ((</>), (<.>), replaceFileName, takeBaseName)
 42 | import System.IO (hPutStrLn, hPutStr, stderr, writeFile, hGetContents, Handle)
 43 | import System.Posix.Process (executeFile)
 44 | import System.Process (ProcessHandle, waitForProcess, createProcess, CreateProcess(..), shell, proc, StdStream(..))
 45 | 
 46 | import Hesh.Process (pipeOps)
 47 | import Hesh.Shell (desugar)
 48 | 
 49 | data Hesh = Hesh {stdin_ :: Bool
 50 |                  ,no_sugar :: Bool
 51 |                  ,no_type_hints :: Bool
 52 |                  ,compile_only :: Bool
 53 |                  ,source_dir :: String
 54 |                  ,source_only :: Bool
 55 |                  ,verbose :: Bool
 56 |                  ,package_index :: String
 57 |                  ,module_index :: String
 58 |                  ,args_ :: [String]
 59 |                  } deriving (Data, Typeable, Show, Eq)
 60 | 
 61 | hesh = Hesh {stdin_ = False &= help "If this option is present, or if no arguments remain after option process, then the script is read from standard input."
 62 |             ,no_sugar = False &= help "Don't expand syntax shortcuts."
 63 |             ,no_type_hints = False &= name "t" &= help "Don't add automatic type hints."
 64 |             ,compile_only = False &= help "Compile the script but don't run it."
 65 |             ,source_dir = def &= name "o" &= typDir &= help "Write to given directory instead of a temporary directory."
 66 |             ,source_only = False &= name "x" &= help "Generate expanded source code and cabal file only."
 67 |             ,verbose = False &= help "Display more information, such as Cabal output."
 68 |             ,package_index = def &= name "p" &= help "The cabal package index (normally ~/.cabal/packages/hackage.haskell.org/00-index.tar)"
 69 |             ,module_index = def &= name "m" &= help "The JSON package index (generated by hesh, normally ~/.cabal/packages/hackage.haskell.org/modules.json)"
 70 |             ,args_ = def &= args &= typ "FILE|ARG.."
 71 |             } &=
 72 |        help "Build/run a hesh script." &=
 73 |        summary ("Hesh v" ++ intercalate "." (map show heshCartelVersion))
 74 | 
 75 | heshCartelVersion = [1, 14, 0]
 76 | 
 77 | main = do
 78 |   opts <- cmdArgs hesh
 79 |   -- In order to work in shebang mode and to provide a more familiar
 80 |   -- commandline interface, we support taking the input filename as an
 81 |   -- argument (rather than just relying on the script being provided
 82 |   -- on stdin). If no commandline argument is provided, we assume the
 83 |   -- script is on stdin.
 84 |   let scriptFile = if stdin_ opts || null (args_ opts) then "<stdin>" else head (args_ opts)
 85 |       scriptName = if stdin_ opts || null (args_ opts) then "script" else takeBaseName (head (args_ opts))
 86 |   (source, args) <- if stdin_ opts || null (args_ opts)
 87 |                       then (\x -> (x, args_ opts)) `fmap` BS.getContents
 88 |                       else (\x -> (x, tail (args_ opts))) `fmap` BS.readFile (head (args_ opts))
 89 |   -- First, get the module -> package+version lookup table.
 90 |   hackagePath <- if null (package_index opts)
 91 |                    then hackagePath
 92 |                    else return (package_index opts)
 93 |   let modulePath = if null (module_index opts) then replaceFileName hackagePath "modules.json" else module_index opts
 94 |   modules <- fromFileCache modulePath (modulePackages hackagePath)
 95 |   let ast = (if no_type_hints opts then id else defaultToUnit) (parseScript scriptFile (no_sugar opts) source)
 96 |       -- Find all qualified module names to add module names to the import list (qualified).
 97 |       names = qualifiedNamesFromModule ast
 98 |       -- Find any import references.
 99 |       imports = importsFromModule ast
100 |       -- Remove aliased modules from the names.
101 |       aliases = catMaybes (map (\ (_, y, _) -> y) imports)
102 |       fqNames = filter (`notElem` aliases) (map fst names)
103 |       -- Insert qualified module usages back into the import list.
104 |       (Module a b pragmas d e importDecls g) = ast
105 |       expandedImports = importDecls ++ map importDeclQualified fqNames ++ if no_sugar opts then [] else (if isJust (find (\(m, _, _) -> m == "Hesh") imports) then [] else [importDeclUnqualified "Hesh"]) ++ if no_type_hints opts then [] else [importDeclQualified "Control.Monad.IO.Class"]
106 |       expandedPragmas = pragmas ++ if no_sugar opts then [] else sugarPragmas
107 |       expandedAst = Module a b expandedPragmas d e expandedImports g
108 |       -- From the imports, build a list of necessary packages.
109 |       -- First, remove fully qualified names that were previously
110 |       -- imported explicitly. This is so that we don't override the
111 |       -- package that might have been selected for that module
112 |       -- manually in the import statement.
113 |       packages = map (packageFromModules modules) (unionBy (\ (x, _, _) (x', _, _) -> x == x') imports (map fqNameModule fqNames) ++ if no_sugar opts then [] else [("Hesh", Nothing, Just "hesh")])
114 |       source' = BU.fromString $ prettyPrintWithMode (defaultMode { linePragmas = True }) expandedAst
115 |       cabal' = BU.fromString $ Cartel.Render.renderNoIndent (cartel opts packages scriptName)
116 |   dir <- if null (source_dir opts)
117 |            then (</> ("hesh-" ++ show (hash source' :: Digest MD5))) `liftM` getTemporaryDirectory
118 |            else return (source_dir opts)
119 |   let sourcePath = dir </> "Main.hs"
120 |       cabalPath = dir </> scriptName <.> "cabal"
121 |   -- Check if the source is different than what exists in the directory already.
122 |   oldSource <- catchAny (BS.readFile sourcePath) (\ _ -> return "")
123 |   oldCabal <- catchAny (BS.readFile cabalPath) (\ _ -> return "")
124 |   when (oldSource /= source' || oldCabal /= cabal') $ do
125 |     createDirectoryIfMissing False dir
126 |     BS.writeFile sourcePath source'
127 |     BS.writeFile cabalPath cabal'
128 |     -- Cabal will complain without a LICENSE file.
129 |     BS.writeFile (dir </> "LICENSE") ""
130 |   if (source_only opts)
131 |     then putStr dir
132 |     else do
133 |       let path = dir </> "dist/build" </> scriptName </> scriptName
134 |       binaryExists <- doesFileExist path
135 |       when (not binaryExists || oldSource /= source' || oldCabal /= cabal') $ do
136 |         callCommandInDir "cabal install --only-dependencies" dir (verbose opts)
137 |         callCommandInDir "cabal build" dir (verbose opts)
138 |       if (compile_only opts)
139 |         then putStr path
140 |         else executeFile path False args Nothing
141 |  where fqNameModule name = (name, Nothing, Nothing)
142 |        sugarPragmas = [LanguagePragma (SrcLoc "<generated>" 0 0) [Ident "TemplateHaskell", Ident "QuasiQuotes", Ident "PackageImports"]]
143 | 
144 | waitForSuccess :: String -> ProcessHandle -> Maybe Handle -> IO ()
145 | waitForSuccess cmd p out = do
146 |   code <- waitForProcess p
147 |   when (code /= ExitSuccess) $ do
148 |     case out of
149 |       Just o -> hPutStr stderr =<< hGetContents o
150 |       Nothing -> return ()
151 |     hPutStrLn stderr $ cmd ++ ": exited with code " ++ show code
152 |     exitFailure
153 | 
154 | callCommandInDir :: String -> FilePath -> Bool -> IO ()
155 | callCommandInDir cmd dir verbose' = do
156 |   -- GHC is noisy on stdout. It should go to stderr instead.
157 |   -- TODO: Move this into a more appropriate place. It just
158 |   -- happens to work here.
159 |   (_, out, _, p) <- createProcess (shell cmd) { cwd = Just dir, std_out = (if verbose' then UseHandle stderr else CreatePipe) }
160 |   waitForSuccess cmd p out
161 | 
162 | callCommand :: FilePath -> [String] -> IO ()
163 | callCommand path args = do
164 |   (_, _, _, p) <- createProcess (proc path args)
165 |   waitForSuccess path p Nothing
166 | 
167 | catchAny :: IO a -> (SomeException -> IO a) -> IO a
168 | catchAny = catch
169 | 
170 | -- Read a value from a cache (JSON-encoded file), writing it out if
171 | -- the cached value doesn't exist or is invalid.
172 | fromFileCache :: (FromJSON a, ToJSON a) => FilePath -> IO a -> IO a
173 | fromFileCache path f = do
174 |   catchAny readCached $ \ _ -> do
175 |     value <- f
176 |     catchAny (BL.writeFile path (encode value)) (\ _ -> return ())
177 |     return value
178 |  where readCached = do
179 |          d <- BL.readFile path
180 |          case decode d of
181 |            Just x -> return x
182 |            Nothing -> error "Failed to parse JSON."
183 | 
184 | qualifiedNamesFromModule :: Module -> [(String, String)]
185 | qualifiedNamesFromModule m = [ (mName, name) | Qual (ModuleName mName) (Ident name) <- universeBi m ]
186 | 
187 | -- This is a helper until Haskell has better defaulting (something like
188 | -- https://ghc.haskell.org/trac/haskell-prime/wiki/Defaulting).
189 | -- It saves adding "IO ()" type declarations in a number of common contexts.
190 | defaultToUnit :: Module -> Module
191 | defaultToUnit = transformBi defaultExpToUnit
192 |  where defaultExpToUnit :: Exp -> Exp
193 |        defaultExpToUnit (Do stmts) = Do (map defaultStmtToUnit stmts)
194 |        defaultExpToUnit exp = exp
195 |        defaultStmtToUnit (Qualifier exp) = Qualifier (defaultQualifiedExpToUnit exp)
196 |        defaultStmtToUnit stmt = stmt
197 |        defaultQualifiedExpToUnit exp = if canDefaultToUnit exp then defaultToUnit exp else exp
198 |        -- do [sh| ... |] => do [sh| ... |] :: IO ()
199 |        canDefaultToUnit (QuasiQuote f _) = f `elem` ["sh", "Hesh.sh"]
200 |        -- do cmd "..." [...] => do cmd "..." [...] :: IO ()
201 |        canDefaultToUnit (App (App (Var f) _) _) = f `elem` functionNames "cmd"
202 |        -- do ... /> "..." => ... /> "..." :: IO ()
203 |        canDefaultToUnit (InfixApp exp1 (QVarOp op) exp2) = op `elem` (concatMap operatorNames pipeOps)
204 |        canDefaultToUnit _ = False
205 |        defaultToUnit exp = ExpTypeSig (SrcLoc "<generated>" 0 0) exp (TyVar (Ident "(Control.Monad.IO.Class.MonadIO m) => m ()"))
206 |        functionNames name = [ UnQual (Ident name)
207 |                             , Qual (ModuleName "Hesh") (Ident name) ]
208 |        operatorNames name = [ UnQual (Symbol name)
209 |                             , UnQual (Ident ("(" ++ name ++ ")"))
210 |                             , Qual (ModuleName "Hesh") (Ident ("(" ++ name ++ ")")) ]
211 | 
212 | importsFromModule :: Module -> [(String, Maybe String, Maybe String)]
213 | importsFromModule (Module _ _ _ _ _ imports _) = map importName imports
214 |  where importName (ImportDecl _ (ModuleName m) _ _ _ pkg Nothing _) = (m, Nothing, pkg)
215 |        importName (ImportDecl _ (ModuleName m) _ _ _ pkg (Just (ModuleName n)) _) = (m, Just n, pkg)
216 | 
217 | importDeclQualified :: String -> ImportDecl
218 | importDeclQualified m = ImportDecl (SrcLoc "<generated>" 0 0) (ModuleName m) True False False Nothing Nothing Nothing
219 | 
220 | importDeclUnqualified :: String -> ImportDecl
221 | importDeclUnqualified m = ImportDecl (SrcLoc "<generated>" 0 0) (ModuleName m) False False False Nothing Nothing Nothing
222 | 
223 | packageFromModules modules (m, _, Just pkg)
224 |   | pkg == "hesh" = Cartel.package "hesh" (Cartel.eq heshCartelVersion)
225 |   | otherwise =
226 |       let parts = Text.splitOn "-" (Text.pack pkg)
227 |       in case parts of
228 |            [_] -> Cartel.package pkg Cartel.anyVersion
229 |            ps -> if Text.all (\c -> isDigit c || c == '.') (last ps)
230 |                    then let version = map (read . Text.unpack) (Text.splitOn "." (last ps))
231 |                             package = Text.unpack (Text.intercalate "-" (init ps))
232 |                         in Cartel.package package (Cartel.eq version)
233 |                    else Cartel.package pkg Cartel.anyVersion
234 | packageFromModules modules (m, _, Nothing)
235 |   | m == "Hesh" || isPrefixOf "Hesh." m = Cartel.package "hesh" (Cartel.eq heshCartelVersion)
236 |   | otherwise = constrainedPackage (Map.findWithDefault (error ("Module \"" ++ m ++ "\" not found in Hackage list.")) (Text.pack m) modules)
237 | 
238 | cartel opts packages name = mempty { Cartel.Ast.properties = properties
239 |                                    , Cartel.Ast.sections = [executable] }
240 |  where properties = mempty
241 |          { Cartel.name         = name
242 |          , Cartel.version      = [0,1]
243 |          , Cartel.cabalVersion = Just (fromIntegral 1, fromIntegral 18)
244 |          , Cartel.buildType    = Just Cartel.simple
245 |          , Cartel.license      = Just Cartel.allRightsReserved
246 |          , Cartel.licenseFile  = "LICENSE"
247 |          , Cartel.category     = "shell"
248 |          }
249 |        executable = Cartel.executable name fields
250 |        fields = [ Cartel.Ast.ExeMainIs "Main.hs"
251 |                 , Cartel.Ast.ExeInfo (Cartel.Ast.DefaultLanguage Cartel.Ast.Haskell2010)
252 |                 , Cartel.Ast.ExeInfo (Cartel.Ast.BuildDepends ([Cartel.package "base" Cartel.anyVersion] ++ packages))
253 |                 , Cartel.Ast.ExeInfo (Cartel.Ast.GHCOptions (["-threaded"]))
254 |                 ]
255 | 
256 | -- We make the simplifying assumption that a module only appears in a
257 | -- contiguous version range.
258 | data PackageConstraint = PackageConstraint { packageName :: Text.Text
259 |                                            , packageMinVersion :: [Int]
260 |                                            , packageMaxVersion :: [Int]
261 |                                            } deriving Generic
262 | 
263 | instance ToJSON PackageConstraint
264 | instance FromJSON PackageConstraint
265 | 
266 | -- PackageConstraint -> Package
267 | -- Always prefer base, otherwise arbitrarily take the first module.
268 | constrainedPackage ps = Cartel.package (Text.unpack (packageName package)) Cartel.anyVersion
269 |  where package = case find (\p -> packageName p == (Text.pack "base")) ps of
270 |                    Just p' -> p'
271 |                    Nothing -> head ps
272 | 
273 | modulePackages hackagePath = foldrWithKey buildConstraints Map.empty `liftM` readHackage' hackagePath
274 |  where buildConstraints name versions constraints = foldrWithKey (buildConstraints' name) constraints versions
275 |        buildConstraints' name version meta constraints = foldr (\m cs -> Map.alter (alterConstraint (Text.pack name) (V.versionBranch version)) m cs) constraints (map (Text.pack . display) (exposedModules' meta))
276 |        alterConstraint packageName' version constraint =
277 |          case constraint of
278 |            Nothing -> Just [PackageConstraint packageName' version version]
279 |            Just constraints ->
280 |              -- TODO: This could probably be more efficient.
281 |              case find (\c -> packageName c == packageName') constraints of
282 |                -- If the package is already listed, update the constraint.
283 |                Just _ -> Just (map (updateConstraint packageName' version) constraints)
284 |                -- If not, add a new constraint.
285 |                Nothing -> Just $ constraints ++ [PackageConstraint packageName' version version]
286 |        updateConstraint name version constraint = if packageName constraint == name
287 |                                                     then if version < packageMinVersion constraint
288 |                                                            then constraint { packageMinVersion = version }
289 |                                                            else if version < packageMaxVersion constraint
290 |                                                                   then constraint { packageMaxVersion = version }
291 |                                                                   else constraint
292 |                                                     else constraint
293 |        exposedModules' = fromMaybe [] . fmap (exposedModules . condTreeData) . condLibrary
294 | 
295 | parseScript :: String -> Bool -> BS.ByteString -> Module
296 | parseScript filename noSugar source =
297 |   case parseFileContentsWithMode
298 |        (defaultParseMode { parseFilename = filename
299 |                          , extensions = exts
300 |                          , fixities = Just (infixl_ 8 ["^..", "^?", "^?!", "^@..", "^@?", "^@?!", "^.", "^@."])})
301 |        source' of
302 |     ParseOk m -> m
303 |     r@(ParseFailed _ _) -> fromParseResult r
304 |  where exts = if noSugar then [] else [EnableExtension TemplateHaskell, EnableExtension QuasiQuotes, EnableExtension PackageImports]
305 |        source' = if noSugar then BU.toString source'' else desugar (BU.toString source'')
306 |        -- Remove any leading shebang line.
307 |        source'' = if B8.isPrefixOf "#!" source
308 |                     then B8.dropWhile (/= '\n') source
309 |                     else source
310 | 


--------------------------------------------------------------------------------
/lib/Hesh.hs:
--------------------------------------------------------------------------------
1 | module Hesh ( sh, cmd, (|>), (/>), (!>), (&>), (</), (/>>), (!>>), (&>>), (<//), (.=)
2 |             , passThrough
3 |             ) where
4 | 
5 | import Hesh.Process
6 | import Hesh.Shell
7 | 


--------------------------------------------------------------------------------
/lib/Hesh/Process.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DeriveDataTypeable #-}
  2 | {-# LANGUAGE FlexibleInstances #-}
  3 | {-# LANGUAGE UndecidableInstances #-}
  4 | {-# LANGUAGE RankNTypes #-}
  5 | {-# LANGUAGE ExistentialQuantification #-}
  6 | 
  7 | module Hesh.Process ( (|>), (/>), (!>), (&>), (</), (/>>), (!>>), (&>>), (<//), pipeOps
  8 |                     , ProcessFailure, cmd, passThrough, (.=)
  9 |                     ) where
 10 | 
 11 | import Control.Concurrent (forkIO)
 12 | import Control.Exception (Exception, bracketOnError)
 13 | import Control.Monad (liftM, void)
 14 | import Control.Monad.Catch (throwM)
 15 | import Control.Monad.IO.Class (MonadIO, liftIO)
 16 | import qualified Data.ByteString.Char8 as BS
 17 | import Data.Char (isSpace)
 18 | import Data.Maybe (fromJust)
 19 | import Data.Text (Text)
 20 | import qualified Data.Text as Text
 21 | import qualified Data.Text.IO as Text.IO
 22 | import Data.Typeable (Typeable)
 23 | import System.Exit (ExitCode(..))
 24 | import System.IO (openFile, IOMode(..), hGetContents, hClose, hPutStr, hPutStrLn, stderr, Handle)
 25 | import System.Process (proc, createProcess, CreateProcess(..), ProcessHandle, waitForProcess, StdStream(..), CmdSpec(..), readProcess, terminateProcess)
 26 | 
 27 | class Streamable a where
 28 |   s_hPutStr :: Handle -> a -> IO ()
 29 |   stdoutToStreamable :: (MonadIO m) => m ProcessChain -> m a
 30 | 
 31 | instance Streamable String where
 32 |   s_hPutStr = hPutStr
 33 |   stdoutToStreamable = stdoutToString
 34 | 
 35 | instance Streamable Text where
 36 |   s_hPutStr = Text.IO.hPutStr
 37 |   stdoutToStreamable = stdoutToText
 38 | 
 39 | instance Streamable BS.ByteString where
 40 |   s_hPutStr = BS.hPutStr
 41 |   stdoutToStreamable = stdoutToByteString
 42 | 
 43 | type RunningProcess = (String, ProcessHandle)
 44 | data ProcessChain = forall a . (Streamable a) => ProcessChain ([RunningProcess], (CreateProcess, Maybe a))
 45 | 
 46 | data ProcessFailure = ProcessFailure String Int
 47 |   deriving (Typeable)
 48 | 
 49 | instance Show ProcessFailure where
 50 |   show (ProcessFailure command code) = "Command " ++ command ++ " exited with failure code: " ++ show code
 51 | 
 52 | instance Exception ProcessFailure
 53 | 
 54 | pipeOps = ["|>", "/>", "!>", "&>", "</", "/>>", "!>>", "&>>", "<//"]
 55 | 
 56 | class PipeResult a where
 57 |   (|>) :: (MonadIO m) => m ProcessChain -> m ProcessChain -> m a
 58 |   (/>) :: (MonadIO m) => m ProcessChain -> FilePath -> m a
 59 |   (!>) :: (MonadIO m) => m ProcessChain -> FilePath -> m a
 60 |   (&>) :: (MonadIO m) => m ProcessChain -> FilePath -> m a
 61 |   (</) :: (MonadIO m) => m ProcessChain -> FilePath -> m a
 62 |   (/>>) :: (MonadIO m) => m ProcessChain -> FilePath -> m a
 63 |   (!>>) :: (MonadIO m) => m ProcessChain -> FilePath -> m a
 64 |   (&>>) :: (MonadIO m) => m ProcessChain -> FilePath -> m a
 65 |   (<//) :: (MonadIO m, Streamable s) => m ProcessChain -> s -> m a
 66 | 
 67 | instance {-# OVERLAPPING #-} PipeResult ProcessChain where
 68 |   (|>) = pipe
 69 |   (</) = redirect [Stdin] ReadMode
 70 |   (/>) = redirect [Stdout] WriteMode
 71 |   (!>) = redirect [Stderr] WriteMode
 72 |   (&>) = redirect [Stdout, Stderr] WriteMode
 73 |   (/>>) = redirect [Stdout] AppendMode
 74 |   (!>>) = redirect [Stderr] AppendMode
 75 |   (&>>) = redirect [Stdout, Stderr] AppendMode
 76 |   (<//) = readStreamable
 77 | 
 78 | instance {-# OVERLAPPING #-} PipeResult () where
 79 |   p1 |> p2 = passThrough (p1 |> p2)
 80 |   p /> path = passThrough (p /> path)
 81 |   p !> path = passThrough (p !> path)
 82 |   p &> path = passThrough (p &> path)
 83 |   p </ path = passThrough (p </ path)
 84 |   p />> path = passThrough (p />> path)
 85 |   p !>> path = passThrough (p !>> path)
 86 |   p &>> path = passThrough (p &>> path)
 87 |   p <// input = passThrough (p <// input)
 88 | 
 89 | instance {-# OVERLAPPING #-} (Streamable s) => PipeResult s where
 90 |   p1 |> p2 = stdoutToStreamable (p1 |> p2)
 91 |   p /> path = stdoutToStreamable (p /> path)
 92 |   p !> path = stdoutToStreamable (p !> path)
 93 |   p &> path = stdoutToStreamable (p &> path)
 94 |   p </ path = stdoutToStreamable (p </ path)
 95 |   p />> path = stdoutToStreamable (p />> path)
 96 |   p !>> path = stdoutToStreamable (p !>> path)
 97 |   p &>> path = stdoutToStreamable (p &>> path)
 98 |   p <// input = stdoutToStreamable (p <// input)
 99 | 
100 | -- cmd is like proc but operates on the resulting process depending on
101 | -- its calling context.
102 | class ProcResult a where
103 |   cmd :: (MonadIO m) => FilePath -> [String] -> m a
104 | 
105 | instance ProcResult ProcessChain where
106 |   cmd path args = return $ ProcessChain ([], (proc path args, Nothing :: Maybe String))
107 | 
108 | instance ProcResult () where
109 |   cmd path args = passThrough (cmd path args)
110 | 
111 | instance ProcResult String where
112 |   cmd path args = stdoutToString (cmd path args)
113 | 
114 | instance ProcResult Text where
115 |   cmd path args = stdoutToText (cmd path args)
116 | 
117 | instance ProcResult BS.ByteString where
118 |   cmd path args = stdoutToByteString (cmd path args)
119 | 
120 | waitForSuccess :: [RunningProcess] -> IO ()
121 | waitForSuccess hs = mapM_ waitForSuccess' hs
122 |  where waitForSuccess' (name, handle) = do
123 |          exit <- waitForProcess handle
124 |          case exit of
125 |            ExitSuccess -> return ()
126 |            ExitFailure code -> throwM (ProcessFailure name code)
127 | 
128 | withProcess :: Streamable s => CreateProcess -> Maybe s -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
129 | withProcess p s f =
130 |   bracketOnError (createProcess $ maybe p (\ _ -> p { std_in = CreatePipe }) s)
131 |                  (\ (_, _, _, h) -> do terminateProcess h)
132 |                  (\ x@(i, o, e, h) -> case s of
133 |                                         Nothing -> f x
134 |                                         Just s' -> do forkIO $ do
135 |                                                         s_hPutStr (fromJust i) s'
136 |                                                         hClose (fromJust i)
137 |                                                       f (Nothing, o, e, h))
138 | 
139 | commandName :: CreateProcess -> String
140 | commandName p = let (RawCommand command _) = cmdspec p in command
141 | 
142 | passThrough :: (MonadIO m) => m ProcessChain -> m ()
143 | passThrough p' = do
144 |   ProcessChain (ps, (p, s)) <- p'
145 |   liftIO (withProcess p s (\ (_, _, _, pHandle) -> waitForSuccess (ps ++ [(commandName p, pHandle)])))
146 | 
147 | -- TODO: Remove duplication from these functions.
148 | stdoutToString :: (MonadIO m) => m ProcessChain -> m String
149 | stdoutToString p' = do
150 |   ProcessChain (ps, (p, s)) <- p'
151 |   liftIO (withProcess (p { std_out = CreatePipe }) s
152 |                       (\ (_, Just pStdout, _, pHandle) -> do output <- hGetContents pStdout
153 |                                                              waitForSuccess (ps ++ [(commandName p, pHandle)])
154 |   -- Strip any trailing newline. These are almost always added to
155 |   -- programs since shells don't add their own newlines, and it's a
156 |   -- surprise to get these when reading a program's output.
157 |                                                              if not (null output) && last output == '\n'
158 |                                                                then return (init output)
159 |                                                                else return output))
160 | 
161 | stdoutToText :: (MonadIO m) => m ProcessChain -> m Text
162 | stdoutToText p' = do
163 |   ProcessChain (ps, (p, s)) <- p'
164 |   liftIO (withProcess (p { std_out = CreatePipe }) s
165 |                       (\ (_, Just pStdout, _, pHandle) -> do output <- Text.IO.hGetContents pStdout
166 |                                                              waitForSuccess (ps ++ [(commandName p, pHandle)])
167 |   -- Strip any trailing newline. These are almost always added to
168 |   -- programs since shells don't add their own newlines, and it's a
169 |   -- surprise to get these when reading a program's output.
170 |                                                              if not (Text.null output) && Text.last output == '\n'
171 |                                                                then return (Text.init output)
172 |                                                                else return output))
173 | 
174 | stdoutToByteString :: (MonadIO m) => m ProcessChain -> m BS.ByteString
175 | stdoutToByteString p' = do
176 |   ProcessChain (ps, (p, s)) <- p'
177 |   liftIO (withProcess (p { std_out = CreatePipe }) s
178 |                       (\ (_, Just pStdout, _, pHandle) -> do output <- BS.hGetContents pStdout
179 |                                                              waitForSuccess (ps ++ [(commandName p, pHandle)])
180 |   -- Strip any trailing newline. These are almost always added to
181 |   -- programs since shells don't add their own newlines, and it's a
182 |   -- surprise to get these when reading a program's output.
183 |                                                              if not (BS.null output) && BS.last output == '\n'
184 |                                                                then return (BS.init output)
185 |                                                                else return output))
186 | 
187 | pipe :: (MonadIO m) => m ProcessChain -> m ProcessChain -> m ProcessChain
188 | pipe p1' p2' = do
189 |   ProcessChain (ps1, (p1, s1)) <- p1'
190 |   ProcessChain (ps2, (p2, _)) <- p2'
191 |   liftIO (withProcess (p1 { std_out = CreatePipe }) s1
192 |                       (\ (_, Just p1Stdout, _, p1Handle) -> return $ ProcessChain (ps1 ++ [(commandName p1, p1Handle)] ++ ps2, (p2 { std_in = UseHandle p1Stdout }, Nothing :: Maybe String))))
193 | 
194 | readStreamable :: (MonadIO m, Streamable s) => m ProcessChain -> s -> m ProcessChain
195 | readStreamable p' s = do
196 |   ProcessChain (ps, (p, _)) <- p'
197 |   return $ ProcessChain (ps, (p, Just s))
198 | 
199 | data StdHandle = Stdin | Stdout | Stderr deriving (Eq)
200 | 
201 | redirect :: (MonadIO m) => [StdHandle] -> IOMode -> m ProcessChain -> FilePath -> m ProcessChain
202 | redirect handles mode p' path = do
203 |   ProcessChain (ps, (p, s)) <- p'
204 |   f <- liftIO (openFile path mode)
205 |   return (case handles of
206 |              [Stdin] -> ProcessChain (ps, (p { std_in = UseHandle f }, s))
207 |              [Stdout] -> ProcessChain (ps, (p { std_out = UseHandle f }, s))
208 |              [Stderr] -> ProcessChain (ps, (p { std_err = UseHandle f }, s))
209 |              [Stdout, Stderr] -> ProcessChain (ps, (p { std_out = UseHandle f, std_err = UseHandle f }, s)))
210 |   -- TODO: Close handle(s).
211 | 
212 | -- I'm not sure that I want this to stick around, so I'm not
213 | -- documenting it. If it's common enough, it's worth keeping. If not,
214 | -- it might just be confusing.
215 | (.=) :: (MonadIO m) => m String -> m String -> m Bool
216 | (.=) lhs' rhs' = do
217 |   lhs <- lhs'
218 |   rhs <- rhs'
219 |   return (lhs == rhs)
220 | 


--------------------------------------------------------------------------------
/lib/Hesh/Shell.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE TemplateHaskell #-}
  2 | {-# LANGUAGE QuasiQuotes #-}
  3 | 
  4 | module Hesh.Shell (sh, desugar) where
  5 | 
  6 | import Control.Applicative ((<$>), (*>), (<*))
  7 | import Control.Monad.IO.Class (liftIO)
  8 | import Data.Char (isSpace, isAlphaNum)
  9 | import Language.Haskell.TH (Q, location, Name, mkName, newName, stringL, litE, varE, listE, varP)
 10 | import Language.Haskell.TH.Quote (QuasiQuoter(..), dataToExpQ)
 11 | import Language.Haskell.TH.Syntax (Exp(..), Lit(..), Loc(..))
 12 | import System.Environment (getEnv)
 13 | import System.FilePath.Glob (namesMatching)
 14 | import System.Process (proc)
 15 | import Text.Parsec (parse)
 16 | import Text.Parsec.Char (space, spaces, char, string, noneOf, satisfy, lower, upper)
 17 | import Text.Parsec.Combinator (eof, sepEndBy1, many1, between)
 18 | import Text.Parsec.Pos (SourcePos, newPos)
 19 | import Text.Parsec.Prim (setPosition, many, (<|>), (<?>), try)
 20 | import Text.Parsec.String (Parser)
 21 | 
 22 | import qualified Hesh.Process
 23 | 
 24 | sh :: QuasiQuoter
 25 | sh = QuasiQuoter heshExp undefined undefined undefined
 26 | 
 27 | heshExp :: String -> Q Exp
 28 | heshExp s = do
 29 |   l <- location'
 30 |   case parse (setPosition l *> topLevel tokensP) "unknown" s of
 31 |     Left err -> error ("parse error: " ++ show err)
 32 |     Right tokens -> cmdExp tokens []
 33 | 
 34 | -- We need to be able to expand some arguments in the IO monad, so
 35 | -- each argument is expanded and bound until we finally evaluate the
 36 | -- command.
 37 | cmdExp :: [String] -> [Name] -> Q Exp
 38 | cmdExp [] vars = [| let tokens = concat $(listE (map varE (reverse vars)))
 39 |                     in Hesh.Process.cmd (head tokens) (tail tokens) |]
 40 | cmdExp (t:ts) vars = do
 41 |   case parse fragmentsP "unknown" t of
 42 |     Left err -> error ("parse error while parsing token \"" ++ t ++ "\": " ++ show err)
 43 |     Right fragments -> do
 44 |       -- We have a list of fragments. We need to expand all of the
 45 |       -- environment variables in the IO monad. The easiest way seems
 46 |       -- to be to just build a list of variables and use return for any
 47 |       -- non-monadic expansions.
 48 |       x <- newName "x"
 49 |       [| ($(fragmentsExp fragments [])) >>= \ $(varP x) -> $(cmdExp ts (x:vars)) |]
 50 | 
 51 | data Fragment = FragmentString String | FragmentIdentifier String | FragmentEnvVar String
 52 | 
 53 | -- This uses a similar recursive monad statement binding technique as cmdExp
 54 | fragmentsExp :: [Fragment] -> [Name] -> Q Exp
 55 | fragmentsExp [] vars = [| return [concat $(listE (map varE (reverse vars)))] |]
 56 | fragmentsExp (f:fs) vars = do
 57 |   x <- newName "y"
 58 |   [| $(fragmentExp f) >>= \ $(varP x) -> $(fragmentsExp fs (x:vars)) |]
 59 | 
 60 | fragmentExp :: Fragment -> Q Exp
 61 | fragmentExp (FragmentString s) = [| return $(litE (stringL s)) |]
 62 | fragmentExp (FragmentIdentifier i) = [| return $(varE (mkName i)) |]
 63 | fragmentExp (FragmentEnvVar e) = [| liftIO (getEnv $(litE (stringL e))) |]
 64 | 
 65 | fragmentsP :: Parser [Fragment]
 66 | fragmentsP = many (try (variableP >>= \x -> case x of
 67 |                                               Left i -> return (FragmentIdentifier i)
 68 |                                               Right e -> return (FragmentEnvVar e))
 69 |                <|> (many1 (onlyEscapedP '$') >>= return . FragmentString))
 70 | 
 71 | -- Variables must match valid Haskell identifier names.
 72 | -- Any variable beginning with an uppercase character is assumed to be an environment variable.
 73 | -- Use of undefined variables throws an error.
 74 | -- Left => normal variable (can be referenced immediately)
 75 | -- Right => environment variable (must be looked up at runtime)
 76 | variableP :: Parser (Either String String)
 77 | variableP = do
 78 |   char '$'
 79 |   (try (between (char '{') (char '}') variable) <|> variable)
 80 |  where variable = (try identifier <|> envVariable)
 81 |        -- This doesn't cover all possible environment variable names, but it removes ambiguity.
 82 |        identifier = do
 83 |          x <- lower
 84 |          xs <- many (satisfy (\c -> isAlphaNum c || c == '\''))
 85 |          return (Left (x:xs))
 86 |        envVariable = do
 87 |          x <- upper
 88 |          xs <- many (satisfy (\c -> isAlphaNum c || c == '_'))
 89 |          return (Right (x:xs))
 90 | 
 91 | tokensP :: Parser [String]
 92 | tokensP = do
 93 |   spaces
 94 |   tokens <- sepEndBy1 token spaces
 95 |   return tokens
 96 |  where token = do parts <- many1 (try quotedP <|> unquotedP)
 97 |                   return (concat parts)
 98 | 
 99 | quotedP = do
100 |   char '"'
101 |   xs <- many (onlyEscapedP '"')
102 |   char '"'
103 |   return xs
104 |  <?> "quoted string"
105 | 
106 | unquotedP = many1 (satisfy (\c -> not (isSpace c) && c /= '"'))
107 | 
108 | onlyEscapedP :: Char -> Parser Char
109 | onlyEscapedP c = try (string ['\\', c] >> return c) <|> satisfy (/= c)
110 | 
111 | topLevel :: Parser a -> Parser a
112 | topLevel p = spaces *> p <* (spaces *> eof)
113 | 
114 | location' :: Q SourcePos
115 | location' = aux <$> location
116 |   where
117 |     aux :: Loc -> SourcePos
118 |     aux loc = uncurry (newPos (loc_filename loc)) (loc_start loc)
119 | 
120 | -- The following parsers are for use by hesh before passing the script to the compiler.
121 | 
122 | desugar :: String -> String
123 | desugar s =
124 |   case parse sugarP "" s of
125 |     Left err -> error ("parse error: " ++ show err)
126 |     Right fragments -> concat fragments
127 | 
128 | sugarP :: Parser [String]
129 | sugarP = many
130 |   (   try shSugarP
131 |   <|> try (string "$")
132 |   <|> (many1 (noneOf "$"))
133 |   )
134 | 
135 | -- syntactic sugar
136 | -- $() => [sh| |]
137 | shSugarP :: Parser String
138 | shSugarP = do
139 |   string "$("
140 |   xs <- many (onlyEscapedP ')')
141 |   char ')'
142 |   return ("[sh|" ++ xs ++ "|]")
143 | 


--------------------------------------------------------------------------------
/manual/manual.md:
--------------------------------------------------------------------------------
  1 | % Using Hesh, the Haskell-Extensible Shell
  2 | % Chris Forno
  3 | % 2015-04-18
  4 | 
  5 | Hesh makes writing scripts in Haskell easier. Here's an example:
  6 | 
  7 | ``` {.haskell .numberLines}
  8 | #!/usr/bin/env hesh
  9 | -- Backup a PostgreSQL database to an encrypted file.
 10 | 
 11 | main = do
 12 |   args <- System.Environment.getArgs
 13 |   case args of
 14 |     [database] -> do
 15 |       today <- $(date +%Y-%m-%d)
 16 |       let file = database ++ "-" ++ today ++ ".sql.gpg"
 17 |       $(pg_dump $database) |> $(gpg -e -r $EMAIL) /> file
 18 |     _ -> do
 19 |       progName <- System.Environment.getProgName
 20 |       $(echo "Usage: $progName <database>") /> "/dev/stderr"
 21 | ```
 22 | 
 23 | Let's look at how this differs from standard Haskell.
 24 | 
 25 | * On line 1, hesh is used like runhaskell to start the script without previous compilation.
 26 | * On line 5, the call to `System.Environment.getArgs` has no accompanying qualified import.
 27 | * On line 8, `$()` is used to execute a command and read its output into a variable (like Bash's `$()`).
 28 | * On line 10, `$()` is used again, this time with a variable substitution (`$database`). However, instead of reading the result of the command into a variable, standard output is piped (`|>`) to another command. The output of that command is redirected (`/>`) to a file.
 29 | 
 30 | # Hesh as a Shell
 31 | 
 32 | Hesh is not an interactive shell.[^interactive] It's intended only for scripts. It's designed to reduce the verbosity of Haskell for shell-script-style tasks enough to make it a viable alternative to Bash.[^compatibility]
 33 | 
 34 | Hesh implements some of the functionality you'd expect from a shell, such as process spawning, I/O redirection, and variable substitution. For the rest, you can rely on Haskell and its libraries.
 35 | 
 36 | ## Spawning Processes
 37 | 
 38 | Spawning a process with `$()` behaves somewhat similar to what you'd expect from other shells, but is designed to be minimal.[^nesting] It interprets its contents in 3 steps:
 39 | 
 40 | 1. separate into tokens on whitespace (excluding [quoted](#quoting) whitespace)
 41 | 2. expand variables
 42 | 3. spawn the command specified by the first token with all folowing tokens as arguments
 43 | 
 44 | `$()` returns either a `String`{.haskell}, a `CreateProcess`{.haskell}, or `()`{.haskell} (all in a `MonadIO`{.haskell} monad), depending on the context. This---along with some proprocessing Hesh does before compiling your script---helps make sure it behaves as you'd expect in most cases.
 45 | 
 46 | ### Quoting
 47 | 
 48 | If you want a string containing whitespace to be passed as a single argument to a program, you must quote it with double-quotes (`""`). To use a quote inside double quotes, escape it with a backslash (`\"`).
 49 | 
 50 | ### Variable Expansion
 51 | 
 52 | `$()` expands any variable reference of the form `$variableName` or `${variableName}` (the latter allows for placing variables next to each other or within a string of text, like `${var1}${var2}` or `computer${suffix}`). If you want to include a literal `$`, escape it with a backslash (`\$`).
 53 | 
 54 | Variables must be valid Haskell identifiers (excluding infix operators),[^haskellvariables] such as `$varName` or `$val'`. For convenience, if the variable begins with an uppercase character, it's assumed to be an environment variable name and substituted with the corresponding environment variable.[^environmentvariables]
 55 | 
 56 | Note that variables are expanded *after* tokenization. This means that you don't have to worry about a variable containing whitespace: it will still be passed as a single argument (unlike with Bash). For example, in:
 57 | 
 58 | ```haskell
 59 | let var = "a filename with spaces"
 60 | in $(ls $var)
 61 | ```
 62 | 
 63 | the `ls` program will be called with a single argument, not with 4 arguments.
 64 | 
 65 | ### Argument Lists
 66 | 
 67 | If you already have a list of arguments you'd like to pass to a program, you can use `cmd` instead of `$()`. `$()` itself invokes `cmd` after tokenization and variable expansion. The following 2 examples are equivalent:
 68 | 
 69 | ```haskell
 70 | $(ls a b c)
 71 | ```
 72 | 
 73 | ```haskell
 74 | cmd "ls" ["a", "b", "c"]
 75 | ```
 76 | 
 77 | ## Redirecting I/O
 78 | 
 79 | `|>`
 80 | 
 81 | :   Pipes the output of the process on the left to the input of the process on the right.[^pipestderr] This behaves the same as Bash's `|` (but is named differently to prevent clashing with Haskell's `|`).
 82 | 
 83 | `/>`
 84 | 
 85 | :   Redirects the output of a process to a file. This behaves the same as Bash's `>` (again named differently to prevent clashing with Haskell's `>`).
 86 | 
 87 | `!>`
 88 | 
 89 | :   Redirects stderr of a process to a file. This behaves the same as Bash's `2>` (which is not a valid identifier in Haskell).
 90 | 
 91 | `&>`
 92 | 
 93 | :   Redirects both stdout and stderr of a process to a file. This behaves the same as Bash's `&>`.
 94 | 
 95 | `</`
 96 | 
 97 | :   Read a file as input to a process. This behaves the same as Bash's `<`.
 98 | 
 99 | `<//`
100 | 
101 | :   Read a String (or Text or strict ByteString) as input to a process. Note that this requires the program to be compiled with `-threaded` (the default if executed by `hesh` itself).
102 | 
103 | All of these functions are available via the `Hesh` library (which is automatically imported for use in Hesh scripts), so you can also use them in your non-Hesh Haskell programs.[^sugar]
104 | 
105 | Each output operator (`/>`, `!>`, `&>`) has an append version (`/>>`, `!>>`, `&>>`) that will append to the given output file instead of overwriting it (like bash's `>>`).
106 | 
107 | # Hesh as a Compiler
108 | 
109 | You can use Hesh to compile native binaries. In fact, that's what Hesh is doing each time it evaluates your script:
110 | 
111 | 1. pre-process the script
112 | 2. generate a Cabal file
113 | 3. run Cabal build in a temporary directory[^tmpdir]
114 | 4. execute the resulting binary
115 | 
116 | Normally when you run hesh it will automatically execute the given script (if it compiles successfully). If you use the `-c` option, hesh will only compile the script and output the resulting executable to stdout.
117 | 
118 | ## Preprocessing
119 | 
120 | Hesh's first feature was its automatic Cabal file generation. Without it, your scripts would be limited to the base libraries. From there, the preprocessor evolved hand-in-hand with Hesh's shell functions in order to make writing scripts feel as natural as possible. The preprocessor does the following:
121 | 
122 | 1. desugars `$()` into `[sh||]` quasiquotes[^nosugar]
123 | 2. finds all uses of qualified names and adds them to the import list (e.g. `System.Environment.getArgs`)
124 | 3. looks in the Hackage database for any modules imported and adds them to the generated Cabal file
125 | 4. adds a type signature to `$()` in certain common contexts
126 | 
127 | ## Hesh and Hackage
128 | 
129 | The first time you run Hesh, it will take a while. That's because it's parsing the Hackage database (the one created by `cabal update`) and converting it into a more convient form for future runs.[^hackagecache] Hesh uses this database to look up which package a module belongs to.
130 | 
131 | Hesh uses a very simplistic method of looking up packages and specifying package version constraints. In particular, its behavior is undefined if more than 1 package exports a module with the same name. In order to disambiguate between packages that export the same module, you can use package-qualified imports.[^packageimports] For example, to import the vector package implementation of Data.Vector, use `import "vector" Data.Vector`.
132 | 
133 | [^interactive]: Hesh is on its way to becoming an interactive shell, but there are non-trivial obstacles to making it one.
134 | 
135 | [^compatibility]: If it wasn't obvious, Hesh is not Bash-compatible, even though it borrows some of its syntax.
136 | 
137 | [^sugar]: Note that `$()` is syntactic sugar for Hesh's `sh` quasiquoter, so you have to convert all instances of `$(command)` to `[sh|command|]` if you use the Hesh library outside of Hesh.
138 | 
139 | [^pipestderr]: As with Bash, piping does not affect stderr.
140 | 
141 | [^nesting]: `$()` does not currently support nesting.
142 | 
143 | [^haskellvariables]: Allowed variable names start with any lowercase Unicode character followed by any number of Unicode alphanumeric characters and/or apostrophes (`'`).
144 | 
145 | [^environmentvariables]: Allowed environment variable names start with any uppercase Unicode character followed by any number of Unicode alphanumeric characters and/or underscores (`_`). If you want to reference an environment variable that doesn't begin with an uppercase character, you'll need to read it into a Haskell variable via `System.Environment.getEnv` first.
146 | 
147 | [^tmpdir]: A new temporary directory is created every time the script changes. Hesh used to also use a Cabal sandbox to try to mitigate dependency problems, but the result was found to be too expensive while developing and testing scripts.
148 | 
149 | [^nosugar]: Desugaring activates the TemplateHaskell and QuasiQuotes Haskell extensions. You can skip this desugaring by passing the `--no-sugar` or `-n` option to Hesh.
150 | 
151 | [^hackagecache]: The modules from the Hackage database is cached in `modules.json` in your Hackage path (usually `packages/hackage.haskell.org` in your `.cabal` directory).
152 | 
153 | [^packageimports]: See [http://haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#package-imports](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#package-qualified-imports) for more details.
154 | 


--------------------------------------------------------------------------------
/manual/manual.pdf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jekor/hesh/58e46c41154e20366be63974a8f1328632a42ef6/manual/manual.pdf


--------------------------------------------------------------------------------