[dhall format] Prefer unquoted URLs (#1235)

* [dhall format] Prefer unquoted URLs

This updates `dhall format` to prefer unquoted URLs.

I included the test cases described in #1109, but along the way I
discovered a standard bug so I have opened dhall-lang/dhall-lang#704 to
fix it.  This change depends on that upstream fix.

Fixes #1109.

* pull in latest dhall-lang

* skip unimplemented tests

dhall/dhall-lang

@@ -1 +1 @@
-Subproject commit fb5b9b7e7919bd77dbfc9719258640c98b85c537
+Subproject commit fbcc2b9ad64c50dd0f0c9967cdea7066edfa80e8

dhall/dhall.cabal

@@ -458,6 +458,7 @@ Library
         megaparsec                  >= 6.5.0    && < 7.1 ,
         memory                      >= 0.14     && < 0.15,
         mtl                         >= 2.2.1    && < 2.3 ,
+        network-uri                 >= 2.6      && < 2.7 ,
         optparse-applicative        >= 0.14.0.0 && < 0.16,
         parsers                     >= 0.12.4   && < 0.13,
         prettyprinter               >= 1.2.0.1  && < 1.3 ,

dhall/src/Dhall/Core.hs

@@ -108,7 +108,7 @@ import qualified Data.Text
 import qualified Data.Text.Prettyprint.Doc  as Pretty
 import qualified Dhall.Map
 import qualified Dhall.Set
-import qualified Network.URI.Encode         as URI.Encode
+import qualified Network.URI                as URI
 import qualified Text.Printf
 
 
@@ -2260,11 +2260,8 @@ prettyPathComponent text
         "/\"" <> Pretty.pretty text <> "\""
 
 prettyURIComponent :: Text -> Doc ann
-prettyURIComponent text
-    | Data.Text.all (\c -> pathCharacter c && URI.Encode.isAllowed c) text =
-        "/" <> Pretty.pretty text
-    | otherwise =
-        "/\"" <> Pretty.pretty text <> "\""
+prettyURIComponent text =
+        Pretty.pretty $ URI.normalizeCase $ URI.normalizeEscape $ "/" <> Data.Text.unpack text
 
 {-| Convenience utility for converting `Either`-based exceptions to `IO`-based
     exceptions

dhall/src/Dhall/Parser/Token.hs

@@ -388,16 +388,18 @@ pathComponent componentType = do
                 FileComponent -> do
                     Text.Megaparsec.takeWhile1P Nothing Dhall.Core.pathCharacter
                 URLComponent -> do
-                    text <- star pchar
-
-                    return (URI.Encode.decodeText text)
+                    star pchar
 
     let quotedPathData = do
             _    <- Text.Parser.Char.char '"'
             text <- Text.Megaparsec.takeWhile1P Nothing quotedPathCharacter
             _    <- Text.Parser.Char.char '"'
 
-            return text
+            case componentType of
+              FileComponent -> do
+                return text
+              URLComponent -> do
+                return (URI.Encode.encodeText text)
 
     quotedPathData <|> pathData
 

dhall/tests/Dhall/Test/Normalization.hs

@@ -44,9 +44,11 @@ getTests = do
             (Turtle.lstree "./dhall-lang/tests/alpha-normalization/success/")
 
     let unitTestFiles = do
-            path <- Turtle.lstree "./dhall-lang/tests/normalization/success/unit"
+            path <- Turtle.lstree (normalizationDirectory </> "unit/")
 
-            let skip = []
+            let skip = [ normalizationDirectory </> "unit/RecursiveRecordMergeWithinFieldSelection3A.dhall"
+                       , normalizationDirectory </> "unit/RightBiasedMergeWithinFieldSelection3A.dhall"
+                       ]
 
             Monad.guard (path `notElem` skip)
 

dhall/tests/Dhall/Test/TypeCheck.hs

@@ -25,7 +25,23 @@ typecheckDirectory = "./dhall-lang/tests/typecheck"
 
 getTests :: IO TestTree
 getTests = do
-    successTests <- Test.Util.discover (Turtle.chars <* "A.dhall") successTest (Turtle.lstree (typecheckDirectory </> "success"))
+    let successTestFiles = do
+            path <- Turtle.lstree (typecheckDirectory </> "success")
+            let skip = [ typecheckDirectory </> "success/preferMixedRecordsA.dhall"
+                       , typecheckDirectory </> "success/preferMixedRecordsSameFieldA.dhall"
+                       , typecheckDirectory </> "success/preludeA.dhall" -- fixed in dhall-lang/dhall-lang#708
+                       , typecheckDirectory </> "success/RecordTypeMixedKindsA.dhall"
+                       , typecheckDirectory </> "success/simple/combineMixedRecordsA.dhall"
+                       , typecheckDirectory </> "success/simple/RecordMixedKinds2A.dhall"
+                       , typecheckDirectory </> "success/simple/RecordMixedKindsA.dhall"
+                       , typecheckDirectory </> "success/simple/RecursiveRecordMergeMixedKindsA.dhall"
+                       , typecheckDirectory </> "success/simple/RightBiasedRecordMergeMixedKindsA.dhall"
+                       ]
+            Monad.guard (path `notElem` skip)
+
+            return path
+
+    successTests <- Test.Util.discover (Turtle.chars <* "A.dhall") successTest successTestFiles
 
     let failureTestFiles = do
             path <- Turtle.lstree (typecheckDirectory </> "failure")

dhall/tests/Dhall/Test/TypeInference.hs

@@ -33,6 +33,9 @@ getTests = do
                          -- fails due to `Expr`'s 'Eq' instance, which inherits the
                          -- @NaN /= NaN@ inequality from 'Double'.
                          typeInferenceDirectory </> "success/unit/AssertNaNA.dhall"
+                       , typeInferenceDirectory </> "success/unit/RecursiveRecordMergeBoolTypeA.dhall"
+                       , typeInferenceDirectory </> "success/simple/RecordTypeMixedKinds2A.dhall"
+                       , typeInferenceDirectory </> "success/simple/RecordTypeMixedKinds3A.dhall"
                        ]
 
             Monad.guard (path `notElem` skip)

dhall/tests/format/urlsA.dhall

@@ -0,0 +1,13 @@
+let unreserved = http://x/y%7ez
+
+let uppercasehex = http://x/y%3bz
+
+let reserved = http://x/y:z
+
+let quoted = http://x/"y:z"
+
+let quotedPercent = http://x/"y%z"
+
+let snowman = http://x/"y☃z"
+
+in "done"

dhall/tests/format/urlsB.dhall

@@ -0,0 +1,13 @@
+let unreserved = http://x/y~z
+
+let uppercasehex = http://x/y%3Bz
+
+let reserved = http://x/y:z
+
+let quoted = http://x/y%3Az
+
+let quotedPercent = http://x/y%25z
+
+let snowman = http://x/y%E2%98%83z
+
+in  "done"