From 74a9bf258c37315e42deabf3853b705256e83f3c Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sun, 25 Jul 2021 16:21:53 +1000 Subject: [PATCH 1/2] support test-specific environment variables in import tests --- dhall/tests/Dhall/Test/Import.hs | 4 +- dhall/tests/Dhall/Test/Util.hs | 64 +++++++++++++++++++++++++++++++- 2 files changed, 66 insertions(+), 2 deletions(-) diff --git a/dhall/tests/Dhall/Test/Import.hs b/dhall/tests/Dhall/Test/Import.hs index 4fde6fa9d..4b5b3d9d8 100644 --- a/dhall/tests/Dhall/Test/Import.hs +++ b/dhall/tests/Dhall/Test/Import.hs @@ -124,7 +124,7 @@ successTest prefix = do Turtle.liftIO (Turtle.cptree originalCache tempdir) return tempdir - let setup = + let cacheSetup = if any endsIn usesCache then do cacheDir <- buildNewCache @@ -145,6 +145,8 @@ successTest prefix = do return () else pure () + let setup = cacheSetup >> Test.Util.managedTestEnvironment prefix + let resolve = Turtle.with setup (const load) let handler :: SomeException -> IO (Core.Expr Parser.Src Void) diff --git a/dhall/tests/Dhall/Test/Util.hs b/dhall/tests/Dhall/Test/Util.hs index 83a2d565a..4bfb2d268 100644 --- a/dhall/tests/Dhall/Test/Util.hs +++ b/dhall/tests/Dhall/Test/Util.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} module Dhall.Test.Util ( code @@ -19,15 +20,20 @@ module Dhall.Test.Util , discover , Dhall.Test.Util.testCase , toDhallPath + , managedTestEnvironment ) where import Control.Monad.Trans.State.Strict (StateT) +import Control.Applicative ((<|>), liftA2) +import Control.Exception (tryJust) +import Control.Monad (guard) import Data.Bifunctor (first) import Data.Text (Text) import Data.Void (Void) import Dhall.Context (Context) import Dhall.Core - ( Expr + ( Chunks(..) + , Expr(..) , Import , Normalizer , ReifiedNormalizer (..) @@ -35,6 +41,7 @@ import Dhall.Core import Dhall.Import (SemanticCacheMode (..), Status (..)) import Dhall.Parser (Src) import Prelude hiding (FilePath) +import System.IO.Error (isDoesNotExistError) import Test.Tasty (TestTree) import Test.Tasty.HUnit import Turtle (FilePath, Pattern, Shell, fp) @@ -42,11 +49,14 @@ import Turtle (FilePath, Pattern, Shell, fp) import qualified Control.Exception import qualified Control.Foldl as Foldl import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.Foldable import qualified Data.Functor import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO import qualified Dhall.Context import qualified Dhall.Core import qualified Dhall.Import +import qualified Dhall.Map import qualified Dhall.Parser import qualified Dhall.TypeCheck import qualified System.FilePath as FilePath @@ -157,6 +167,58 @@ mockRemote url = do <> urlString) #endif +{- Given a test prefix, returns a managed resource + which sets / reverts relevant environment variables based + on `prefix <> "ENV.dhall"` (if present) + -} +managedTestEnvironment :: Text -> Turtle.Managed [(Text, Maybe Text)] +managedTestEnvironment prefix = Turtle.managed (Control.Exception.bracket setup cleanup) + where + envPath = Text.unpack (prefix <> "ENV.dhall") + + setup :: IO [(Text, Maybe Text)] + setup = do + envFileContents <- + tryJust (guard . isDoesNotExistError) (Text.IO.readFile envPath) + + testEnv <- case envFileContents of + Right contents -> do + resolved <- code contents + return (convertEnvExpr (Dhall.Core.normalize resolved)) + Left _ -> return [] + + traverse setEnv testEnv + + cleanup :: [(Text, Maybe Text)] -> IO () + cleanup = Data.Foldable.traverse_ restoreEnv + + convertEnvExpr :: Expr Src Void -> [(Text, Text)] + convertEnvExpr (ListLit _ hs) = Data.Foldable.toList (Data.Foldable.fold maybePairs) + where + maybePairs = mapM toPair hs + + toPair :: Expr s a -> Maybe (Text, Text) + toPair (RecordLit m) = do + (Dhall.Core.recordFieldValue -> TextLit (Chunks [] key), Dhall.Core.recordFieldValue -> TextLit (Chunks [] value)) + <- lookupHeader <|> lookupMapKey + return (key, value) + where + lookupHeader = liftA2 (,) (Dhall.Map.lookup "header" m) (Dhall.Map.lookup "value" m) + lookupMapKey = liftA2 (,) (Dhall.Map.lookup "mapKey" m) (Dhall.Map.lookup "mapValue" m) + toPair _ = Nothing + convertEnvExpr _ = [] + + setEnv :: (Text, Text) -> IO (Text, Maybe Text) + setEnv (k, v) = do + old <- Turtle.need k + _ <- putStrLn $ Text.unpack $ "Setting env: "<>k <> "="<>v + Turtle.export k v + return (k, old) + + restoreEnv :: (Text, Maybe Text) -> IO () + restoreEnv (k, Just old) = Turtle.export k old + restoreEnv (k, Nothing) = Turtle.unset k + equivalent :: Text -> Text -> IO () equivalent text0 text1 = do expr0 <- fmap Dhall.Core.normalize (code text0) :: IO (Expr Void Void) From befb4de900ae93db256fc977f7b2a6746dd8bbde Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sun, 15 Aug 2021 14:12:13 +1000 Subject: [PATCH 2/2] remove console output in test env setup --- dhall/tests/Dhall/Test/Util.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/dhall/tests/Dhall/Test/Util.hs b/dhall/tests/Dhall/Test/Util.hs index 4bfb2d268..0d3eee763 100644 --- a/dhall/tests/Dhall/Test/Util.hs +++ b/dhall/tests/Dhall/Test/Util.hs @@ -211,7 +211,6 @@ managedTestEnvironment prefix = Turtle.managed (Control.Exception.bracket setup setEnv :: (Text, Text) -> IO (Text, Maybe Text) setEnv (k, v) = do old <- Turtle.need k - _ <- putStrLn $ Text.unpack $ "Setting env: "<>k <> "="<>v Turtle.export k v return (k, old)