ehmry/dhall-haskell
ehmry/dhall-haskell
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Remove support for URL fragments (#851)

Browse Source 
... as standardized in https://github.com/dhall-lang/dhall-lang/pull/406
This commit is contained in:
Gabriel Gonzalez 2019-03-14 07:23:23 -07:00 committed by GitHub
parent 4b7bdd458c
commit bffe2ed2a1
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 22 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
dhall/dhall-lang

@ -1 +1 @@
Subproject commit 7d521e2f56ccc3d8fcdb84fd25857a26acd49b80
Subproject commit 9e0bc0f83097d6221e78571e74b9d67a166fa636

19
dhall/src/Dhall/Binary.hs
View File

@ -421,7 +421,6 @@ importToTerm import_ =
++ map TString (reverse components)
++ [ TString file ]
++ (case query of Nothing -> [ TNull ]; Just q -> [ TString q ])
++ (case fragment of Nothing -> [ TNull ]; Just f -> [ TString f ])
)
where
using = case headers of
@ -736,31 +735,27 @@ decodeMaybe (TList (TInt 24 : h : TInt mode : TInt n : xs)) = do
_ -> empty
let remote scheme = do
let process [ TString file, q, f ] = do
let process [ TString file, q ] = do
query <- case q of
TNull -> return Nothing
TString x -> return (Just x)
_ -> empty
fragment <- case f of
TNull -> return Nothing
TString x -> return (Just x)
_ -> empty
return ([], file, query, fragment)
return ([], file, query)
process (TString path : ys) = do
(paths, file, query, fragment) <- process ys
return (path : paths, file, query, fragment)
(paths, file, query) <- process ys
return (path : paths, file, query)
process _ = do
empty
(headers, authority, paths, file, query, fragment) <- case xs of
(headers, authority, paths, file, query) <- case xs of
headers₀ : TString authority : ys -> do
headers₁ <- case headers₀ of
TNull -> return Nothing
_ -> do
Embed (Import { importHashed = headers }) <- decodeMaybe headers₀
return (Just headers)
(paths, file, query, fragment) <- process ys
return (headers₁, authority, paths, file, query, fragment)
(paths, file, query) <- process ys
return (headers₁, authority, paths, file, query)
_ -> do
empty

6
dhall/src/Dhall/Core.hs
View File

@ -178,7 +178,6 @@ data URL = URL
, authority :: Text
, path :: File
, query :: Maybe Text
, fragment :: Maybe Text
, headers :: Maybe ImportHashed
} deriving (Eq, Generic, Ord, Show)
@ -189,7 +188,6 @@ instance Pretty URL where
<> Pretty.pretty authority
<> Pretty.pretty path
<> queryDoc
<> fragmentDoc
<> foldMap prettyHeaders headers
where
prettyHeaders h = " using " <> Pretty.pretty h
@ -202,10 +200,6 @@ instance Pretty URL where
Nothing -> ""
Just q -> "?" <> Pretty.pretty q
fragmentDoc = case fragment of
Nothing -> ""
Just f -> "#" <> Pretty.pretty f
-- | The type of import (i.e. local vs. remote vs. environment)
data ImportType
= Local FilePrefix File

6
dhall/src/Dhall/Parser/Token.hs
View File

@ -375,7 +375,6 @@ httpRaw = do
authority <- authority_
path <- file_
query <- optional (("?" :: Parser Text) *> query_)
fragment <- optional (("#" :: Parser Text) *> fragment_)
let headers = Nothing
@ -497,11 +496,6 @@ query_ = star (pchar <|> satisfy predicate)
where
predicate c = c == '/' || c == '?'
fragment_ :: Parser Text
fragment_ = star (pchar <|> satisfy predicate)
where
predicate c = c == '/' || c == '?'
pctEncoded :: Parser Text
pctEncoded = "%" <> count 2 (satisfy hexdig)

34
dhall/tests/Dhall/Test/QuickCheck.hs
View File

@ -7,7 +7,6 @@
module Dhall.Test.QuickCheck where
import Codec.Serialise (DeserialiseFailure(..))
import Control.Monad (guard)
import Data.Either (isRight)
import Data.List.NonEmpty (NonEmpty(..))
import Dhall.Map (Map)
@ -266,39 +265,24 @@ instance Arbitrary FilePrefix where
instance Arbitrary ImportType where
arbitrary =
Test.QuickCheck.suchThat
(Test.QuickCheck.oneof
[ lift2 Local
, lift5 (\a b c d e -> Remote (URL a b c d e Nothing))
, lift1 Env
, lift0 Missing
]
)
standardizedImportType
Test.QuickCheck.oneof
[ lift2 Local
, lift5 (\a b c d e -> Remote (URL a b c d e))
, lift1 Env
, lift0 Missing
]
shrink importType =
filter standardizedImportType (genericShrink importType)
standardizedImportType :: ImportType -> Bool
standardizedImportType (Remote (URL _ _ _ _ _ (Just _))) = False
standardizedImportType _ = True
shrink = genericShrink
instance Arbitrary ImportHashed where
arbitrary =
Test.QuickCheck.suchThat
(lift1 (ImportHashed Nothing))
standardizedImportHashed
lift1 (ImportHashed Nothing)
shrink (ImportHashed { importType = oldImportType, .. }) = do
newImportType <- shrink oldImportType
let importHashed = ImportHashed { importType = newImportType, .. }
guard (standardizedImportHashed importHashed)
return importHashed
standardizedImportHashed :: ImportHashed -> Bool
standardizedImportHashed (ImportHashed (Just _) _) = False
standardizedImportHashed _ = True
-- The standard does not yet specify how to encode `as Text`, so don't test it
-- yet
instance Arbitrary ImportMode where
@ -317,7 +301,7 @@ instance Arbitrary Scheme where
shrink = genericShrink
instance Arbitrary URL where
arbitrary = lift6 URL
arbitrary = lift5 URL
shrink = genericShrink

6
nix/shared.nix
View File

@ -505,9 +505,7 @@ let
system = "x86_64-linux";
};
# Derivation that trivially depends on the current directory so that Hydra's
# pull request builder always posts a GitHub status on each revision
pwd = pkgs.runCommand "pwd" { here = ../.; } "touch $out";
trivial = x: pkgs.runCommand "trivial" { inherit x; } "touch $out";
makeStaticIfPossible = name:
if pkgs.stdenv.isLinux
@ -537,7 +535,7 @@ let
in
rec {
inherit pwd;
inherit trivial;
possibly-static = {
dhall = makeStaticIfPossible "dhall" ;

4
release.nix
View File

@ -1,3 +1,5 @@
{ src ? { rev = ""; }, ... }:
let
shared_7_10_3 =
import ./nix/shared.nix { compiler = "ghc7103"; };
@ -50,7 +52,7 @@ in
# This is the only `dhall` build that runs the test suite
coverage.dhall
shared.pwd
(shared.trivial src.rev)
];
};