diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,34 @@ +This repository contains some test JSON examples in test/*.json +that is downloaded from Twitter API and http://www.jquery4u.com/json/. +Naturally these are covered by other licenses. + +Code copyright (c) 2014, Michal J. Gajda + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Michal J. Gajda nor the names of other + 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 +OWNER 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,3 @@ +run-haskell-module +================== +Run freshly generated Haskell source code module. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,4 @@ +Changelog +========= + 0.0.1 Jan 2020 + * Initial version diff --git a/run-haskell-module.cabal b/run-haskell-module.cabal new file mode 100644 --- /dev/null +++ b/run-haskell-module.cabal @@ -0,0 +1,45 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 0d105f0142c4fbea46fc0f0bd6aaf9f891f5f4b75a748c0bc2d94e68f7ae8005 + +name: run-haskell-module +version: 0.0.1 +synopsis: Running newly generated Haskell source module. +description: To make sure freshly generated code runs, + we need to make it run in Stack/Cabal/GHC environment. +license: BSD3 +license-file: LICENSE +stability: beta +author: Michal J. Gajda, + Dmitrii Krylov +maintainer: simons@cryp.to, + mjgajda@gmail.com +copyright: Copyright by Michal J. Gajda '2014-'2020 +category: Data, Tools +build-type: Simple +extra-source-files: + README.md + changelog.md +tested-with: GHC==8.4.4 GHC==8.6.5 GHC==8.8.2 GHC==8.10.1 + +source-repository head + type: git + location: https://gitlab.com/migamake/json-autotype.git + +library + exposed-modules: + Language.Haskell.RunHaskellModule + other-modules: + Paths_run_haskell_module + hs-source-dirs: + src + build-depends: + base >=4.3 && <5 + , data-default >=0.7 && <0.8 + , filepath >=1.3 && <1.5 + , process >=1.1 && <1.7 + default-language: Haskell2010 diff --git a/src/Language/Haskell/RunHaskellModule.hs b/src/Language/Haskell/RunHaskellModule.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/RunHaskellModule.hs @@ -0,0 +1,167 @@ +-- | Functions for running generated modules +-- +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Language.Haskell.RunHaskellModule + ( RunOptions(..) + , compileHaskellModule + , compileHaskellModule' + , runHaskellModule + , runHaskellModule' + ) where + + +import Control.Exception +import Control.Monad +import Data.Char +import Data.Default +import System.Environment +import System.Exit +import System.FilePath.Posix +import System.IO +import System.Process + + +data RunOptions = RunOptions + { verbose :: Bool + , showStdout :: Bool + , compileArgs :: [String] + } + + +instance Default RunOptions where + def = RunOptions { verbose = False + , showStdout = False + , compileArgs = [] + } + + +data GhcTool = Runner | Compiler + + +-- | Call specified process with args and print its output when it fails. +-- +callProcess' :: RunOptions -> FilePath -> [String] -> IO ExitCode +callProcess' RunOptions{..} cmd args = do + when verbose $ putStrLn $ "Run \"" ++ cmd ++ "\" with args: " ++ show args + (_, pstdout, pstderr, p) <- createProcess ((proc cmd args) { std_out = if showStdout then Inherit else CreatePipe, std_err = CreatePipe }) + waitForProcess p >>= \case + ExitSuccess -> do + unless showStdout $ whenMaybe hClose pstdout + whenMaybe hClose pstderr + return ExitSuccess + ExitFailure r -> do + whenMaybe (dumpHandle stdout) pstdout + whenMaybe (dumpHandle stderr) pstderr + fail $ concat ["Running \"", cmd, "\" \"", show args, "\" has failed with \"", show r, "\""] + where + dumpHandle outhndl inhnd = hGetContents inhnd >>= hPutStr outhndl + whenMaybe a m = maybe (return ()) a m + + +-- | Splits commandline-like strings into "words", i.e. +-- ``` +-- -O0 --ghc-arg="-package scientific" --ghc-arg="-package xml-typelift" +-- ``` +-- transformed into 3 "words": +-- ``` +-- -O0 +-- --ghc-arg="-package scientific" +-- --ghc-arg="-package xml-typelift" +-- ``` +splitWithQuotes :: String -> [String] +splitWithQuotes [] = [] +splitWithQuotes (ch:cs) + | isSpace ch = splitWithQuotes $ dropWhile isSpace cs + | otherwise = word : splitWithQuotes strrest + where + (word, strrest) = takeWordOrQuote (ch:cs) + takeWordOrQuote :: String -> (String, String) + takeWordOrQuote str = let (w', rest) = takeWordOrQuote' "" False str in (reverse w', rest) + where + takeWordOrQuote' acc _ "" = (acc, "") + takeWordOrQuote' acc True ('"':"") = (acc, "") + takeWordOrQuote' acc True ('"':c:rest) + | isSpace c = ('"':acc, rest) + | otherwise = takeWordOrQuote' ('"':acc) False (c:rest) + takeWordOrQuote' acc True (c :rest) = takeWordOrQuote' (c:acc) True rest + takeWordOrQuote' acc False ('"':rest) = takeWordOrQuote' ('"':acc) True rest + takeWordOrQuote' acc False (c :rest) + | isSpace c = (acc, rest) + | otherwise = takeWordOrQuote' (c:acc) False rest + + +findGhc :: RunOptions + -> GhcTool + -> IO (FilePath, [String]) -- ^ returns (exe, special tool arguments) +findGhc RunOptions{..} ghcTool = do + when verbose $ do + let showEnv env = lookupEnv env >>= (\e -> putStrLn $ ">>> " ++ show env ++ " = " ++ show e) + showEnv "STACK_EXE" + showEnv "CABAL_SANDBOX_CONFIG" + showEnv "GHC_ENVIRONMENT" + showEnv "GHC_PACKAGE_PATH" + showEnv "HASKELL_DIST_DIR" + showEnv "CI_GHC_ADDITIONAL_FLAGS" + showEnv "CI_GHC_ADDITIONAL_PACKAGES" + showEnv "CI_GHC_CABAL_STYLE" + -- putStrLn "Environment: -----------" + -- getEnvironment >>= (mapM_ $ \(env,val) -> putStrLn $ env ++ " = " ++ val) + -- putStrLn "End of environment -----" + stack <- lookupEnv "STACK_EXE" + oldCabal <- lookupEnv "CABAL_SANDBOX_CONFIG" + newCabal <- lookupEnv "HASKELL_DIST_DIR" + additionalFlags <- (maybe [] splitWithQuotes) <$> lookupEnv "CI_GHC_ADDITIONAL_FLAGS" + additionalPackages <- ((additionalPackagesDef ++) . (maybe [] words)) <$> lookupEnv "CI_GHC_ADDITIONAL_PACKAGES" + cabalStyle <- (maybe "v2" id) <$> lookupEnv "CI_GHC_CABAL_STYLE" + let cabalExec = cabalStyle ++ "-exec" + let additionalPackagesArgs = map mkAdditionalPackagesArg additionalPackages + let res@(exe, exeArgs') | Just stackExec <- stack = (stackExec, additionalFlags ++ [tool, "--"]) + | Just _ <- oldCabal = ("cabal", ["exec", tool, "--"]) + | Just _ <- newCabal = ("cabal", [cabalExec, tool, "--"] ++ additionalPackagesArgs) + | otherwise = (tool, []) + exeArgs = case ghcTool of + Compiler -> exeArgs' ++ ["-O0"] + Runner -> exeArgs' + when verbose $ putStrLn $ "Use exe \"" ++ exe ++ "\", and additional arguments: " ++ show exeArgs + return res + where + tool = case ghcTool of + Runner -> "runghc" + Compiler -> "ghc" + mkAdditionalPackagesArg arg = case ghcTool of + Runner -> "--ghc-arg=-package " ++ arg + Compiler -> "-package " ++ arg + additionalPackagesDef = [] + + +passModuleToGhc :: RunOptions -> GhcTool -> FilePath -> [String] -> IO ExitCode +passModuleToGhc ro ghcTool moduleFilename args = + handle (\(e::SomeException) -> do print e >> throw e) $ do + (exe, exeArgs) <- findGhc ro ghcTool + callProcess' ro exe (exeArgs ++ moduleFilename:args) + + +-- | Find ghc with cabal or stack and compile Haskell module with specified arguments and run options +-- +compileHaskellModule' :: RunOptions -> FilePath -> [String] -> IO ExitCode +compileHaskellModule' ro moduleFilename args = passModuleToGhc ro Compiler moduleFilename args + +-- | Find ghc with cabal or stack and compile Haskell module with specified arguments +-- +compileHaskellModule :: FilePath -> [String] -> IO ExitCode +compileHaskellModule = compileHaskellModule' def + +-- | Find ghc with cabal or stack and run Haskell module in specified file with arguments and run options +-- +runHaskellModule' :: RunOptions -> FilePath -> [String] -> IO ExitCode +runHaskellModule' ro moduleFilename args = passModuleToGhc ro Runner moduleFilename args + + +-- | Find ghc with cabal or stack and run Haskell module in specified file with arguments +-- +runHaskellModule :: FilePath -> [String] -> IO ExitCode +runHaskellModule = runHaskellModule' def + +