Add support for quoted path components (#690)

... as standardized in dhall-lang/dhall-lang#293

Author: Gabriella439

dhall/dhall.cabal

@@ -322,6 +322,7 @@ Library
         text                        >= 0.11.1.0 && < 1.3 ,
         transformers                >= 0.2.0.0  && < 0.6 ,
         unordered-containers        >= 0.1.3.0  && < 0.3 ,
+        uri-encode                                 < 1.6 ,
         vector                      >= 0.11.0.0 && < 0.13
     if flag(with-http)
       Build-Depends:

dhall/src/Dhall/Core.hs

@@ -57,6 +57,7 @@ module Dhall.Core (
     , reservedIdentifiers
     , escapeText
     , subExpressions
+    , pathCharacter
     ) where
 
 #if MIN_VERSION_base(4,8,0)
@@ -75,7 +76,7 @@ import Data.String (IsString(..))
 import Data.Semigroup (Semigroup(..))
 import Data.Sequence (Seq, ViewL(..), ViewR(..))
 import Data.Text (Text)
-import Data.Text.Prettyprint.Doc (Pretty)
+import Data.Text.Prettyprint.Doc (Doc, Pretty)
 import Data.Traversable
 import Dhall.Map (Map)
 import Dhall.Set (Set)
@@ -131,10 +132,7 @@ instance Semigroup Directory where
         Directory (components₁ <> components₀)
 
 instance Pretty Directory where
-    pretty (Directory {..}) =
-        foldMap prettyComponent (reverse components)
-      where
-        prettyComponent text = "/" <> Pretty.pretty text
+    pretty (Directory {..}) = foldMap prettyPathComponent (reverse components)
 
 {-| A `File` is a `directory` followed by one additional path component
     representing the `file` name
@@ -145,7 +143,9 @@ data File = File
     } deriving (Eq, Generic, Ord, Show)
 
 instance Pretty File where
-    pretty (File {..}) = Pretty.pretty directory <> "/" <> Pretty.pretty file
+    pretty (File {..}) =
+            Pretty.pretty directory
+        <>  prettyPathComponent file
 
 instance Semigroup File where
     File directory₀ _ <> File directory₁ file =
@@ -2331,3 +2331,28 @@ subExpressions f (Project a b) = Project <$> f a <*> pure b
 subExpressions f (Note a b) = Note a <$> f b
 subExpressions f (ImportAlt l r) = ImportAlt <$> f l <*> f r
 subExpressions _ (Embed a) = pure (Embed a)
+
+{-| Returns `True` if the given `Char` is valid within an unquoted path
+    component
+
+    This is exported for reuse within the @"Dhall.Parser.Token"@ module
+-}
+pathCharacter :: Char -> Bool
+pathCharacter c =
+         '\x21' == c
+    ||  ('\x24' <= c && c <= '\x27')
+    ||  ('\x2A' <= c && c <= '\x2B')
+    ||  ('\x2D' <= c && c <= '\x2E')
+    ||  ('\x30' <= c && c <= '\x3B')
+    ||  c == '\x3D'
+    ||  ('\x40' <= c && c <= '\x5A')
+    ||  ('\x5E' <= c && c <= '\x7A')
+    ||  c == '\x7C'
+    ||  c == '\x7E'
+
+prettyPathComponent :: Text -> Doc ann
+prettyPathComponent text
+    | Data.Text.all pathCharacter text =
+        "/" <> Pretty.pretty text
+    | otherwise =
+        "/\"" <> Pretty.pretty text <> "\""

dhall/src/Dhall/Import.hs

@@ -189,6 +189,7 @@ import qualified Dhall.Map
 import qualified Dhall.Parser
 import qualified Dhall.Pretty.Internal
 import qualified Dhall.TypeCheck
+import qualified Network.URI.Encode
 import qualified System.Environment
 import qualified System.Directory                 as Directory
 import qualified System.FilePath                  as FilePath
@@ -610,13 +611,22 @@ exprFromUncachedImport (Import {..}) = do
 
             return (path, text)
 
-        Remote (URL scheme authority file query fragment maybeHeaders) -> do
+        Remote (URL scheme authority path query fragment maybeHeaders) -> do
             let prefix =
                         (case scheme of HTTP -> "http"; HTTPS -> "https")
                     <>  "://"
                     <>  authority
 
-            let fileText = Dhall.Pretty.Internal.prettyToStrictText file
+            let File {..} = path
+            let Directory {..} = directory
+
+            let pathComponentToText component =
+                    "/" <> Network.URI.Encode.encodeText component
+
+            let fileText =
+                       Text.concat
+                           (map pathComponentToText (reverse components))
+                    <> pathComponentToText file
 
             let suffix =
                         (case query    of Nothing -> ""; Just q -> "?" <> q)

dhall/src/Dhall/Parser/Token.hs

@@ -109,6 +109,7 @@ import qualified Data.HashSet
 import qualified Data.List.NonEmpty
 import qualified Data.Text
 import qualified Dhall.Set
+import qualified Text.Megaparsec
 import qualified Text.Parser.Char
 import qualified Text.Parser.Combinators
 
@@ -325,25 +326,25 @@ posixEnvironmentVariableCharacter =
         ||  ('\x3E' <= c && c <= '\x5B')
         ||  ('\x5D' <= c && c <= '\x7E')
 
-pathCharacter :: Char -> Bool
-pathCharacter c =
-        ('\x21' <= c && c <= '\x22')
-    ||  ('\x24' <= c && c <= '\x27')
-    ||  ('\x2A' <= c && c <= '\x2B')
-    ||  ('\x2D' <= c && c <= '\x2E')
-    ||  ('\x30' <= c && c <= '\x3B')
-    ||  c == '\x3D'
-    ||  ('\x40' <= c && c <= '\x5A')
-    ||  ('\x5E' <= c && c <= '\x7A')
-    ||  c == '\x7C'
-    ||  c == '\x7E'
+quotedPathCharacter :: Char -> Bool
+quotedPathCharacter c =
+        ('\x20' <= c && c <= '\x21')
+    ||  ('\x23' <= c && c <= '\x2E')
+    ||  ('\x30' <= c && c <= '\x7E')
 
 pathComponent :: Parser Text
 pathComponent = do
     _      <- "/" :: Parser Text
-    string <- some (Text.Parser.Char.satisfy pathCharacter)
 
-    return (Data.Text.pack string)
+    let pathData = Text.Megaparsec.takeWhile1P Nothing Dhall.Core.pathCharacter
+
+    let quotedPathData = do
+            _    <- Text.Parser.Char.char '"'
+            text <- Text.Megaparsec.takeWhile1P Nothing quotedPathCharacter
+            _    <- Text.Parser.Char.char '"'
+            return text
+
+    pathData <|> quotedPathData
 
 file_ :: Parser File
 file_ = do

dhall/tests/Parser.hs

@@ -149,6 +149,9 @@ parserTests =
         , shouldParse
             "Sort"
             "./tests/parser/success/sort"
+        , shouldParse
+            "quoted path components"
+            "./tests/parser/success/quotedPaths"
         , shouldNotParse
             "positive double out of bounds"
             "./tests/parser/failure/doubleBoundsPos.dhall"

dhall/tests/parser/success/quotedPathsA.dhall

@@ -0,0 +1,3 @@
+{ example0 = /"foo"/bar/"baz qux"
+, example1 = https://example.com/foo/"bar?baz"?qux
+}

dhall/tests/parser/success/quotedPathsB.dhall

@@ -0,0 +1,24 @@
+[
+  "3.0.0",
+  [
+    8,
+    {
+      "example0": [
+        24,
+        2,
+        "foo",
+        "bar",
+        "baz qux"
+      ],
+      "example1": [
+        24,
+        1,
+        "example.com",
+        "foo",
+        "bar?baz",
+        "qux",
+        null
+      ]
+    }
+  ]
+]