Update to latest dhall-lang (#1084)
* Update to latest `dhall-lang` The main updates are to support the following two changes to the standard: * https://github.com/dhall-lang/dhall-lang/pull/604 * https://github.com/dhall-lang/dhall-lang/pull/611 * `s/fields/fails/` ... as caught by @sjakobi Co-Authored-By: Simon Jakobi <simon.jakobi@gmail.com>
This commit is contained in:
Gabriel Gonzalez
mergify[bot]
parent
2cd4ed948f
commit
c116207663
|
|
@ -1 +1 @@
|
|||
Subproject commit 61c6d3c74b516165e5673753a3ffa2acd69a67fd
|
||||
Subproject commit 3fefae11fa64566f2768318cdb97123c852ed868
|
||||
|
|
@ -171,6 +171,7 @@ import Dhall.TypeCheck (X(..))
|
|||
import Lens.Family.State.Strict (zoom)
|
||||
|
||||
import qualified Codec.Serialise
|
||||
import qualified Control.Exception as Exception
|
||||
import qualified Control.Monad.Trans.Maybe as Maybe
|
||||
import qualified Control.Monad.Trans.State.Strict as State
|
||||
import qualified Crypto.Hash
|
||||
|
|
@ -389,24 +390,28 @@ instance Canonicalize Import where
|
|||
Import (canonicalize importHashed) importMode
|
||||
|
||||
toHeaders
|
||||
:: Expr s a
|
||||
:: Text
|
||||
-> Text
|
||||
-> Expr s a
|
||||
-> Maybe [(CI Data.ByteString.ByteString, Data.ByteString.ByteString)]
|
||||
toHeaders (ListLit _ hs) = do
|
||||
hs' <- mapM toHeader hs
|
||||
toHeaders key₀ key₁ (ListLit _ hs) = do
|
||||
hs' <- mapM (toHeader key₀ key₁) hs
|
||||
return (Data.Foldable.toList hs')
|
||||
toHeaders _ = do
|
||||
toHeaders _ _ _ = do
|
||||
empty
|
||||
|
||||
toHeader
|
||||
:: Expr s a
|
||||
:: Text
|
||||
-> Text
|
||||
-> Expr s a
|
||||
-> Maybe (CI Data.ByteString.ByteString, Data.ByteString.ByteString)
|
||||
toHeader (RecordLit m) = do
|
||||
TextLit (Chunks [] keyText ) <- Dhall.Map.lookup "header" m
|
||||
TextLit (Chunks [] valueText) <- Dhall.Map.lookup "value" m
|
||||
toHeader key₀ key₁ (RecordLit m) = do
|
||||
TextLit (Chunks [] keyText ) <- Dhall.Map.lookup key₀ m
|
||||
TextLit (Chunks [] valueText) <- Dhall.Map.lookup key₁ m
|
||||
let keyBytes = Data.Text.Encoding.encodeUtf8 keyText
|
||||
let valueBytes = Data.Text.Encoding.encodeUtf8 valueText
|
||||
return (Data.CaseInsensitive.mk keyBytes, valueBytes)
|
||||
toHeader _ = do
|
||||
toHeader _ _ _ = do
|
||||
empty
|
||||
|
||||
|
||||
|
|
@ -622,34 +627,50 @@ exprFromUncachedImport import_@(Import {..}) = do
|
|||
Just headersExpression -> do
|
||||
expr <- loadWith headersExpression
|
||||
|
||||
let expected :: Expr Src X
|
||||
expected =
|
||||
App List
|
||||
( Record
|
||||
( Dhall.Map.fromList
|
||||
[("header", Text), ("value", Text)]
|
||||
)
|
||||
)
|
||||
let suffix_ = Dhall.Pretty.Internal.prettyToStrictText expected
|
||||
let annot = case expr of
|
||||
Note (Src begin end bytes) _ ->
|
||||
Note (Src begin end bytes') (Annot expr expected)
|
||||
where
|
||||
bytes' = bytes <> " : " <> suffix_
|
||||
_ ->
|
||||
Annot expr expected
|
||||
let decodeHeaders key₀ key₁ = do
|
||||
let expected :: Expr Src X
|
||||
expected =
|
||||
App List
|
||||
( Record
|
||||
( Dhall.Map.fromList
|
||||
[ (key₀, Text), (key₁, Text) ]
|
||||
)
|
||||
)
|
||||
|
||||
case Dhall.TypeCheck.typeOf annot of
|
||||
Left err -> liftIO (throwIO err)
|
||||
Right _ -> return ()
|
||||
let suffix_ = Dhall.Pretty.Internal.prettyToStrictText expected
|
||||
let annot = case expr of
|
||||
Note (Src begin end bytes) _ ->
|
||||
Note (Src begin end bytes') (Annot expr expected)
|
||||
where
|
||||
bytes' = bytes <> " : " <> suffix_
|
||||
_ ->
|
||||
Annot expr expected
|
||||
|
||||
let expr' = Dhall.Core.normalize expr
|
||||
case Dhall.TypeCheck.typeOf annot of
|
||||
Left err -> liftIO (throwIO err)
|
||||
Right _ -> return ()
|
||||
|
||||
case toHeaders expr' of
|
||||
Just headers -> do
|
||||
return (Just (headers, expr'))
|
||||
Nothing -> do
|
||||
liftIO (throwIO InternalError)
|
||||
let expr' = Dhall.Core.normalize expr
|
||||
|
||||
case toHeaders key₀ key₁ expr' of
|
||||
Just headers -> do
|
||||
return (Just (headers, expr'))
|
||||
Nothing -> do
|
||||
liftIO (throwIO InternalError)
|
||||
|
||||
let handler₀ (e :: SomeException) = do
|
||||
{- Try to decode using the preferred @mapKey@ /
|
||||
@mapValue@ fields and fall back to @header@ /
|
||||
@value@ if that fails. However, if @header@ /
|
||||
@value@ still fails then re-throw the original
|
||||
exception for @mapKey@ / @mapValue@
|
||||
-}
|
||||
let handler₁ (_ :: SomeException) =
|
||||
Exception.throw e
|
||||
|
||||
Exception.handle handler₁ (decodeHeaders "header" "value")
|
||||
|
||||
liftIO (Exception.handle handler₀ (decodeHeaders "mapKey" "mapValue"))
|
||||
|
||||
#ifdef MIN_VERSION_http_client
|
||||
let maybeHeaders = fmap fst maybeHeadersAndExpression
|
||||
|
|
|
|||
|
|
@ -370,12 +370,14 @@ pathComponent :: ComponentType -> Parser Text
|
|||
pathComponent componentType = do
|
||||
_ <- "/" :: Parser Text
|
||||
|
||||
let pathData = do
|
||||
text <- Text.Megaparsec.takeWhile1P Nothing Dhall.Core.pathCharacter
|
||||
|
||||
let pathData =
|
||||
case componentType of
|
||||
FileComponent -> return text
|
||||
URLComponent -> return (URI.Encode.decodeText text)
|
||||
FileComponent -> do
|
||||
Text.Megaparsec.takeWhile1P Nothing Dhall.Core.pathCharacter
|
||||
URLComponent -> do
|
||||
text <- star pchar
|
||||
|
||||
return (URI.Encode.decodeText text)
|
||||
|
||||
let quotedPathData = do
|
||||
_ <- Text.Parser.Char.char '"'
|
||||
|
|
@ -384,11 +386,16 @@ pathComponent componentType = do
|
|||
|
||||
return text
|
||||
|
||||
pathData <|> quotedPathData
|
||||
quotedPathData <|> pathData
|
||||
|
||||
file_ :: ComponentType -> Parser File
|
||||
file_ componentType = do
|
||||
path <- Data.List.NonEmpty.some1 (pathComponent componentType)
|
||||
let emptyPath =
|
||||
case componentType of
|
||||
URLComponent -> pure (pure "")
|
||||
FileComponent -> empty
|
||||
|
||||
path <- Data.List.NonEmpty.some1 (pathComponent componentType) <|> emptyPath
|
||||
|
||||
let directory = Directory (reverse (Data.List.NonEmpty.init path))
|
||||
let file = Data.List.NonEmpty.last path
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user