diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,21 @@ +1.41.2 + +* [BUG FIX: Fix `:hash` REPL command to α-normalize input](https://github.com/dhall-lang/dhall-haskell/pull/2420) +* [Add `{From,To}Dhall` instances for `DayOfWeek`](https://github.com/dhall-lang/dhall-haskell/pull/2413) +* [Add `{From,To}Dhall` instances for `ShortText`](https://github.com/dhall-lang/dhall-haskell/pull/2413) +* Performance improvements + * [#2423](https://github.com/dhall-lang/dhall-haskell/pull/2423) +* Fixes and improvements to haddocks + * [#2396](https://github.com/dhall-lang/dhall-haskell/pull/2396) +* Fixes and improvements to test suite + * [#2342](https://github.com/dhall-lang/dhall-haskell/pull/2382) + * [#2394](https://github.com/dhall-lang/dhall-haskell/pull/2394) +* Build against newer dependencies + * [`pretty-simple-4.1`](https://github.com/dhall-lang/dhall-haskell/pull/2408) + * [`aeson-2.1`](https://github.com/dhall-lang/dhall-haskell/pull/2424) + * [`vector-0.13`](https://github.com/dhall-lang/dhall-haskell/pull/2427) + * [`turtle-1.6`](https://github.com/dhall-lang/dhall-haskell/pull/2431) + 1.41.1 * [BUG FIX: Don't escape `?` path component when pretty-printing `with` expressions](https://github.com/dhall-lang/dhall-haskell/pull/2392) diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.4 Name: dhall -Version: 1.41.1 +Version: 1.41.2 Build-Type: Simple License: BSD-3-Clause License-File: LICENSE @@ -196,10 +196,15 @@ Default: False Manual: True +Flag network-tests + Description: Enable tests which depend on an internet connection + Default: True + Manual: True + Common common Build-Depends: base >= 4.11.0.0 && < 5 , - aeson >= 1.0.0.0 && < 2.1 , + aeson >= 1.0.0.0 && < 2.2 , aeson-pretty < 0.9 , ansi-terminal >= 0.6.3.1 && < 0.12, atomic-write >= 0.2.0.7 && < 0.3 , @@ -221,6 +226,7 @@ half >= 0.2.2.3 && < 0.4 , haskeline >= 0.7.2.1 && < 0.9 , hashable >= 1.2 && < 1.5 , + indexed-traversable < 0.2 , lens-family-core >= 1.0.0 && < 2.2 , -- megaparsec follows SemVer: https://github.com/mrkkrp/megaparsec/issues/469#issuecomment-927918469 megaparsec >= 8 && < 10 , @@ -232,7 +238,7 @@ parser-combinators , prettyprinter >= 1.7.0 && < 1.8 , prettyprinter-ansi-terminal >= 1.1.1 && < 1.2 , - pretty-simple < 4.1 , + pretty-simple < 4.2 , profunctors >= 3.1.2 && < 5.7 , repline >= 0.4.0.0 && < 0.5 , serialise >= 0.2.0.0 && < 0.3 , @@ -240,12 +246,13 @@ template-haskell >= 2.13.0.0 && < 2.19, text >= 0.11.1.0 && < 2.1 , text-manipulate >= 0.2.0.1 && < 0.4 , + text-short >= 0.1 && < 0.2 , th-lift-instances >= 0.1.13 && < 0.2 , time >= 1.1.4 && < 1.13, transformers >= 0.5.2.0 && < 0.6 , unordered-containers >= 0.1.3.0 && < 0.3 , uri-encode < 1.6 , - vector >= 0.11.0.0 && < 0.13 + vector >= 0.11.0.0 && < 0.14 if flag(with-http) CPP-Options: @@ -253,6 +260,9 @@ if flag(use-http-client-tls) CPP-Options: -DUSE_HTTP_CLIENT_TLS + if flag(network-tests) + CPP-Options: + -DNETWORK_TESTS GHC-Options: -Wall -Wcompat -Wincomplete-uni-patterns @@ -410,7 +420,7 @@ tasty-quickcheck >= 0.9.2 && < 0.11, tasty-silver < 3.4 , temporary >= 1.2.1 && < 1.4 , - turtle < 1.6 , + turtle < 1.7 , Default-Language: Haskell2010 Test-Suite doctest diff --git a/src/Dhall/Marshal/Decode.hs b/src/Dhall/Marshal/Decode.hs --- a/src/Dhall/Marshal/Decode.hs +++ b/src/Dhall/Marshal/Decode.hs @@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -54,6 +55,7 @@ , string , lazyText , strictText + , shortText -- ** Time , timeOfDay , day @@ -61,6 +63,7 @@ , localTime , zonedTime , utcTime + , dayOfWeek -- ** Containers , maybe , pair @@ -151,6 +154,7 @@ ( Chunks (..) , DhallDouble (..) , Expr (..) + , FieldSelection (..) , FunctionBinding (..) , Var (..) ) @@ -173,6 +177,7 @@ import qualified Data.Set import qualified Data.Text import qualified Data.Text.Lazy +import qualified Data.Text.Short import qualified Data.Time as Time import qualified Data.Vector import qualified Dhall.Core as Core @@ -300,6 +305,9 @@ instance {-# OVERLAPS #-} FromDhall [Char] where autoWith _ = string +instance FromDhall Data.Text.Short.ShortText where + autoWith _ = shortText + instance FromDhall Data.Text.Lazy.Text where autoWith _ = lazyText @@ -336,6 +344,9 @@ instance FromDhall Time.UTCTime where autoWith _ = utcTime +instance FromDhall Time.DayOfWeek where + autoWith _ = dayOfWeek + {-| Note that this instance will throw errors in the presence of duplicates in the list. To ignore duplicates, use `setIgnoringDuplicates`. -} @@ -906,6 +917,14 @@ expected = pure Double +{-| Decode `Data.Text.Short.ShortText`. + +>>> input shortText "\"Test\"" +"Test" +-} +shortText :: Decoder Data.Text.Short.ShortText +shortText = fmap Data.Text.Short.fromText strictText + {-| Decode lazy `Data.Text.Text`. >>> input lazyText "\"Test\"" @@ -998,6 +1017,42 @@ -} utcTime :: Decoder Time.UTCTime utcTime = Time.zonedTimeToUTC <$> zonedTime + +{-| Decode `Time.DayOfWeek` + +>>> input dayOfWeek "< Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday >.Monday" +Monday +-} +dayOfWeek :: Decoder Time.DayOfWeek +dayOfWeek = Decoder{..} + where + extract expr@(Field _ FieldSelection{ fieldSelectionLabel }) = + case fieldSelectionLabel of + "Sunday" -> pure Time.Sunday + "Monday" -> pure Time.Monday + "Tuesday" -> pure Time.Tuesday + "Wednesday" -> pure Time.Wednesday + "Thursday" -> pure Time.Thursday + "Friday" -> pure Time.Friday + "Saturday" -> pure Time.Saturday + _ -> typeError expected expr + extract expr = + typeError expected expr + + expected = + pure + (Union + (Dhall.Map.fromList + [ ("Sunday", Nothing) + , ("Monday", Nothing) + , ("Tuesday", Nothing) + , ("Wednesday", Nothing) + , ("Thursday", Nothing) + , ("Friday", Nothing) + , ("Saturday", Nothing) + ] + ) + ) {-| Decode a `Maybe`. diff --git a/src/Dhall/Marshal/Encode.hs b/src/Dhall/Marshal/Encode.hs --- a/src/Dhall/Marshal/Encode.hs +++ b/src/Dhall/Marshal/Encode.hs @@ -83,6 +83,7 @@ import qualified Data.Set import qualified Data.Text import qualified Data.Text.Lazy +import qualified Data.Text.Short import qualified Data.Time as Time import qualified Data.Vector import qualified Data.Void @@ -166,6 +167,14 @@ declared = Bool +instance ToDhall Data.Text.Short.ShortText where + injectWith _ = Encoder {..} + where + embed text = + TextLit (Chunks [] (Data.Text.Short.toText text)) + + declared = Text + instance ToDhall Data.Text.Lazy.Text where injectWith _ = Encoder {..} where @@ -381,6 +390,37 @@ instance ToDhall Time.UTCTime where injectWith = contramap (Time.utcToZonedTime Time.utc) . injectWith + +instance ToDhall Time.DayOfWeek where + injectWith _ = Encoder{..} + where + embed Time.Sunday = + Field declared (Core.makeFieldSelection "Sunday") + embed Time.Monday = + Field declared (Core.makeFieldSelection "Monday" ) + embed Time.Tuesday = + Field declared (Core.makeFieldSelection "Tuesday") + embed Time.Wednesday = + Field declared (Core.makeFieldSelection "Wednesday") + embed Time.Thursday = + Field declared (Core.makeFieldSelection "Thursday") + embed Time.Friday = + Field declared (Core.makeFieldSelection "Friday") + embed Time.Saturday = + Field declared (Core.makeFieldSelection "Saturday") + + declared = + Union + (Dhall.Map.fromList + [ ("Sunday", Nothing) + , ("Monday", Nothing) + , ("Tuesday", Nothing) + , ("Wednesday", Nothing) + , ("Thursday", Nothing) + , ("Friday", Nothing) + , ("Saturday", Nothing) + ] + ) {-| Note that the output list will be sorted. diff --git a/src/Dhall/Normalize.hs b/src/Dhall/Normalize.hs --- a/src/Dhall/Normalize.hs +++ b/src/Dhall/Normalize.hs @@ -629,8 +629,12 @@ return $ case x' of Field (Union ktsY) (Syntax.fieldSelectionLabel -> kY) -> case Dhall.Map.lookup kY ktsY of - Just _ -> TextLit (Chunks [] kY) + Just Nothing -> TextLit (Chunks [] kY) _ -> ShowConstructor x' + App (Field (Union ktsY) (Syntax.fieldSelectionLabel -> kY)) _ -> + case Dhall.Map.lookup kY ktsY of + Just (Just _) -> TextLit (Chunks [] kY) + _ -> ShowConstructor x' Some _ -> TextLit (Chunks [] "Some") App None _ -> @@ -940,7 +944,14 @@ RecordLit _ -> False _ -> loop x && all loop t ShowConstructor x -> loop x && case x of - Field (Union _) _ -> False + Field (Union kts) (Syntax.fieldSelectionLabel -> k) -> + case Dhall.Map.lookup k kts of + Just Nothing -> False + _ -> True + App (Field (Union kts) (Syntax.fieldSelectionLabel -> k)) _ -> + case Dhall.Map.lookup k kts of + Just (Just _) -> False + _ -> True Some _ -> False App None _ -> False _ -> True diff --git a/src/Dhall/Pretty/Internal.hs b/src/Dhall/Pretty/Internal.hs --- a/src/Dhall/Pretty/Internal.hs +++ b/src/Dhall/Pretty/Internal.hs @@ -1900,7 +1900,8 @@ Pretty.defaultLayoutOptions { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } -{-| Convert an expression representing a temporal value to `Text`, if possible +{-| Convert an expression representing a temporal value to `Data.Text.Text`, if + possible This is used by downstream integrations (e.g. `dhall-json` for treating temporal values as strings diff --git a/src/Dhall/Repl.hs b/src/Dhall/Repl.hs --- a/src/Dhall/Repl.hs +++ b/src/Dhall/Repl.hs @@ -294,7 +294,8 @@ normalizedExpression <- normalize loadedExpression - writeOutputHandle $ hashExpressionToCode normalizedExpression + writeOutputHandle + (hashExpressionToCode (Dhall.Core.alphaNormalize normalizedExpression)) saveFilePrefix :: FilePath saveFilePrefix = ".dhall-repl" diff --git a/src/Dhall/Tutorial.hs b/src/Dhall/Tutorial.hs --- a/src/Dhall/Tutorial.hs +++ b/src/Dhall/Tutorial.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE CPP #-} {-| Dhall is a programming language specialized for configuration files. This module contains a tutorial explaining how to author configuration files @@ -375,13 +376,23 @@ -- -- ... and you can reference that expression either directly: -- +#if defined(WITH_HTTP) && defined(USE_HTTP_CLIENT_TLS) && defined(NETWORK_TESTS) -- >>> input auto "https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool -- True +#else +-- > >>> input auto "https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool +-- > True +#endif -- -- ... or inside of a larger expression: -- +#if defined(WITH_HTTP) && defined(USE_HTTP_CLIENT_TLS) && defined(NETWORK_TESTS) -- >>> input auto "False == https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool -- False +#else +-- > >>> input auto "False == https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool +-- > False +#endif -- -- You're not limited to hosting Dhall expressions on GitHub. You can host a -- Dhall expression anywhere that you can host UTF8-encoded text on the web, @@ -1968,6 +1979,7 @@ -- $substitutions -- -- Substitutions are another way to extend the language. +-- -- Suppose we have the following Haskell datatype: -- -- > data Result = Failure Integer | Success String @@ -1985,22 +1997,9 @@ -- Right now it is quite easy to keep these two definitions (the one in Haskell source and the one in the Dhall file) synchronized: -- If we implement a new feature in the Haskell source we update the corresponding type in the Dhall file. -- But what happens if our application is growing and our Result type contains e.g. 10 unions with possible types embedded in it? --- Maintaining the code will get tedious. Luckily we can extract the correct Dhall type from the Haskell definition: -- --- > resultDecoder :: Dhall.Decoder Result --- > resultDecoder = Dhall.auto --- > --- > resultType :: Expr Src Void --- > resultType = maximum $ Dhall.expected resultDecoder --- > --- > resultTypeString :: String --- > resultTypeString = show $ pretty resultType --- --- Now we just have to inject that type into the Dhall code and we are done. One common way to do that is to wrap the import of example.dhall in a let expression: --- --- > Dhall.input (Dhall.auto :: Dhall.Decoder Result) ("let Result = " <> Data.Text.pack resultTypeString <> " in ./example.dhall") --- --- Now we can omit the definition of Result in our example.dhall file. While this will work perfectly Dhall provides a cleaner solution for our \"injection problem\": +-- We can override the interpreter's @evaluateSettings@ with a custom set of +-- substitutions, like this: -- -- > {-# LANGUAGE OverloadedStrings #-} -- > diff --git a/src/Dhall/TypeCheck.hs b/src/Dhall/TypeCheck.hs --- a/src/Dhall/TypeCheck.hs +++ b/src/Dhall/TypeCheck.hs @@ -35,7 +35,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid (Endo (..)) import Data.Semigroup (Max (..)) -import Data.Sequence (Seq, ViewL (..)) +import Data.Sequence (ViewL (..)) import Data.Set (Set) import Data.Text (Text) import Data.Typeable (Typeable) @@ -65,6 +65,7 @@ ) import qualified Data.Foldable as Foldable +import qualified Data.Foldable.WithIndex as Foldable.WithIndex import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map import qualified Data.Sequence @@ -93,9 +94,6 @@ type X = Void {-# DEPRECATED X "Use Data.Void.Void instead" #-} -traverseWithIndex_ :: Applicative f => (Int -> a -> f b) -> Seq a -> f () -traverseWithIndex_ k xs = Foldable.sequenceA_ (Data.Sequence.mapWithIndex k xs) - axiom :: Const -> Either (TypeError s a) Const axiom Type = return Kind axiom Kind = return Sort @@ -631,7 +629,7 @@ Left (TypeError context t₁ err) - traverseWithIndex_ process ts₁ + Foldable.WithIndex.itraverse_ process ts₁ return (VList _T₀') diff --git a/tests/Dhall/Test/Freeze.hs b/tests/Dhall/Test/Freeze.hs --- a/tests/Dhall/Test/Freeze.hs +++ b/tests/Dhall/Test/Freeze.hs @@ -1,5 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} +-- FIXME: Re-enable deprecation warnings after removing support for turtle < 1.6. +{-# OPTIONS_GHC -Wno-deprecations #-} + module Dhall.Test.Freeze where import Data.Text (Text) diff --git a/tests/Dhall/Test/Import.hs b/tests/Dhall/Test/Import.hs --- a/tests/Dhall/Test/Import.hs +++ b/tests/Dhall/Test/Import.hs @@ -1,16 +1,19 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} +-- FIXME: Re-enable deprecation warnings after removing support for turtle < 1.6. +{-# OPTIONS_GHC -Wno-deprecations #-} + module Dhall.Test.Import where -import Control.Exception (SomeException) -import Data.Foldable (fold) -import Data.Text (Text, isSuffixOf) -import Data.Void (Void) -import Filesystem.Path.CurrentOS (toText) -import Prelude hiding (FilePath) -import Test.Tasty (TestTree) -import Turtle (FilePath, ()) +import Control.Exception (SomeException) +import Data.Foldable (fold) +import Data.Text (Text, isSuffixOf) +import Data.Void (Void) +import Prelude hiding (FilePath) +import Test.Tasty (TestTree) +import Turtle (FilePath, toText, ()) import qualified Control.Exception as Exception import qualified Control.Monad as Monad @@ -21,14 +24,18 @@ import qualified Dhall.Import as Import import qualified Dhall.Parser as Parser import qualified Dhall.Test.Util as Test.Util -import qualified Network.HTTP.Client as HTTP -import qualified Network.HTTP.Client.TLS as HTTP import qualified System.FilePath as FilePath import qualified System.IO.Temp as Temp import qualified Test.Tasty as Tasty import qualified Test.Tasty.HUnit as Tasty.HUnit import qualified Turtle +#if defined(WITH_HTTP) && defined(NETWORK_TESTS) +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.TLS as HTTP +#endif + + importDirectory :: FilePath importDirectory = "./dhall-lang/tests/import" @@ -62,6 +69,18 @@ let expectedSuccesses = [ importDirectory "failure/unit/DontRecoverCycle.dhall" , importDirectory "failure/unit/DontRecoverTypeError.dhall" +#if !(defined(WITH_HTTP) && defined(NETWORK_TESTS)) + -- We attempt to simulate test.dhall-lang.org, but even so + -- some tests unexpectedly succeed due to the inadequacy of + -- the simulation + , importDirectory "failure/unit/cors/OnlySelf.dhall" + , importDirectory "failure/unit/cors/OnlyOther.dhall" + , importDirectory "failure/unit/cors/Null.dhall" + , importDirectory "failure/unit/cors/TwoHops.dhall" + , importDirectory "failure/unit/cors/Empty.dhall" + , importDirectory "failure/unit/cors/NoCORS.dhall" + , importDirectory "failure/originHeadersFromRemote.dhall" +#endif ] _ <- Monad.guard (path `notElem` expectedSuccesses) @@ -84,7 +103,15 @@ let directoryString = FilePath.takeDirectory inputPath - let expectedFailures = [ ] + let expectedFailures = + [ +#if !(defined(WITH_HTTP) && defined(NETWORK_TESTS)) + importDirectory "success/originHeadersImportFromEnv" + , importDirectory "success/originHeadersImport" + , importDirectory "success/originHeadersOverride" + , importDirectory "success/unit/asLocation/RemoteChainEnv" +#endif + ] Test.Util.testCase prefix expectedFailures (do @@ -98,6 +125,7 @@ let originalCache = "dhall-lang/tests/import/cache" +#if defined(WITH_HTTP) && defined(NETWORK_TESTS) let httpManager = HTTP.newManager HTTP.tlsManagerSettings @@ -108,6 +136,9 @@ httpManager (pure Import.envOriginHeaders) directoryString +#else + let status = Import.emptyStatus directoryString +#endif let load = State.evalStateT diff --git a/tests/Dhall/Test/TypeInference.hs b/tests/Dhall/Test/TypeInference.hs --- a/tests/Dhall/Test/TypeInference.hs +++ b/tests/Dhall/Test/TypeInference.hs @@ -59,7 +59,7 @@ successTest prefix = do let expectedFailures = [] -#ifdef WITH_HTTP +#if defined(WITH_HTTP) && defined(NETWORK_TESTS) #else ++ [ typeInferenceDirectory "success/CacheImports" ] diff --git a/tests/Dhall/Test/Util.hs b/tests/Dhall/Test/Util.hs --- a/tests/Dhall/Test/Util.hs +++ b/tests/Dhall/Test/Util.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} @@ -49,7 +50,6 @@ 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 @@ -64,9 +64,11 @@ import qualified Test.Tasty.ExpectedFailure as Tasty.ExpectedFailure import qualified Turtle -#ifndef WITH_HTTP +#if defined(WITH_HTTP) && defined(NETWORK_TESTS) +import qualified Data.Foldable +#else import Control.Monad.IO.Class (MonadIO (..)) -import Dhall.Core (URL (..)) +import Dhall.Core (URL (..), File (..), Directory (..)) import Lens.Family.State.Strict (zoom) import qualified Data.Foldable @@ -104,62 +106,85 @@ (loadWith expression) (Dhall.Import.emptyStatus rootDirectory) { _semanticCacheMode = semanticCacheMode } -#ifdef WITH_HTTP +#if defined(WITH_HTTP) && defined(NETWORK_TESTS) loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void) loadWith = Dhall.Import.loadWith #else loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void) loadWith expr = do - let mockRemote' url = do - liftIO . putStrLn $ "\nTesting without real HTTP support --" - ++ " using mock HTTP client to resolve remote import." - mockRemote url - zoom Dhall.Import.remote (State.put mockRemote') + zoom Dhall.Import.remote (State.put mockRemote) Dhall.Import.loadWith expr mockRemote :: Dhall.Core.URL -> StateT Status IO Data.Text.Text --- Matches anything pointing to --- `https://raw.githubusercontent.com/dhall-lang/dhall-lang/master/` -mockRemote (URL { authority = "raw.githubusercontent.com" - , path = Dhall.Core.File (Dhall.Core.Directory components) file }) - | take 3 (reverse components) == ["dhall-lang", "dhall-lang", "master"] = do - let dropEnd n ls = take (length ls - n) ls - let localDir = dropEnd 3 components ++ ["dhall-lang"] +mockRemote + url@URL + { authority = "raw.githubusercontent.com" + , path = File (Directory components) file + } = do + let localDir = case reverse components of + "dhall-lang" : "dhall-lang" : _ : rest -> + reverse ("dhall-lang" : rest) + "Nadrieril" : "dhall-rust" : _ : "dhall" : rest -> + reverse ("dhall-lang" : rest) + _ -> do + fail ("Unable to mock URL: " <> Text.unpack (Dhall.Core.pretty url)) - localPath <- Dhall.Import.localToPath Dhall.Core.Here (Dhall.Core.File (Dhall.Core.Directory localDir) file) - liftIO $ Data.Text.IO.readFile localPath + localPath <- Dhall.Import.localToPath Dhall.Core.Here (File (Directory localDir) file) --- Matches anything pointing to --- `https://test.dhall-lang.org/Bool/package.dhall`; checks that a `test` header --- is present and redirects to the local copy of the prelude. -mockRemote (URL { authority = "test.dhall-lang.org" - , path = Dhall.Core.File (Dhall.Core.Directory components) file - , headers = Just headersExpr }) = - case Data.Foldable.find ((== "test") . fst) hs of - Nothing -> fail $ "(mock http) Tried to load an import from " - ++"\"test.dhall-lang.org\"" - ++ "without setting the \"test\" header field." - Just (_, _) -> do - let localDir = components ++ ["Prelude", "dhall-lang"] - localPath <- Dhall.Import.localToPath Dhall.Core.Here (Dhall.Core.File (Dhall.Core.Directory localDir) file) - liftIO $ Data.Text.IO.readFile localPath - where - hs = Dhall.Import.toHeaders headersExpr + liftIO (Data.Text.IO.readFile localPath) --- Emulates `https://httpbin.org/user-agent` -mockRemote (URL { authority = "httpbin.org" - , path = Dhall.Core.File (Dhall.Core.Directory []) "user-agent" - , headers = Just headersExpr }) = - case Data.Foldable.find ((== "user-agent") . fst) hs of - Nothing -> fail $ "(mock http) Tried to read the user agent via " - ++ "\"httpbin.com/user-agent\" without supplying one " - ++ "in the header!" - Just (_, userAgent) -> do +mockRemote + URL { authority = "prelude.dhall-lang.org" + , path = File (Directory components) file + } = do + let localDir = components ++ [ "Prelude", "dhall-lang" ] + + localPath <- Dhall.Import.localToPath Dhall.Core.Here (File (Directory localDir) file) + + liftIO (Data.Text.IO.readFile localPath) + +mockRemote url@URL{ authority = "test.dhall-lang.org", path, headers } = + case (path, fmap Dhall.Import.toHeaders headers) of + (File (Directory []) "foo", Just [("test", _)]) -> + return "./bar" + (File (Directory []) "bar", Just [("test", _)]) -> + return "True" + (File (Directory ["cors"]) "AllowedAll.dhall", _) -> + return "42" + (File (Directory ["cors"]) "OnlyGithub.dhall", _) -> + return "42" + (File (Directory ["cors"]) "OnlySelf.dhall", _) -> + return "42" + (File (Directory ["cors"]) "OnlyOther.dhall", _) -> + return "42" + (File (Directory ["cors"]) "Empty.dhall", _) -> + return "42" + (File (Directory ["cors"]) "NoCORS.dhall", _) -> + return "42" + (File (Directory ["cors"]) "Null.dhall", _) -> + return "42" + (File (Directory ["cors"]) "SelfImportAbsolute.dhall", _) -> + return "https://test.dhall-lang.org/cors/NoCORS.dhall" + (File (Directory ["cors"]) "SelfImportRelative.dhall", _) -> + return "./NoCORS.dhall" + (File (Directory ["cors"]) "TwoHopsFail.dhall", _) -> + return "https://raw.githubusercontent.com/dhall-lang/dhall-lang/5ff7ecd2411894dd9ce307dc23020987361d2d43/tests/import/data/cors/OnlySelf.dhall" + (File (Directory ["cors"]) "TwoHopsSuccess.dhall", _) -> + return "https://raw.githubusercontent.com/dhall-lang/dhall-lang/5ff7ecd2411894dd9ce307dc23020987361d2d43/tests/import/data/cors/OnlyGithub.dhall" + _ -> do + fail ("Unable to mock URL: " <> Text.unpack (Dhall.Core.pretty url)) + +mockRemote url@URL{ authority = "httpbin.org", path, headers } = + case (path, fmap Dhall.Import.toHeaders headers) of + (File (Directory []) "user-agent", Just [("user-agent", userAgent)]) -> do let agentText = Data.Text.Encoding.decodeUtf8 userAgent + return ("{\n \"user-agent\": \"" <> agentText <> "\"\n}\n") - where - hs = Dhall.Import.toHeaders headersExpr + (File (Directory []) "user-agent", Nothing) -> do + return ("{\n \"user-agent\": \"Dhall\"\n}\n") + _ -> do + fail ("Unable to mock URL: " <> Text.unpack (Dhall.Core.pretty url)) mockRemote url = do let urlString = Text.unpack (Dhall.Core.pretty url)