THSH (empty) → 0.0.0.1
raw patch · 14 files changed
+1145/−0 lines, 14 filesdep +PyFdep +THSHdep +base
Dependencies added: PyF, THSH, base, extra, filepath, ghc, parsec, process, split, template-haskell, temporary, text, transformers
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- THSH.cabal +128/−0
- loader/main.hs +153/−0
- src/THSH.hs +11/−0
- src/THSH/Fn.hs +105/−0
- src/THSH/Funclet.hs +34/−0
- src/THSH/Internal/HsExprUtils.hs +53/−0
- src/THSH/Internal/ProcessUtils.hs +44/−0
- src/THSH/Internal/PyFInternals.hs +164/−0
- src/THSH/Internal/THUtils.hs +79/−0
- src/THSH/QQ.hs +118/−0
- src/THSH/Script.hs +162/−0
- test/Main.hs +69/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for THSH++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2024 Miao, ZhiCheng++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.
+ THSH.cabal view
@@ -0,0 +1,128 @@+cabal-version: 3.4+-- The cabal-version field refers to the version of the .cabal specification,+-- and can be different from the cabal-install (the tool) version and the+-- Cabal (the library) version you are using. As such, the Cabal (the library)+-- version used must be equal or greater than the version stated in this field.+-- Starting from the specification version 2.2, the cabal-version field must be+-- the first thing in the cabal file.++-- Initial package description 'THSH' generated by+-- 'cabal init'. For further documentation, see:+-- http://haskell.org/cabal/users-guide/+--+-- The name of the package.+name: THSH++-- The package version.+-- See the Haskell package versioning policy (PVP) for standards+-- guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.0.0.1++-- A short (one-line) description of the package.+synopsis: A "noDSL" approach to mixing shell scripting with Haskell programs using Template Haskell++-- A longer description of the package.+-- description:++-- The license under which the package is released.+license: MIT++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Miao, ZhiCheng++-- An email address to which users can send suggestions, bug reports, and patches.+maintainer: zhicheng.miao@gmail.com++-- A copyright notice.+-- copyright:+category: System+build-type: Simple++-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.+extra-doc-files: CHANGELOG.md++-- Extra source files to be distributed with the package, such as examples, or a tutorial module.+-- extra-source-files:++common warnings+ ghc-options: -Wall++common extensions+ -- GHC2021 is enabled since 9.2.1 (https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/control.html)+ default-language: GHC2021+ default-extensions: LambdaCase+ MultiWayIf++common base-deps+ build-depends: ghc >= 9.2.0,+ base >= 4.17.0.0 && <= 9999.0.0.0,+ template-haskell+++library+ import: warnings, extensions, base-deps++ -- Modules exported by the library.+ exposed-modules: THSH.Funclet+ THSH.Script+ THSH.Fn+ THSH.QQ+ THSH++ -- Modules included in this library but not exported.+ other-modules: THSH.Internal.THUtils+ THSH.Internal.HsExprUtils+ THSH.Internal.PyFInternals+ THSH.Internal.ProcessUtils++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ -- Other library packages from which modules are imported.+ build-depends: text,+ transformers,+ PyF,+ parsec,+ filepath,+ process,+ temporary++ -- Directories containing source files.+ hs-source-dirs: src++executable thsh+ import: warnings, extensions, base-deps+ main-is: main.hs+ build-depends: THSH,+ extra,+ split,+ filepath,+ process,+ PyF+ hs-source-dirs: loader++test-suite THSH-test+ import: warnings, extensions, base-deps++ -- The interface type and version of the test suite.+ type: exitcode-stdio-1.0++ -- Modules included in this executable, other than Main.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ main-is: Main.hs+ build-depends:+ base >=4.17.0.0,+ PyF,+ THSH+ hs-source-dirs: test
+ loader/main.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE QuasiQuotes #-}+module Main where++import Data.Function ((&))+import Data.List (intercalate)+import System.Console.GetOpt (ArgDescr (..), ArgOrder (Permute), OptDescr (..), getOpt, usageInfo)+import System.Environment (getArgs, lookupEnv)+import System.Exit (ExitCode (..), exitWith)+import System.IO (IOMode (..), hGetLine, hIsEOF, hPutStr, hPutStrLn, stderr, withFile)+import Text.Read (readMaybe)+-- split+import Data.List.Split (splitOn)+-- extra+import Data.List.Extra (trimEnd)+-- filepath+import System.FilePath (dropFileName, splitExtension, takeFileName, (</>))+-- process+import System.Process (proc, waitForProcess, withCreateProcess)+-- PyF+import PyF (fmt)+++oops :: String -> IO a+oops msg = hPutStrLn stderr msg >> exitWith (ExitFailure 1)++main :: IO ExitCode+main = do+ (options, args) <- getArgs >>= parseArgs++ -- digest options and arguments+ let verbosity = getVerbosity options+ (scriptFile:argv) <- if length args < 1 then oops "A script file is required."+ else pure args++ thshFile <- genTHSHFile options scriptFile++ withCreateProcess+ (proc "cabal" ([ "run", "-v" ++ show verbosity, thshFile, "--"] <> argv))+ (\_ _ _ ph -> waitForProcess ph)++{- INTERNAL FUNCTIONS -}++helpHeader :: String+helpHeader = "Usage: thsh script [OPTION...] [--] [args...]"++data Flag = Verbosity !Int -- valid values: 0..3; invalid values -> -1+ | UseLanguageEdition String+ | DisableBlockArguments+ | PrintHelp+ deriving (Show, Eq)+optsDescr :: [OptDescr Flag]+optsDescr = [ Option ['v'] ["verbose"] (ReqArg verbp "VERBOSITY")+ "Control verbosity (n is 0--3, default is 1)."+ , Option ['l'] ["language"] (ReqArg UseLanguageEdition "LANG")+ "Language edition used, default is GHC2021."+ , Option [] ["disable-block-arguments"] (NoArg DisableBlockArguments)+ "Disable block arguments extensions, ffs."+ , Option ['h'] ["help"] (NoArg PrintHelp)+ "Print this help message."+ ]+ where verbp p = Verbosity $ case readMaybe p of Just a | a >= 0 && a <=3 -> a | otherwise -> -1; Nothing -> -1+getVerbosity :: [Flag] -> Int+getVerbosity (Verbosity a:_) = a+getVerbosity (_:os) = getVerbosity os+getVerbosity [] = 1+getLanguageEdition :: [Flag] -> String+getLanguageEdition (UseLanguageEdition a:_) = a+getLanguageEdition (_:os) = getLanguageEdition os+getLanguageEdition [] = "GHC2021"++parseArgs :: [String] -> IO ([Flag], [String])+parseArgs rawArgs = case getOpt Permute optsDescr rawArgs of+ (options, args, []) -> do+ if PrintHelp `elem` options+ then putStr usageInfoText >> exitWith ExitSuccess+ else if getVerbosity options == -1 then oops ("Error: invalid verbosity number.\n" ++ usageInfoText)+ else pure (reverse options, args) -- reverse the options so that it takes latter options as the effective ones+ (_ ,_ , errs) -> oops (concat errs ++ usageInfoText)+ where usageInfoText = usageInfo helpHeader optsDescr++-- | Read and split script file into (strippedScript, cabalMetadata, projectMetadata)+readScriptFile :: FilePath -> IO (String, String, String)+readScriptFile filePath = withFile filePath ReadMode $ go ("", "", "") (0 :: Int)+ where go results mode = \hdl ->+ hIsEOF hdl >>= \case+ True -> pure results -- short circuit when eof+ False -> hGetLine hdl >>= pure . trimEnd >>= \line -> case () of+ _ | line == "{- cabal:" ->+ if mode == 0 then go results 1 hdl+ else oops "Error: unexpected cabal metadata section start"+ | line == "{- project: " ->+ if mode == 0 then go results 2 hdl+ else oops "Error: unexpected project metadata section start"+ | line == "-}" ->+ if mode /= 0 then go results 0 hdl+ else oops "Error: unexpected metadata section close"+ | otherwise -> go results mode hdl >>= pure . add_line mode line+ add_line 0 line (c0, c1, c2) = (line ++ "\n" ++ c0, c1, c2)+ add_line 1 line (c0, c1, c2) = (c0, line ++ "\n" ++ c1, c2)+ add_line 2 line (c0, c1, c2) = (c0, c1, line ++ "\n" ++ c2)+ add_line _ _ _ = error "bad mode"++genTHSHFile :: [Flag] -> FilePath -> IO FilePath+genTHSHFile options scriptFile = do+ withFile thshFile WriteMode+ (\hdl -> do+ contents <- readScriptFile scriptFile+ hPutStr hdl =<< genTHSH options contents+ pure thshFile+ ) where thshFile = splitExtension scriptFile+ & \(a, b) -> dropFileName a </> "." ++ takeFileName a ++ ".thsh" ++ b++genTHSH :: [Flag] -> (String, String, String) -> IO String+genTHSH options (strippedScript, cabalMeta, projectMeta) =+ lookupEnv "THSH_EXTRA_PACKAGE_DBS"+ >>= (\case Just env -> pure $ Just $ splitOn ":" env+ Nothing -> pure Nothing+ )+ >>= \extraPackageDBs -> let extraPackageDBsLine = case extraPackageDBs of+ Nothing -> ""+ Just dbs -> "package-dbs: " ++ intercalate ",\n " dbs+ langEdition = getLanguageEdition options+ extraLangOptions =+ if DisableBlockArguments `elem` options then [] else ["BlockArguments"]+ <> [ "LambdaCase" ]+ in pure [fmt|\+{{- cabal:+build-depends: base, THSH, PyF+default-language: { langEdition }+-- ! BEGIN USER CABAL METADATA+{ cabalMeta }+-- ! END USER CABAL METADATA+-}}+{{- project:+{ extraPackageDBsLine }+-- ! BEGIN USER PROJECT METADATA+{ projectMeta }+-- ! END USER PROJECT METADATA+-}}+{{-# LANGUAGE QuasiQuotes #-}}+{{-# LANGUAGE { intercalate ", " extraLangOptions } #-}}++import THSH+import System.Exit++-- ! BEGIN USER STRIPPED SCRIPT+{strippedScript}+-- ! END USER STRIPPED SCRIPT++main :: IO ExitCode+main = do+ runFuncletWithStdHandles __main__+|]
+ src/THSH.hs view
@@ -0,0 +1,11 @@+module THSH+ ( module THSH.Funclet+ , module THSH.QQ+ , module THSH.Script+ , module THSH.Fn+ ) where++import THSH.Fn+import THSH.Funclet+import THSH.QQ+import THSH.Script
+ src/THSH/Fn.hs view
@@ -0,0 +1,105 @@+module THSH.Fn+ ( ContentFn (..), stringContentFn, stringContentIOFn, textContentFn, textContentIOFn+ , LineReadFn (..), lineReadFn+ , fn ) where++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (bracket)+import System.Exit (ExitCode (..))+import System.IO (BufferMode (NoBuffering), Handle, hClose, hGetContents, hGetLine, hIsEOF,+ hPutStr, hSetBuffering)+-- process+import System.Process (createPipe)+-- text+import qualified Data.Text as T+import qualified Data.Text.IO+--+import THSH.Funclet (Funclet (..))+++-- | A 'Fn' is a function that, given a set of handles to communicate with it, it returns an exit code.+class FnFunction f where+ runFn :: f -> (Handle, Handle, Handle) -> IO ExitCode++-- | A 'Fn' that converts the entire input content to another as 'String'.+data ContentFn m s = MkContentFn (s -> m s) (Handle -> m s) (Handle -> s -> m ())++instance FnFunction (ContentFn IO s) where+ runFn (MkContentFn f r w) (hIn, hOut, _) = do+ content <- r hIn+ w hOut =<< f content+ pure ExitSuccess++-- | 'ContentFn' for the 'String' type.+stringContentFn :: (String -> String) -> ContentFn IO String+stringContentFn f = MkContentFn (pure . f) hGetContents hPutStr++-- | IO variant of 'stringContentFn'.+stringContentIOFn :: (String -> IO String) -> ContentFn IO String+stringContentIOFn f = MkContentFn f hGetContents hPutStr++-- | 'ContentFn' for the 'Text' type from the text package.+textContentFn :: (T.Text -> T.Text) -> ContentFn IO T.Text+textContentFn f = MkContentFn (pure . f) Data.Text.IO.hGetContents Data.Text.IO.hPutStr++-- | IO variant of 'textContentFn'.+textContentIOFn :: (T.Text -> IO T.Text) -> ContentFn IO T.Text+textContentIOFn f = MkContentFn f Data.Text.IO.hGetContents Data.Text.IO.hPutStr++-- | A 'Fn' that reads line by line via 'Read' instances of @a@ and accumulates context @b@.+data LineReadFn m a b = Read a+ => MkLineReadFn+ (a -> b -> m (b, Maybe String)) -- read an element; accumulate context; and maybe an output+ (b -> m (Maybe String)) -- final output+ b -- initial context++-- Idiomatic wrapper for the `MkLineReadFn`+lineReadFn :: forall a b.+ Read a+ => (a -> b -> (b, Maybe String))+ -> (b -> Maybe String)+ -> b+ -> LineReadFn IO a b+lineReadFn f fin b0 = MkLineReadFn ((pure .) . f) (pure . fin) b0++instance FnFunction (LineReadFn IO a b) where+ runFn (MkLineReadFn f fin b0) (hIn, hOut, _) = do+ let go b (a:as) = a >>= \case+ Just a' -> f a' b >>= \ (b', r) ->+ case r of+ Just r' -> hPutStr hOut r'+ Nothing -> pure ()+ >> go b' as+ Nothing -> fin b >>= \case+ Just a' -> hPutStr hOut a'+ Nothing -> pure () -- input lines finished+ go _ _ = error "impossible"+ -- repeatedly reading lines for @go@ to process, which should end with an infinite list of Nothings.+ go b0 $ repeat (hIsEOF hIn >>= \ case+ False -> hGetLine hIn >>= pure . Just . (read :: String -> a)+ True -> pure Nothing)+ pure ExitSuccess++-- | 'Fn' wraps a type of 'FnFunction' instance.+data Fn f = FnFunction f => Fn f++-- | 'Fn' is a trivial 'Funclet'.+instance Funclet (Fn f) where+ runFunclet (Fn f) cb = do+ handles <- newEmptyMVar+ _ <- forkIO $ bracket+ (do+ (hInR, hInW) <- createPipe+ (hOutR, hOutW) <- createPipe+ (hErrR, hErrW) <- createPipe+ mapM_ (`hSetBuffering` NoBuffering) [hInR, hInW, hOutR, hOutW, hErrR, hErrW]+ putMVar handles (hInW, hOutR, hErrR)+ pure (hInR, hOutW, hErrW)+ )+ (\(hInR, hOutW, hErrW) -> mapM_ hClose [hInR, hOutW, hErrW])+ (\(hInR, hOutW, hErrW) -> cb =<< runFn f (hInR, hOutW, hErrW))+ takeMVar handles++fn :: FnFunction f => f -> Fn f+fn = Fn
+ src/THSH/Funclet.hs view
@@ -0,0 +1,34 @@+module THSH.Funclet+ ( Funclet (..)+ , AnyFunclet (..)+ , runFuncletWithStdHandles+ ) where++import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)+import System.Exit (ExitCode)+import System.IO (Handle, stderr, stdin, stdout)+--+import THSH.Internal.ProcessUtils (binaryCat)+++-- | A funclet is an IO process that communicates through handles and returns an exit code.+class Funclet f where+ runFunclet :: f -> (ExitCode -> IO ()) -> IO (Handle, Handle, Handle)++-- | Run a funclet with standard handles+runFuncletWithStdHandles :: Funclet f => f -> IO ExitCode+runFuncletWithStdHandles f = do+ ecVar <- newEmptyMVar+ (hInW, hOutR, hErrR) <- runFunclet f (putMVar ecVar)+ mapM_ forkIO [ binaryCat stdin hInW+ , binaryCat hOutR stdout+ , binaryCat hErrR stderr+ ]+ ec <- takeMVar ecVar+ pure ec++-- | Existential wrapper of any funclet.+data AnyFunclet = forall f. Funclet f => MkAnyFunclet f++instance Funclet AnyFunclet where+ runFunclet (MkAnyFunclet f) = runFunclet f
+ src/THSH/Internal/HsExprUtils.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}++module THSH.Internal.HsExprUtils+ ( RdrName+ , findFreeVariables+ ) where++import GHC (GenLocated (..), Located, SrcSpan, locA, unLoc)+import qualified GHC.Hs.Expr as HsExpr (GRHS (..), GRHSs (..), HsExpr (..), Match (..), MatchGroup (..))+import qualified GHC.Hs.Extension+import GHC.Types.Name.Reader (RdrName (..))+import qualified Language.Haskell.Syntax.Pat as Pat+--+import Data.Data (Data, gmapQ)+import Data.Typeable (Typeable, cast)+++findFreeVariables :: Data a => a -> [(SrcSpan, RdrName)]+findFreeVariables item = allNames+ where+ -- Find all free Variables in an HsExpr+ f :: forall a. (Data a, Typeable a) => a -> [Located RdrName]+ f expr = case cast @_ @(HsExpr.HsExpr GHC.Hs.Extension.GhcPs) expr of+#if MIN_VERSION_ghc(9,2,0)+ Just (HsExpr.HsVar _ l@(L a _)) -> [L (locA a) (unLoc l)]+#else+ Just (HsExpr.HsVar _ l) -> [l]+#endif++#if MIN_VERSION_ghc(9,10,0)+ Just (HsExpr.HsLam _ _ (HsExpr.MG _ (unLoc -> (map unLoc -> [HsExpr.Match _ _ (map unLoc -> ps) (HsExpr.GRHSs _ [unLoc -> HsExpr.GRHS _ _ (unLoc -> e)] _)])))) -> filter keepVar subVars+#elif MIN_VERSION_ghc(9,6,0)+ Just (HsExpr.HsLam _ (HsExpr.MG _ (unLoc -> (map unLoc -> [HsExpr.Match _ _ (map unLoc -> ps) (HsExpr.GRHSs _ [unLoc -> HsExpr.GRHS _ _ (unLoc -> e)] _)])))) -> filter keepVar subVars+#else+ Just (HsExpr.HsLam _ (HsExpr.MG _ (unLoc -> (map unLoc -> [HsExpr.Match _ _ (map unLoc -> ps) (HsExpr.GRHSs _ [unLoc -> HsExpr.GRHS _ _ (unLoc -> e)] _)])) _)) -> filter keepVar subVars+#endif+ where+ keepVar (L _ n) = n `notElem` subPats+ subVars = concat $ gmapQ f [e]+ subPats = concat $ gmapQ findPats ps+ _ -> concat $ gmapQ f expr++ -- Find all Variables bindings (i.e. patterns) in an HsExpr+ findPats :: forall a. (Data a, Typeable a) => a -> [RdrName]+ findPats p = case cast @_ @(Pat.Pat GHC.Hs.Extension.GhcPs) p of+ Just (Pat.VarPat _ (unLoc -> name)) -> [name]+ _ -> concat $ gmapQ findPats p+ -- Be careful, we wrap hsExpr in a list, so the toplevel hsExpr will be+ -- seen by gmapQ. Otherwise it will miss variables if they are the top+ -- level expression: gmapQ only checks sub constructors.+ allVars = concat $ gmapQ f [item]+ allNames = map (\(L l e) -> (l, e)) allVars
+ src/THSH/Internal/ProcessUtils.hs view
@@ -0,0 +1,44 @@+module THSH.Internal.ProcessUtils+ ( binaryCat, binaryCat'+ , pollProcessExitCode+ ) where++import Control.Concurrent (threadDelay, yield)+import Control.Monad (unless)+import Foreign (Ptr, allocaBytes)+import System.Exit (ExitCode)+import System.IO+import System.Process (ProcessHandle, getProcessExitCode)+++binaryCat :: Handle -> Handle -> IO ()+binaryCat hr hw = allocaBytes cBUFFER_SIZE (binary_cat_with_ptr "" hr hw)++binaryCat' :: String -> Handle -> Handle -> IO ()+binaryCat' l hr hw = allocaBytes cBUFFER_SIZE (binary_cat_with_ptr l hr hw)++pollProcessExitCode :: ProcessHandle -> IO ExitCode+pollProcessExitCode ph = getProcessExitCode ph >>= \case+ Nothing -> yield >> threadDelay cPROCESS_POLL_INTERVAL >> pollProcessExitCode ph+ Just ec -> pure ec++{- INTERNAL FUNCTIONS -}++cPROCESS_POLL_INTERVAL :: Int+cPROCESS_POLL_INTERVAL = 10_000++-- https://stackoverflow.com/questions/68639266/size-of-buffered-input-in-c+-- By many accounts, it seems "gnu cat" uses 128 KB as buffer size+cBUFFER_SIZE :: Int+cBUFFER_SIZE = 128 * 1024++binary_cat_with_ptr :: String -> Handle -> Handle -> Ptr a -> IO ()+binary_cat_with_ptr l hr hw ptr = go where+ go = do+ unless (length l == 0) (put_err_ln $ "!! cat " <> l <> " go")+ n <- hGetBufSome hr ptr cBUFFER_SIZE+ unless (length l == 0) (put_err_ln $ "!! cat " <> l <> " n " <> show n)+ unless (n == 0) $ hPutBuf hw ptr n >> go++put_err_ln :: String -> IO ()+put_err_ln = hPutStrLn stderr
+ src/THSH/Internal/PyFInternals.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module THSH.Internal.PyFInternals+ ( checkOneItem+ , getFormatExpr+ , ParsingContext (..)+ , Item (..)+ , parseGenericFormatString+ ) where++-- ghc modules+import GHC (SrcSpan)+import GHC.TypeError (ErrorMessage (Text), TypeError)+import Language.Haskell.TH.Syntax (Exp (..), Lit (..), Q (..))+-- baes module+import Data.Kind (Type)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Proxy (Proxy (Proxy))+-- PyF module (Note: we take the risks of using internal functions)+import PyF.Class (PyFCategory (..), PyFClassify, PyFToString (..), PyfFormatFractional (..),+ PyfFormatIntegral (..))+import PyF.Formatters (AnyAlign (..))+import qualified PyF.Formatters as Formatters+import PyF.Internal.PythonSyntax (AlternateForm (..), ExprOrValue (..), FormatMode (..), Item (..),+ Padding (..), ParsingContext (..), Precision (..), TypeFormat (..),+ parseGenericFormatString, pattern DefaultFormatMode)+--+import THSH.Internal.HsExprUtils (RdrName, findFreeVariables)+import THSH.Internal.THUtils (freeVariableByNameExists)+++{- ========== checkOneItem ========== -}++checkOneItem :: Item -> Q (Maybe (SrcSpan, String))+checkOneItem (Raw _) = pure Nothing+checkOneItem (Replacement (hsExpr, _) formatMode) = do+ let allNames = findFreeVariables hsExpr <> findFreeVariablesInFormatMode formatMode+ res <- mapM freeVariableByNameExists allNames+ let resFinal = catMaybes res++ case resFinal of+ [] -> pure Nothing+ ((err, srcSpan) : _) -> pure $ Just (srcSpan, err)++findFreeVariablesInFormatMode :: Maybe FormatMode -> [(SrcSpan, RdrName)]+findFreeVariablesInFormatMode Nothing = []+findFreeVariablesInFormatMode (Just (FormatMode padding tf _ )) = findFreeVariables tf <> case padding of+ PaddingDefault -> []+ Padding eoi _ -> findFreeVariables eoi++{- ========== getFormatExpr ========== -}++getFormatExpr :: Maybe FormatMode -> Q Exp+getFormatExpr mode = let mode' = fromMaybe DefaultFormatMode mode in padAndFormat mode'++padAndFormat :: FormatMode -> Q Exp+padAndFormat (FormatMode padding tf grouping) = case tf of+ -- Integrals+ BinaryF alt s -> [|formatAnyIntegral $(withAlt alt Formatters.Binary) s $(newPaddingQ padding) $(toGrp grouping 4)|]+ CharacterF -> [|formatAnyIntegral Formatters.Character Formatters.Minus $(newPaddingQ padding) Nothing|]+ DecimalF s -> [|formatAnyIntegral Formatters.Decimal s $(newPaddingQ padding) $(toGrp grouping 3)|]+ HexF alt s -> [|formatAnyIntegral $(withAlt alt Formatters.Hexa) s $(newPaddingQ padding) $(toGrp grouping 4)|]+ OctalF alt s -> [|formatAnyIntegral $(withAlt alt Formatters.Octal) s $(newPaddingQ padding) $(toGrp grouping 4)|]+ HexCapsF alt s -> [|formatAnyIntegral (Formatters.Upper $(withAlt alt Formatters.Hexa)) s $(newPaddingQ padding) $(toGrp grouping 4)|]+ -- Floating+ ExponentialF prec alt s -> [|formatAnyFractional $(withAlt alt Formatters.Exponent) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec)|]+ ExponentialCapsF prec alt s -> [|formatAnyFractional (Formatters.Upper $(withAlt alt Formatters.Exponent)) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec)|]+ GeneralF prec alt s -> [|formatAnyFractional $(withAlt alt Formatters.Generic) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec)|]+ GeneralCapsF prec alt s -> [|formatAnyFractional (Formatters.Upper $(withAlt alt Formatters.Generic)) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec)|]+ FixedF prec alt s -> [|formatAnyFractional $(withAlt alt Formatters.Fixed) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec)|]+ FixedCapsF prec alt s -> [|formatAnyFractional (Formatters.Upper $(withAlt alt Formatters.Fixed)) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec)|]+ PercentF prec alt s -> [|formatAnyFractional $(withAlt alt Formatters.Percent) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec)|]+ -- Default / String+ DefaultF prec s -> [|formatAny s $(paddingToPaddingK padding) $(toGrp grouping 3) $(splicePrecision Nothing prec)|]+ StringF prec -> [|Formatters.formatString (newPaddingKForString $(paddingToPaddingK padding)) $(splicePrecision Nothing prec) . pyfToString|]++-- | Default precision for floating point+defaultFloatPrecision :: Maybe Int+defaultFloatPrecision = Just 6++withAlt :: AlternateForm -> Formatters.Format t t' t'' -> Q Exp+withAlt NormalForm e = [|e|]+withAlt AlternateForm e = [|Formatters.Alternate e|]++-- | Precision to maybe+splicePrecision :: Maybe Int -> Precision -> Q Exp+splicePrecision def PrecisionDefault = [|def :: Maybe Int|]+splicePrecision _ (Precision p) = [|Just $(exprToInt p)|]++toGrp :: Maybe Char -> Int -> Q Exp+toGrp mb a = [|grp|]+ where+ grp = (a,) <$> mb++newPaddingQ :: Padding -> Q Exp+newPaddingQ padding = case padding of+ PaddingDefault -> [|Nothing :: Maybe (Int, AnyAlign, Char)|]+ (Padding i al) -> case al of+ Nothing -> [|Just ($(exprToInt i), AnyAlign Formatters.AlignRight, ' ')|] -- Right align and space is default for any object, except string+ Just (Nothing, a) -> [|Just ($(exprToInt i), a, ' ')|]+ Just (Just c, a) -> [|Just ($(exprToInt i), a, c)|]++exprToInt :: ExprOrValue Int -> Q Exp+-- Note: this is a literal provided integral. We use explicit case to ::Int so it won't warn about defaulting+exprToInt (Value i) = [|$(pure $ LitE (IntegerL (fromIntegral i))) :: Int|]+exprToInt (HaskellExpr (_, e)) = [|$(pure e)|]++paddingToPaddingK :: Padding -> Q Exp+paddingToPaddingK p = case p of+ PaddingDefault -> [|PaddingDefaultK|]+ Padding i Nothing -> [|PaddingK ($(exprToInt i)) Nothing :: PaddingK 'Formatters.AlignAll Int|]+ Padding i (Just (c, AnyAlign a)) -> [|PaddingK $(exprToInt i) (Just (c, a))|]++paddingKToPadding :: PaddingK k i -> Maybe (i, AnyAlign, Char)+paddingKToPadding p = case p of+ PaddingDefaultK -> Nothing+ (PaddingK i al) -> case al of+ Nothing -> Just (i, AnyAlign Formatters.AlignRight, ' ') -- Right align and space is default for any object, except string+ Just (Nothing, a) -> Just (i, AnyAlign a, ' ')+ Just (Just c, a) -> Just (i, AnyAlign a, c)++formatAnyIntegral :: forall i paddingWidth t t'. Integral paddingWidth => PyfFormatIntegral i => Formatters.Format t t' 'Formatters.Integral -> Formatters.SignMode -> Maybe (paddingWidth, AnyAlign, Char) -> Maybe (Int, Char) -> i -> String+formatAnyIntegral f s Nothing grouping i = pyfFormatIntegral @i @paddingWidth f s Nothing grouping i+formatAnyIntegral f s (Just (padSize, AnyAlign alignMode, c)) grouping i = pyfFormatIntegral f s (Just (padSize, alignMode, c)) grouping i++formatAnyFractional :: forall paddingWidth precision i t t'. (Integral paddingWidth, Integral precision, PyfFormatFractional i) => Formatters.Format t t' 'Formatters.Fractional -> Formatters.SignMode -> Maybe (paddingWidth, AnyAlign, Char) -> Maybe (Int, Char) -> Maybe precision -> i -> String+formatAnyFractional f s Nothing grouping p i = pyfFormatFractional @i @paddingWidth @precision f s Nothing grouping p i+formatAnyFractional f s (Just (padSize, AnyAlign alignMode, c)) grouping p i = pyfFormatFractional f s (Just (padSize, alignMode, c)) grouping p i++class FormatAny i k where+ formatAny :: forall paddingWidth precision. (Integral paddingWidth, Integral precision) => Formatters.SignMode -> PaddingK k paddingWidth -> Maybe (Int, Char) -> Maybe precision -> i -> String++instance (FormatAny2 (PyFClassify t) t k) => FormatAny t k where+ formatAny = formatAny2 (Proxy :: Proxy (PyFClassify t))++class FormatAny2 (c :: PyFCategory) (i :: Type) (k :: Formatters.AlignForString) where+ formatAny2 :: forall paddingWidth precision. (Integral paddingWidth, Integral precision) => Proxy c -> Formatters.SignMode -> PaddingK k paddingWidth -> Maybe (Int, Char) -> Maybe precision -> i -> String++instance (Show t, Integral t) => FormatAny2 'PyFIntegral t k where+ formatAny2 _ s a p _precision = formatAnyIntegral Formatters.Decimal s (paddingKToPadding a) p++instance (PyfFormatFractional t) => FormatAny2 'PyFFractional t k where+ formatAny2 _ s a = formatAnyFractional Formatters.Generic s (paddingKToPadding a)++data PaddingK k i where+ PaddingDefaultK :: PaddingK 'Formatters.AlignAll Int+ PaddingK :: i -> Maybe (Maybe Char, Formatters.AlignMode k) -> PaddingK k i++newPaddingKForString :: Integral i => PaddingK 'Formatters.AlignAll i -> Maybe (Int, Formatters.AlignMode 'Formatters.AlignAll, Char)+newPaddingKForString padding = case padding of+ PaddingDefaultK -> Nothing+ PaddingK i Nothing -> Just (fromIntegral i, Formatters.AlignLeft, ' ') -- default align left and fill with space for string+ PaddingK i (Just (mc, a)) -> Just (fromIntegral i, a, fromMaybe ' ' mc)++-- TODO: _s(ign) and _grouping should trigger errors+instance (PyFToString t) => FormatAny2 'PyFString t 'Formatters.AlignAll where+ formatAny2 _ _s a _grouping precision t = Formatters.formatString (newPaddingKForString a) precision (pyfToString t)++instance TypeError ('Text "String type is incompatible with inside padding (=).") => FormatAny2 'PyFString t 'Formatters.AlignNumber where+ formatAny2 = error "Unreachable"
+ src/THSH/Internal/THUtils.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++module THSH.Internal.THUtils+ ( reportErrorAt+ , toName+ , lookupName+ , freeVariableByNameExists+ ) where++import GHC (SrcSpan, moduleNameString)+import GHC.Tc.Errors.Types (TcRnMessage (TcRnUnknownMessage))+import GHC.Tc.Types (TcM)+import GHC.Tc.Utils.Monad (addErrAt)+import GHC.Types.Error (NoDiagnosticOpts (NoDiagnosticOpts), UnknownDiagnostic (UnknownDiagnostic))+import GHC.Types.Name (getOccString, occNameString)+import GHC.Types.Name.Reader (RdrName (..))+import qualified GHC.Unit.Module as Module+import GHC.Utils.Error (mkPlainError, noHints)+import GHC.Utils.Outputable (text)+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Syntax (Q (Q))+--+import Data.Maybe (isJust)+import Unsafe.Coerce (unsafeCoerce)++-- | This function is similar to TH reportError, however it also provide+-- correct SrcSpan, so error are localised at the correct position in the TH+-- splice instead of being at the beginning.+--+-- From: PyF.Internal.QQ+reportErrorAt :: SrcSpan -> String -> Q ()+reportErrorAt loc msg = unsafeRunTcM $ addErrAt loc msg'+ where+#if MIN_VERSION_ghc(9,7,0)+ msg' = TcRnUnknownMessage (UnknownDiagnostic (const NoDiagnosticOpts) (mkPlainError noHints (text msg)))+#elif MIN_VERSION_ghc(9,6,0)+ msg' = TcRnUnknownMessage (UnknownDiagnostic $ mkPlainError noHints $+ text msg)+#elif MIN_VERSION_ghc(9,3,0)+ msg' = TcRnUnknownMessage (GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $+ text msg)+#else+ msg' = fromString msg+#endif++-- Stolen from: https://www.tweag.io/blog/2021-01-07-haskell-dark-arts-part-i/+-- This allows to hack inside the the GHC api and use function not exported by template haskell.+-- This may not be always safe, see https://github.com/guibou/PyF/issues/115,+-- hence keep that for "failing path" (i.e. error reporting), but not on+-- codepath which are executed otherwise.+-- From: PyF.Internal.QQ+unsafeRunTcM :: TcM a -> Q a+unsafeRunTcM m = Q (unsafeCoerce m)++toName :: RdrName -> TH.Name+toName n = case n of+ (Unqual o) -> TH.mkName (occNameString o)+ (Qual m o) -> TH.mkName (Module.moduleNameString m <> "." <> occNameString o)+ (Orig _m _o) -> error "PyFMeta: not supported toName (Orig _)"+ (Exact nm) -> case getOccString nm of+ "[]" -> '[]+ "()" -> '()+ _ -> error "toName: exact name encountered"++lookupName :: RdrName -> Q Bool+lookupName n = case n of+ (Unqual o) -> isJust <$> TH.lookupValueName (occNameString o)+ (Qual m o) -> isJust <$> TH.lookupValueName (moduleNameString m <> "." <> occNameString o)+ -- No idea how to lookup for theses names, so consider that they exists+ (Orig _m _o) -> pure True+ (Exact _) -> pure True++freeVariableByNameExists :: (b, RdrName) -> Q (Maybe (String, b))+freeVariableByNameExists (loc, name) = do+ res <- lookupName name+ if res+ then pure Nothing+ else pure (Just ("Variable not in scope: " <> show (toName name), loc))
+ src/THSH/QQ.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE TemplateHaskellQuotes #-}++module THSH.QQ+ ( thsh+ ) where++-- ghc modules+import GHC (SrcLoc, mkSrcLoc, mkSrcSpan)+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax (Code, Exp (..), Q (..))+-- base module+import Data.List (intercalate)+import Data.Maybe (catMaybes, listToMaybe)+import Data.String (fromString)+-- transformers module+import Control.Monad.Trans.Reader (runReader)+-- parsec module+import qualified Text.Parsec as Ps+import qualified Text.Parsec.Error as PsError+import qualified Text.Parsec.Pos as PsPos+--+import THSH.Funclet (AnyFunclet (..))+import qualified THSH.Internal.PyFInternals as PyF+import THSH.Internal.THUtils (reportErrorAt)+import THSH.Script (Script (..), genFuncletPipeCode)+++-- | The quasi quoter for Template Haskell shell scripts.+thsh :: QuasiQuoter+thsh = QuasiQuoter+ { quoteExp = toExp,+ quotePat = mkErr "pattern",+ quoteType = mkErr "type",+ quoteDec = mkErr "declaration"+ }+ where+ mkErr :: String -> a+ mkErr name = error ("thsh : This QuasiQuoter can not be used as a " ++ name ++ "!")++ toExp :: String -> Q Exp+ toExp s = do+ loc <- TH.location+ exts <- TH.extsEnabled+ let context = PyF.ParsingContext (Just ('«', '»')) exts++ -- Setup the parser so it matchs the real original position in the source+ -- code.+ let filename = TH.loc_filename loc+ let initPos = Ps.setSourceColumn (Ps.setSourceLine (PsPos.initialPos filename) (fst $ TH.loc_start loc)) (snd $ TH.loc_start loc)+ case runReader (Ps.runParserT (Ps.setPosition initPos >> PyF.parseGenericFormatString) () filename s) context of+ -- returns a dummy exp, so TH continues its life. This TH code won't be+ -- executed anyway, there is an error+ Left err -> reportParserErrorAt err >> [|()|]+ Right items -> do+ -- stop at the first item that contains an error+ mapM id (map PyF.checkOneItem items) >>= pure . listToMaybe . catMaybes >>= \case+ Nothing -> TH.unTypeCode (mkScript items)+ Just (srcSpan, msg) -> reportErrorAt srcSpan msg >> [|()|]++{- ========== mkScript ========== -}++mkScript :: [PyF.Item] -> Code Q Script+mkScript items = [|| MkScript $$(TH.unsafeCodeCoerce source) $$(TH.unsafeCodeCoerce funclets) ||]+ where items' = fmap matchItem items+ funclets = foldl appendQ <$> [| [] |] <*>+ mapM snd (filter ((== True) . fst) items')+ source = snd $ foldl (\(c, rs) (isFunclet, frag) -> if isFunclet+ then (c + 1, appendQ <$> rs <*> [| genFuncletPipeCode c |])+ else (c, appendQ <$> rs <*> frag)+ ) (0 :: Int, [| [] |]) items'++-- | call `<>` between two 'Exp'+appendQ :: Exp -> Exp -> Exp+appendQ s0 s1 = InfixE (Just s0) (VarE '(<>)) (Just s1)++-- | Match an item to a funclet expression (True) or a formatted String expression (False)+matchItem :: PyF.Item -> (Bool, Q Exp)+matchItem (PyF.Raw x) = (False, [| x |])+matchItem (PyF.Replacement (_, expr) y) =+ let isFunclet = case expr of+ AppE (VarE a) _ -> if | TH.nameBase a == "sh" -> True+ | TH.nameBase a == "fn" -> True+ | otherwise -> False+ _ -> False+ in (isFunclet, if isFunclet then [| [MkAnyFunclet $(pure expr)] |]+ else [| $(PyF.getFormatExpr y) $(pure expr) |])++{- ========== reportParserErrorAt ========== -}++reportParserErrorAt :: Ps.ParseError -> Q ()+reportParserErrorAt err = reportErrorAt srcSpan msg+ where+ msg = intercalate "\n" $ formatErrorMessages err++ srcSpan = mkSrcSpan loc loc'++ loc = srcLocFromParserError (Ps.errorPos err)+ loc' = srcLocFromParserError (Ps.incSourceColumn (Ps.errorPos err) 1)++formatErrorMessages :: Ps.ParseError -> [String]+formatErrorMessages err+ -- If there is an explicit error message from parsec, use only that+ | not $ null messages = map PsError.messageString messages+ -- Otherwise, uses parsec formatting+ | otherwise = [PsError.showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (PsError.errorMessages err)]+ where+ (_sysUnExpect, msgs1) = span (PsError.SysUnExpect "" ==) (PsError.errorMessages err)+ (_unExpect, msgs2) = span (PsError.UnExpect "" ==) msgs1+ (_expect, messages) = span (PsError.Expect "" ==) msgs2++srcLocFromParserError :: Ps.SourcePos -> SrcLoc+srcLocFromParserError sourceLoc = srcLoc+ where+ line = Ps.sourceLine sourceLoc+ column = Ps.sourceColumn sourceLoc+ name = Ps.sourceName sourceLoc+ srcLoc = mkSrcLoc (fromString name) line column
+ src/THSH/Script.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE QuasiQuotes #-}+module THSH.Script+ ( Script (..)+ , genFuncletPipeCode+ , sh+ ) where++-- base module+import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)+import Control.Exception (bracket, catch)+import Control.Monad (unless, void)+import System.Exit (ExitCode (..))+import System.IO (BufferMode (NoBuffering), IOMode (ReadMode, ReadWriteMode, WriteMode),+ hClose, hGetLine, hPutStr, hPutStrLn, hSetBuffering, openBinaryFile,+ stderr, withFile)+-- filepath module+import System.FilePath ((</>))+-- process module+import System.Process (CreateProcess (std_err, std_in, std_out), StdStream (CreatePipe),+ callCommand, createProcess, shell)+-- temporary module+import System.IO.Temp (withSystemTempDirectory)+-- PyF module+import PyF (fmt, str)+--+import THSH.Funclet (AnyFunclet, Funclet (..))+import THSH.Internal.ProcessUtils (binaryCat, pollProcessExitCode)+++data Script = MkScript { source :: String+ , funclets :: [AnyFunclet]+ }++instance Funclet Script where+ runFunclet (MkScript { source, funclets }) cb = do+ handles <- newEmptyMVar+ _ <- forkIO $ withSystemTempDirectory "thsh-script.d" $ \ dir -> do+ let initCodePath = dir </> "init.sh"+ srcPath = dir </> "source.sh"+ ctlFifo = dir </> "cr.fifo"++ -- write init code+ withFile initCodePath WriteMode $ \fh -> hPutStr fh (gen_init_code (length funclets))++ -- call init code+ callCommand ("sh " <> initCodePath)++ -- write source file+ withFile srcPath WriteMode $ \fh -> do+ hPutStr fh gen_stub_code+ hPutStr fh source++ -- create the main process+ (Just hInW, Just hOutR, Just hErrR, mainProc) <- createProcess $+ (shell ("sh " <> srcPath)) { std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }+ putMVar handles (hInW, hOutR, hErrR)++ -- create control thread+ unless (length funclets == 0) $ void . forkIO $ withFile ctlFifo ReadMode $ \ ch -> let+ go = do+ catch (hGetLine ch) (\ (e :: IOError) -> hPutStrLn stderr (show e) >> pure []) >>= \cmd -> do+ case cmd of+ [] -> pure () -- likely end of file+ 's':' ':i -> start_funclet_proc (funclets !! (read i :: Int)) (dir </> i) >> pure ()+ _ -> hPutStrLn stderr $ "[thsh-script] unknown control command: " <> cmd+ if cmd /= "" then go else pure ()+ in go++ -- wait for the main sub process to finish+ ec <- pollProcessExitCode mainProc++ cb ec++ (hInW, hOutR, hErrR) <- takeMVar handles+ pure (hInW, hOutR, hErrR)++genFuncletPipeCode :: Int -> String+genFuncletPipeCode i = "__pipeFunclet " <> (show i)++sh :: Script -> Script+sh = id++{- INTERNAL FUNCTIONS -}++start_funclet_proc :: Funclet f => f -> FilePath -> IO ()+start_funclet_proc f procDir = do+ -- use mVar to communicate errno+ ecVar <- newEmptyMVar+ (fh0, fh1, fh2) <- runFunclet f (putMVar ecVar)+ -- piping data between the main process and the funclet process+ void . forkIO $ bracket+ (do+ -- create main process handlers (mh)+ mh0 <- openBinaryFile (procDir </> "0.fifo") ReadMode+ mh1 <- openBinaryFile (procDir </> "1.fifo") ReadWriteMode+ mh2 <- openBinaryFile (procDir </> "2.fifo") ReadWriteMode+ mapM_ (`hSetBuffering` NoBuffering) [mh0, mh1, mh2]+ pure (mh0, mh1, mh2)+ )+ (\(mh0, mh1, mh2) -> mapM_ hClose [mh0, mh1, mh2])+ (\(mh0, mh1, mh2) -> do+ -- fork pipes+ cs <- mapM (const newEmptyMVar) [(),(),()]+ mapM_ forkIO [ binaryCat mh0 fh0 >> hClose fh0 >> putMVar (cs !! 0) ()+ , binaryCat fh1 mh1 >> putMVar (cs !! 1) ()+ , binaryCat fh2 mh2 >> putMVar (cs !! 2) ()+ ]+ -- wait for all pipes to finish+ mapM_ takeMVar cs+ )+ -- wait for the errno and save it for the main process+ void . forkIO $ takeMVar ecVar >>= \ec -> do+ case ec of+ ExitSuccess -> pure ()+ ExitFailure errno -> withFile (procDir </> "errno") WriteMode (`hPutStr` (show errno))++gen_init_code :: Int -> String+gen_init_code nFunclets = [str|\+#set -x+__initFunclets() {+ n="$1"+ d=$(dirname "$0")++ # nothing to initialize when there is no funclet+ [ "$n" == "-1" ] && return++ # create control fifos+ mkfifo "$d"/c{w,r}.fifo+ tail -f "$d"/cw.fifo > "$d"/cr.fifo &++ # create funclet fifos+ seq 0 "$n" | while read i; do+ mkdir -p "$d/$i"+ mkfifo "$d/$i"/{0,1,2}.fifo+ done+}+|] <> [fmt|__initFunclets {show (nFunclets - 1)}+|]++gen_stub_code :: String+gen_stub_code = [str|\+#+BEGIN_SRC THSH script stub code+__pipeFunclet() (+ # connect to the fifos of nth functlet+ i="$1"+ d="$(dirname "$0")/$i"++ cat <&0 > "$d"/0.fifo & pid0=$!+ cat >&1 < "$d"/1.fifo & pid1=$!+ cat >&2 < "$d"/2.fifo & pid2=$!+ trap 'kill $pid0 $pid1 $pid2' SIGINT++ echo "s $i" > "$(dirname "$0")"/cw.fifo++ wait $pid0 $pid1 $pid2+ : __pipeFunclet ended+)+#+END_SRC+|]
+ test/Main.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE QuasiQuotes #-}++module Main (main) where++import Data.Char (toLower)+import System.Exit (ExitCode)+import THSH+++testSingleShellScript :: IO ExitCode+testSingleShellScript = do+ let saluteTo = "nix"+ runFuncletWithStdHandles [thsh|\+set -x+cat "$(dirname "$0")"/init.sh+cat "$0"+echo "Hello « saluteTo », 1 + 1 = « (1 :: Integer) + 1 :>4.2f»"+echo "««"+echo "»»"+|]++testScriptFunclet :: IO ExitCode+testScriptFunclet = do+ let s0 = [thsh| sed "s/Haskell/Haskell❤️/g" |]+ s1 = [thsh| echo Brrrr |]+ s2 = [thsh| bc |]+ runFuncletWithStdHandles [thsh|\+echo "Hello, Haskell." | «sh s0»+echo "" | «sh s1» | sed 's/r/R/g'+echo "Now do some maths."+for i in `seq 0 10`;do+ expr="2 ^ $i"+ echo -n "$expr = "+ echo $expr | «sh s2»+done+|]++testFn :: IO ExitCode+testFn = runFuncletWithStdHandles [thsh|\+curl -s https://example.org/ | «fn (stringContentFn (\content -> "Number of occurrences of the word 'example' is "+ <> show (length (filter ((== "examples"). fmap toLower) . words $ content))+ <> "\n"+ ))»++# pseudo sales numbers processing+echo -n "Sum of the sales: "; {+«fn lsum» <<EOF+("apple", 1.2, 100.2)+("orange", 2.0, 34.2)+EOF+} | tail -n1+|] where lsum = lineReadFn+ (\ (_ :: String, price, quantity) s -> let s' = s + price * quantity+ in (s', Nothing))+ (\ s -> Just (show s ++ "\n"))+ (0.0 :: Float)++main :: IO ()+main = do+ putStrLn "== testSingleShellScript"+ _ <- testSingleShellScript++ putStrLn "== testScriptFunclet"+ _ <- testScriptFunclet++ putStrLn "== testFn"+ _ <- testFn++ pure ()