diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +Changelog +========= + +Version 0.1.0.0 +--------------- + +*April 21, 2022* + + + +* Initial commit diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2022 Justin Le +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,62 @@ +dhall-text-shell +================ + +`dhall-text-shell` requires the expression to be `Text`. But what if it was able to +also render expressions of type `(Text -> Text) -> Text`, and be given a shell +argument as the `Text -> Text` ? + +```dhall +-- testfile.dhall +let text = https://raw.githubusercontent.com/dhall-lang/dhall-lang/v21.1.0/Prelude/Text/package.dhall +in \(f : Text -> Text) -> text.concatMapSep "," Text f [ "hello", "world" ] +``` + +Would give: + +``` +$ dhall-text-shell --file testfile.dhall --argCmd cat +hello,world +$ dhall-text-shell --file testfile.dhall --argCmd "tr '[:lower:]' '[:upper:]'" +HELLO,WORLD +$ dhall-text-shell --file testfile.dhall --argCmd "pandoc -f markdown -t html" +

hello

+,

world

+$ dhall-text-shell --file testfile.dhall --argCmd "md5sum -z" +5d41402abc4b2a76b9719d911017c592 -,7d793037a0760186574b0282f2f435e7 - +``` + +Error messages: + +``` +$ dhall-text-shell --file testfile.dhall +Error: Expression doesn't match annotation + +- Text ++ .. -> .. (a function type) +$ dhall-text-shell --file testfile.dhall --argCmd cat --argCmd cat +Error: Expression doesn't match annotation + +- .. -> .. (a function type) ++ Text +``` + +Supports multiple arguments as well: + +```dhall +-- testfile2.dhall +let text = https://raw.githubusercontent.com/dhall-lang/dhall-lang/v21.1.0/Prelude/Text/package.dhall +in \(f : Text -> Text) -> \(g : Text -> Text) -> text.concatMapSep "," Text f [ "hello", g "world" ] +``` + +``` +$ dhall-text-shell --file testfile2.dhall --argCmd cat --argCmd "tr '[:lower:]' '[:upper:]'" +hello,WORLD +``` + +This is essentially a very minimal "FFI" for dhall, since it doesn't require +extending anything in the language. It just requires you to parameterize your +program on that ffi function. + +Note that for this to work meaningfully, your shell command must be "pure": it +must return the same stdout for any stdin, and shouldn't observably affect the +world every time it is run. diff --git a/app/dhall-text-shell.hs b/app/dhall-text-shell.hs new file mode 100644 --- /dev/null +++ b/app/dhall-text-shell.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified Dhall.TextShell + +main :: IO () +main = Dhall.TextShell.main diff --git a/dhall-text-shell.cabal b/dhall-text-shell.cabal new file mode 100644 --- /dev/null +++ b/dhall-text-shell.cabal @@ -0,0 +1,69 @@ +cabal-version: 2.4 +name: dhall-text-shell +version: 0.1.0.0 +synopsis: Render dhall text with shell commands as function arguments +description: + `dhall-text-shell` requires the expression to be `Text`. But what if it was able to + also render expressions of type `(Text -> Text) -> Text`, and be given a shell + argument as the `Text -> Text` ? + . + This is essentially a very minimal "FFI" for dhall, since it doesn't require + extending anything in the language. It just requires you to parameterize your + program on that ffi function. +homepage: https://github.com/mstksg/dhall-text-shell +bug-reports: https://github.com/mstksg/dhall-text-shell/issues +license: MIT +license-file: LICENSE +category: Compiler +author: Justin Le +maintainer: Justin Le +copyright: 2021 Justin Le +build-type: Simple +extra-doc-files: README.md + CHANGELOG.md +tested-with: GHC == 8.8.3 + +source-repository head + type: git + location: https://github.com/mstksg/dhall-text-shell.git + +common common-options + build-depends: base >= 4.11.0.0 && < 5 + , containers + , dhall + , filepath + , optparse-applicative + , process + , text + + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + if impl(ghc >= 8.0) + ghc-options: -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -fhide-source-paths + if impl(ghc >= 8.4) + ghc-options: -Wmissing-export-lists + -Wpartial-fields + if impl(ghc >= 8.8) + ghc-options: -Wmissing-deriving-strategies + + default-language: Haskell2010 + +library + import: common-options + hs-source-dirs: src + exposed-modules: Dhall.TextShell + +executable dhall-text-shell + import: common-options + hs-source-dirs: app + main-is: dhall-text-shell.hs + build-depends: dhall-text-shell + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N + diff --git a/src/Dhall/TextShell.hs b/src/Dhall/TextShell.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/TextShell.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module Dhall.TextShell (main) where + +import Control.Exception (Handler (..), SomeException) +import Control.Monad (foldM) +import Control.Applicative (optional) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Core (Expr(Annot)) +import Dhall.Import (SemanticCacheMode (..), Imported(..)) +import Dhall.Parser (Src) +import Dhall.TypeCheck (Censored (..), DetailedTypeError (..), TypeError) +import Dhall.Util (Input (..), Output (..), Censor(..)) +import Options.Applicative (Parser) +import System.Exit (ExitCode, exitFailure) +import qualified Control.Exception +import qualified Data.Map +import qualified Data.Text +import qualified Data.Text.IO +import qualified Dhall +import qualified Dhall.Core +import qualified Dhall.Import +import qualified Dhall.TypeCheck +import qualified Dhall.Util +import qualified GHC.IO.Encoding +import qualified Options.Applicative +import qualified System.FilePath +import qualified System.IO +import qualified System.Process + +-- | Options from general dhall tools +data AsCommand = AsCommand + { censor :: Censor + , explain :: Bool + } + +-- | Options specifically for TextShell +data Options = Options + { file :: Input + , output :: Output + , argCmds :: [String] + } + +-- | Parse 'Options' and 'AsCommand' +parseConfig :: Parser (Options, AsCommand) +parseConfig = (,) <$> parseOptions + <*> parseAsCommand + where + switch name description = + Options.Applicative.switch + ( Options.Applicative.long name + <> Options.Applicative.help description + ) + parseOptions = + Options <$> parseFile + <*> parseOutput + <*> Options.Applicative.many parseArgCmd + parseFile = fmap f (optional p) + where + f Nothing = StandardInput + f (Just file) = InputFile file + + p = Options.Applicative.strOption + ( Options.Applicative.long "file" + <> Options.Applicative.help "Read expression from a file instead of standard input" + <> Options.Applicative.metavar "FILE" + <> Options.Applicative.action "file" + ) + parseOutput = fmap f (optional p) + where + f Nothing = StandardOutput + f (Just file) = OutputFile file + + p = Options.Applicative.strOption + ( Options.Applicative.long "output" + <> Options.Applicative.help "Write result to a file instead of standard output" + <> Options.Applicative.metavar "FILE" + <> Options.Applicative.action "file" + ) + parseArgCmd = Options.Applicative.strOption + ( Options.Applicative.long "argCmd" + <> Options.Applicative.help "Use shell command to supply as `Text -> Text` argument" + <> Options.Applicative.metavar "CMD" + <> Options.Applicative.action "CMD" + ) + parseAsCommand = + AsCommand <$> parseCensor + <*> switch "explain" "Explain error messages in more detail" + parseCensor = fmap f (switch "censor" "Hide source code in error messages") + where + f True = Censor + f False = NoCensor + +main :: IO () +main = do + (options, ac) <- Options.Applicative.execParser $ + Options.Applicative.info + (Options.Applicative.helper <*> parseConfig) + ( Options.Applicative.progDesc "render dhall text with shell commands as function arguments" + <> Options.Applicative.fullDesc + ) + runWithOptions ac options + +runWithOptions :: AsCommand -> Options -> IO () +runWithOptions ac Options{..} = asCommand ac $ \getExpression rootDirectory -> do + expression <- getExpression file + + resolvedExpression <- + Dhall.Import.loadRelativeTo (rootDirectory file) UseSemanticCache expression + + let addPiLayer :: Expr Src Void -> Expr Src Void + addPiLayer = Dhall.Core.Pi + Nothing "_" + (Dhall.Core.Pi Nothing "_" Dhall.Core.Text Dhall.Core.Text) + expectedType = iterate addPiLayer Dhall.Core.Text !! length argCmds + _ <- Dhall.Core.throws (Dhall.TypeCheck.typeOf (Annot resolvedExpression expectedType)) + + let normalizedExpression = Dhall.Core.normalize resolvedExpression + peelArg :: (Expr Void Void, Data.Map.Map Text [String]) + -> String + -> Maybe (Expr Void Void, Data.Map.Map Text [String]) + peelArg (currExp, currMap) arg = case currExp of + Dhall.Core.Lam _ (Dhall.Core.FunctionBinding { functionBindingVariable }) subExp -> + Just (subExp, Data.Map.insertWith (++) functionBindingVariable [arg] currMap) + _ -> Nothing + peeledExprAndMap = + foldM peelArg (normalizedExpression, Data.Map.empty) argCmds + + case peeledExprAndMap of + Nothing -> pure () -- this should have been caught during the typecheck + Just (expr, argMap) -> do + res <- Dhall.Core.normalizeWithM + (\x -> case x of + Dhall.Core.App (Dhall.Core.Var (Dhall.Core.V v i)) + (Dhall.Core.TextLit (Dhall.Core.Chunks [] txt)) + | Just as <- Data.Map.lookup v argMap + , a:_ <- drop i as + -> Just <$> do + sysOut <- Data.Text.pack <$> System.Process.readCreateProcess + (System.Process.shell a) + (Data.Text.unpack txt) + pure $ Dhall.Core.TextLit (Dhall.Core.Chunks [] sysOut) + _ -> pure Nothing + ) + expr + case res of + Dhall.Core.TextLit (Dhall.Core.Chunks [] text) -> + let write = case output of + StandardOutput -> Data.Text.IO.putStr + OutputFile file_ -> Data.Text.IO.writeFile file_ + in write text + _ -> do + let invalidDecoderExpected :: Expr Void Void + invalidDecoderExpected = Dhall.Core.Text + + let invalidDecoderExpression :: Expr Void Void + invalidDecoderExpression = res + + Control.Exception.throwIO (Dhall.InvalidDecoder {..}) + +-- | Copy as much as possible the setup in "Dhall.Main". If that module +-- changes, this should update as well. +asCommand + :: AsCommand + -> ((Input -> IO (Expr Src Dhall.Core.Import)) -> (Input -> FilePath) -> IO ()) + -> IO () +asCommand AsCommand{..} act = do + GHC.IO.Encoding.setLocaleEncoding System.IO.utf8 + + let rootDirectory = \case + InputFile f -> System.FilePath.takeDirectory f + StandardInput -> "." + + let getExpression = Dhall.Util.getExpression censor + + let handle io = + Control.Exception.catches io + [ Handler handleTypeError + , Handler handleImported + , Handler handleExitCode + ] + where + handleAll e = do + let string = show (e :: SomeException) + + if not (null string) + then System.IO.hPutStrLn System.IO.stderr string + else return () + + System.Exit.exitFailure + + handleTypeError e = Control.Exception.handle handleAll $ do + let _ = e :: TypeError Src Void + System.IO.hPutStrLn System.IO.stderr "" + if explain + then + case censor of + Censor -> Control.Exception.throwIO (CensoredDetailed (DetailedTypeError e)) + NoCensor -> Control.Exception.throwIO (DetailedTypeError e) + + else do + Data.Text.IO.hPutStrLn System.IO.stderr "\ESC[2mUse \"dhall --explain\" for detailed errors\ESC[0m" + case censor of + Censor -> Control.Exception.throwIO (Censored e) + NoCensor -> Control.Exception.throwIO e + + handleImported (Imported ps e) = Control.Exception.handle handleAll $ do + let _ = e :: TypeError Src Void + System.IO.hPutStrLn System.IO.stderr "" + if explain + then Control.Exception.throwIO (Imported ps (DetailedTypeError e)) + else do + Data.Text.IO.hPutStrLn System.IO.stderr "\ESC[2mUse \"dhall --explain\" for detailed errors\ESC[0m" + Control.Exception.throwIO (Imported ps e) + + handleExitCode e = + Control.Exception.throwIO (e :: ExitCode) + + handle $ act getExpression rootDirectory +