diff --git a/dhall/dhall-lang b/dhall/dhall-lang index c77f22c..64e1ff6 160000 --- a/dhall/dhall-lang +++ b/dhall/dhall-lang @@ -1 +1 @@ -Subproject commit c77f22cb10f25d9c3e29801760849c81b8595407 +Subproject commit 64e1ff6b6e27eb5633e2e803fe8f9d2c6e7c624b diff --git a/dhall/src/Dhall/Binary.hs b/dhall/src/Dhall/Binary.hs index 9c200da..fb8dcd9 100644 --- a/dhall/src/Dhall/Binary.hs +++ b/dhall/src/Dhall/Binary.hs @@ -132,8 +132,6 @@ class ToTerm a where instance ToTerm a => ToTerm (Expr s a) where encode (Var (V "_" n)) = TInteger n - encode (Var (V x 0)) = - TString x encode (Var (V x n)) = TList [ TString x, TInteger n ] encode NaturalBuild = @@ -566,8 +564,6 @@ instance FromTerm a => FromTerm (Expr s a) where return (Const Sort) decode (TString "_") = empty - decode (TString x) = - return (Var (V x 0)) decode (TList [ TString x, TInt n ]) = return (Var (V x (fromIntegral n))) decode (TList [ TString x, TInteger n ]) = diff --git a/dhall/src/Dhall/Core.hs b/dhall/src/Dhall/Core.hs index 55e320a..bdd114c 100644 --- a/dhall/src/Dhall/Core.hs +++ b/dhall/src/Dhall/Core.hs @@ -98,6 +98,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 Text.Printf @@ -191,12 +192,20 @@ instance Pretty URL where schemeDoc <> "://" <> Pretty.pretty authority - <> Pretty.pretty path + <> pathDoc <> queryDoc <> foldMap prettyHeaders headers where prettyHeaders h = " using " <> Pretty.pretty h + File {..} = path + + Directory {..} = directory + + pathDoc = + foldMap prettyURIComponent (reverse components) + <> prettyURIComponent file + schemeDoc = case scheme of HTTP -> "http" HTTPS -> "https" @@ -1542,15 +1551,7 @@ normalizeWithM ctx e0 = loop (denote e0) case y' of TextLit c -> pure [Chunks [] x, c] _ -> pure [Chunks [(x, y')] mempty] - TextAppend x y -> decide <$> loop x <*> loop y - where - isEmpty (Chunks [] "") = True - isEmpty _ = False - - decide (TextLit m) r | isEmpty m = r - decide l (TextLit n) | isEmpty n = l - decide (TextLit m) (TextLit n) = TextLit (m <> n) - decide l r = TextAppend l r + TextAppend x y -> loop (TextLit (Chunks [("", x), ("", y)] "")) TextShow -> pure TextShow List -> pure List ListLit t es @@ -1835,15 +1836,7 @@ isNormalized e0 = loop (denote e0) check y = loop y && case y of TextLit _ -> False _ -> True - TextAppend x y -> loop x && loop y && decide x y - where - isEmpty (Chunks [] "") = True - isEmpty _ = False - - decide (TextLit m) _ | isEmpty m = False - decide _ (TextLit n) | isEmpty n = False - decide (TextLit _) (TextLit _) = False - decide _ _ = True + TextAppend _ _ -> False TextShow -> True List -> True ListLit t es -> all loop t && all loop es @@ -2111,6 +2104,13 @@ prettyPathComponent text | otherwise = "/\"" <> 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 <> "\"" + {-| Convenience utility for converting `Either`-based exceptions to `IO`-based exceptions -} diff --git a/dhall/src/Dhall/Eval.hs b/dhall/src/Dhall/Eval.hs index 1e5a70a..b8b1cdc 100644 --- a/dhall/src/Dhall/Eval.hs +++ b/dhall/src/Dhall/Eval.hs @@ -419,11 +419,7 @@ eval !env t = TextLit cs -> case evalChunks cs of VChunks [("", t)] "" -> t vcs -> VTextLit vcs - TextAppend t u -> case (evalE t, evalE u) of - (VTextLit (VChunks [] ""), u) -> u - (t, VTextLit (VChunks [] "")) -> t - (VTextLit x, VTextLit y) -> VTextLit (x <> y) - (t, u) -> VTextAppend t u + TextAppend t u -> evalE (TextLit (Chunks [("", t), ("", u)] "")) TextShow -> VPrim $ \case VTextLit (VChunks [] x) -> VTextLit (VChunks [] (textShow x)) t -> VTextShow t diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 47fc01a..83104f9 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -308,7 +308,7 @@ instance Show MissingImports where <> concatMap (\e -> "\n" <> show e <> "\n") es throwMissingImport :: (MonadCatch m, Exception e) => e -> m a -throwMissingImport e = throwM (MissingImports [(toException e)]) +throwMissingImport e = throwM (MissingImports [toException e]) -- | Exception thrown when a HTTP url is imported but dhall was built without -- the @with-http@ Cabal flag. @@ -461,6 +461,8 @@ exprFromImport :: Import -> StateT (Status IO) IO (Expr Src Import) exprFromImport here@(Import {..}) = do let ImportHashed {..} = importHashed + Status {..} <- State.get + result <- Maybe.runMaybeT $ do Just expectedHash <- return hash cacheFile <- getCacheFile expectedHash @@ -472,7 +474,7 @@ exprFromImport here@(Import {..}) = do if expectedHash == actualHash then return () - else liftIO (Control.Exception.throwIO (HashMismatch {..})) + else throwMissingImport (Imported _stack (HashMismatch {..})) let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict @@ -527,7 +529,7 @@ exprToImport here expression = do let fallback = do let actualHash = hashExpression NoVersion normalizedExpression - liftIO (Control.Exception.throwIO (HashMismatch {..})) + throwMissingImport (Imported _stack (HashMismatch {..})) Data.Foldable.asum (map check [ minBound .. maxBound ]) <|> fallback diff --git a/dhall/src/Dhall/Import/HTTP.hs b/dhall/src/Dhall/Import/HTTP.hs index ba3d219..85ec0ee 100644 --- a/dhall/src/Dhall/Import/HTTP.hs +++ b/dhall/src/Dhall/Import/HTTP.hs @@ -12,10 +12,13 @@ import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) import Data.Dynamic (fromDynamic, toDyn) import Data.Semigroup ((<>)) +import Data.Text (Text) import Lens.Family.State.Strict (zoom) import Dhall.Core - ( Import(..) + ( Directory(..) + , File(..) + , Import(..) , ImportHashed(..) , ImportType(..) , Scheme(..) @@ -27,6 +30,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding import qualified Dhall.Core import qualified Dhall.Util +import qualified Network.URI.Encode as URI.Encode import Dhall.Import.Types @@ -200,6 +204,35 @@ corsCompliant (Remote parentURL) childURL responseHeaders = liftIO $ do Control.Exception.throwIO (NotCORSCompliant {..}) corsCompliant _ _ _ = return () +renderComponent :: Text -> Text +renderComponent component = "/" <> URI.Encode.encodeText component + +renderQuery :: Text -> Text +renderQuery query = "?" <> query + +renderURL :: URL -> Text +renderURL url = + schemeText + <> authority + <> pathText + <> queryText + where + URL {..} = url + + File {..} = path + + Directory {..} = directory + + schemeText = case scheme of + HTTP -> "http://" + HTTPS -> "https://" + + pathText = + foldMap renderComponent (reverse components) + <> renderComponent file + + queryText = foldMap renderQuery query + fetchFromHttpUrl :: URL -> Maybe [(CI ByteString, ByteString)] diff --git a/dhall/src/Dhall/Parser/Token.hs b/dhall/src/Dhall/Parser/Token.hs index fa014b5..a6f0eab 100644 --- a/dhall/src/Dhall/Parser/Token.hs +++ b/dhall/src/Dhall/Parser/Token.hs @@ -111,6 +111,7 @@ import qualified Data.HashSet import qualified Data.List.NonEmpty import qualified Data.Text import qualified Dhall.Set +import qualified Network.URI.Encode as URI.Encode import qualified Text.Megaparsec import qualified Text.Megaparsec.Char.Lexer import qualified Text.Parser.Char @@ -380,9 +381,19 @@ httpRaw :: Parser URL httpRaw = do scheme <- scheme_ authority <- authority_ - path <- file_ + oldPath <- file_ query <- optional (("?" :: Parser Text) *> query_) + let path = + oldPath + { file = URI.Encode.decodeText (file oldPath) + , directory = + (directory oldPath) + { components = + map URI.Encode.decodeText (components (directory oldPath)) + } + } + let headers = Nothing return (URL {..}) diff --git a/dhall/tests/Dhall/Test/Normalization.hs b/dhall/tests/Dhall/Test/Normalization.hs index 953ae6e..0b8c2f1 100644 --- a/dhall/tests/Dhall/Test/Normalization.hs +++ b/dhall/tests/Dhall/Test/Normalization.hs @@ -48,6 +48,8 @@ getTests = do let skip = [ normalizationDirectory "unit/EmptyAlternativeA.dhall" + -- https://github.com/dhall-lang/dhall-lang/issues/505 + , normalizationDirectory "unit/OperatorTextConcatenateLhsEmptyA.dhall" ] Monad.guard (path `notElem` skip)