Update to latest test suite (#903)
This requires implementing the following changes to the standard: * https://github.com/dhall-lang/dhall-lang/pull/481 * https://github.com/dhall-lang/dhall-lang/pull/488 * https://github.com/dhall-lang/dhall-lang/pull/489 * https://github.com/dhall-lang/dhall-lang/pull/497
This commit is contained in:
Gabriel Gonzalez
GitHub
parent
7d31506be4
commit
21da6f2b7f
|
|
@ -1 +1 @@
|
|||
Subproject commit c77f22cb10f25d9c3e29801760849c81b8595407
|
||||
Subproject commit 64e1ff6b6e27eb5633e2e803fe8f9d2c6e7c624b
|
||||
|
|
@ -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 ]) =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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 {..})
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user