dhall 1.41.1 → 1.41.2
raw patch · 13 files changed
+278/−86 lines, 13 filesdep +indexed-traversabledep +text-shortdep ~mtldep ~template-haskelldep ~timePVP ok
version bump matches the API change (PVP)
Dependencies added: indexed-traversable, text-short
Dependency ranges changed: mtl, template-haskell, time, transformers, turtle
API changes (from Hackage documentation)
+ Dhall.Marshal.Decode: dayOfWeek :: Decoder DayOfWeek
+ Dhall.Marshal.Decode: instance Dhall.Marshal.Decode.FromDhall Data.Text.Short.Internal.ShortText
+ Dhall.Marshal.Decode: instance Dhall.Marshal.Decode.FromDhall Data.Time.Calendar.Week.DayOfWeek
+ Dhall.Marshal.Decode: shortText :: Decoder ShortText
+ Dhall.Marshal.Encode: instance Dhall.Marshal.Encode.ToDhall Data.Text.Short.Internal.ShortText
+ Dhall.Marshal.Encode: instance Dhall.Marshal.Encode.ToDhall Data.Time.Calendar.Week.DayOfWeek
Files
- CHANGELOG.md +18/−0
- dhall.cabal +15/−5
- src/Dhall/Marshal/Decode.hs +55/−0
- src/Dhall/Marshal/Encode.hs +40/−0
- src/Dhall/Normalize.hs +13/−2
- src/Dhall/Pretty/Internal.hs +2/−1
- src/Dhall/Repl.hs +2/−1
- src/Dhall/Tutorial.hs +14/−15
- src/Dhall/TypeCheck.hs +3/−5
- tests/Dhall/Test/Freeze.hs +3/−0
- tests/Dhall/Test/Import.hs +42/−11
- tests/Dhall/Test/TypeInference.hs +1/−1
- tests/Dhall/Test/Util.hs +70/−45
CHANGELOG.md view
@@ -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)
dhall.cabal view
@@ -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
src/Dhall/Marshal/Decode.hs view
@@ -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`.
src/Dhall/Marshal/Encode.hs view
@@ -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.
src/Dhall/Normalize.hs view
@@ -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
src/Dhall/Pretty/Internal.hs view
@@ -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
src/Dhall/Repl.hs view
@@ -294,7 +294,8 @@ normalizedExpression <- normalize loadedExpression - writeOutputHandle $ hashExpressionToCode normalizedExpression+ writeOutputHandle+ (hashExpressionToCode (Dhall.Core.alphaNormalize normalizedExpression)) saveFilePrefix :: FilePath saveFilePrefix = ".dhall-repl"
src/Dhall/Tutorial.hs view
@@ -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 #-} -- >
src/Dhall/TypeCheck.hs view
@@ -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₀')
tests/Dhall/Test/Freeze.hs view
@@ -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)
tests/Dhall/Test/Import.hs view
@@ -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
tests/Dhall/Test/TypeInference.hs view
@@ -59,7 +59,7 @@ successTest prefix = do let expectedFailures = []-#ifdef WITH_HTTP+#if defined(WITH_HTTP) && defined(NETWORK_TESTS) #else ++ [ typeInferenceDirectory </> "success/CacheImports" ]
tests/Dhall/Test/Util.hs view
@@ -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)