diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for THSH + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/THSH.cabal b/THSH.cabal new file mode 100644 --- /dev/null +++ b/THSH.cabal @@ -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 diff --git a/loader/main.hs b/loader/main.hs new file mode 100644 --- /dev/null +++ b/loader/main.hs @@ -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__ +|] diff --git a/src/THSH.hs b/src/THSH.hs new file mode 100644 --- /dev/null +++ b/src/THSH.hs @@ -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 diff --git a/src/THSH/Fn.hs b/src/THSH/Fn.hs new file mode 100644 --- /dev/null +++ b/src/THSH/Fn.hs @@ -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 diff --git a/src/THSH/Funclet.hs b/src/THSH/Funclet.hs new file mode 100644 --- /dev/null +++ b/src/THSH/Funclet.hs @@ -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 diff --git a/src/THSH/Internal/HsExprUtils.hs b/src/THSH/Internal/HsExprUtils.hs new file mode 100644 --- /dev/null +++ b/src/THSH/Internal/HsExprUtils.hs @@ -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 diff --git a/src/THSH/Internal/ProcessUtils.hs b/src/THSH/Internal/ProcessUtils.hs new file mode 100644 --- /dev/null +++ b/src/THSH/Internal/ProcessUtils.hs @@ -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 diff --git a/src/THSH/Internal/PyFInternals.hs b/src/THSH/Internal/PyFInternals.hs new file mode 100644 --- /dev/null +++ b/src/THSH/Internal/PyFInternals.hs @@ -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" diff --git a/src/THSH/Internal/THUtils.hs b/src/THSH/Internal/THUtils.hs new file mode 100644 --- /dev/null +++ b/src/THSH/Internal/THUtils.hs @@ -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)) diff --git a/src/THSH/QQ.hs b/src/THSH/QQ.hs new file mode 100644 --- /dev/null +++ b/src/THSH/QQ.hs @@ -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 diff --git a/src/THSH/Script.hs b/src/THSH/Script.hs new file mode 100644 --- /dev/null +++ b/src/THSH/Script.hs @@ -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 +|] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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» < 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 ()