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

Update to latest version of language standard (#948)

Browse Source 
Fixes https://github.com/dhall-lang/dhall-haskell/issues/947
This commit is contained in:
Gabriel Gonzalez 2019-05-13 08:23:46 -07:00 committed by GitHub
parent dadade9dd8
commit d788b780a2
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
8 changed files with 203 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
dhall/dhall-lang

@ -1 +1 @@
Subproject commit 64e1ff6b6e27eb5633e2e803fe8f9d2c6e7c624b
Subproject commit a6c59932ca78715be55fc266be4c361e0e050e98

11
dhall/dhall.cabal
View File

@ -102,6 +102,8 @@ Extra-Source-Files:
dhall-lang/Prelude/Text/concatSep
dhall-lang/Prelude/Text/package.dhall
dhall-lang/Prelude/Text/show
dhall-lang/tests/binary-decode/success/unit/*.dhall
dhall-lang/tests/binary-decode/success/unit/*.dhallb
dhall-lang/tests/import/data/*.txt
dhall-lang/tests/import/data/*.dhall
dhall-lang/tests/import/data/fieldOrder/*.dhall
@ -233,14 +235,17 @@ Extra-Source-Files:
dhall-lang/tests/normalization/success/simple/*.dhall
dhall-lang/tests/normalization/success/simplifications/*.dhall
dhall-lang/tests/normalization/success/unit/*.dhall
dhall-lang/tests/α-normalization/success/unit/*.dhall
dhall-lang/tests/alpha-normalization/success/unit/*.dhall
dhall-lang/tests/parser/failure/*.dhall
dhall-lang/tests/parser/success/*.dhall
dhall-lang/tests/parser/success/*.dhallb
dhall-lang/tests/parser/success/import/*.dhall
dhall-lang/tests/parser/success/import/*.dhallb
dhall-lang/tests/parser/success/unit/*.dhall
dhall-lang/tests/parser/success/unit/*.dhallb
dhall-lang/tests/parser/success/unit/import/*.dhall
dhall-lang/tests/parser/success/unit/import/*.dhallb
dhall-lang/tests/parser/success/text/*.dhall
dhall-lang/tests/parser/success/text/*.dhallb
dhall-lang/tests/typecheck/data/*.dhall
dhall-lang/tests/typecheck/failure/*.dhall
dhall-lang/tests/typecheck/success/*.dhall
dhall-lang/tests/typecheck/success/prelude/Bool/and/*.dhall

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

@ -856,6 +856,50 @@ instance FromTerm Import where
decode _ = empty
strip55799Tag :: Term -> Term
strip55799Tag term =
case term of
TInt a ->
TInt a
TInteger a ->
TInteger a
TBytes a ->
TBytes a
TBytesI a ->
TBytesI a
TString a ->
TString a
TStringI a ->
TStringI a
TList as ->
TList (fmap strip55799Tag as)
TListI as ->
TListI (fmap strip55799Tag as)
TMap as ->
TMap (fmap adapt as)
where
adapt (a, b) = (strip55799Tag a, strip55799Tag b)
TMapI as ->
TMapI (fmap adapt as)
where
adapt (a, b) = (strip55799Tag a, strip55799Tag b)
TTagged 55799 b ->
strip55799Tag b
TTagged a b->
TTagged a (strip55799Tag b)
TBool a ->
TBool a
TNull ->
TNull
TSimple a ->
TSimple a
THalf a ->
THalf a
TFloat a ->
TFloat a
TDouble a ->
TDouble a
-- | Encode a Dhall expression as a CBOR `Term`
encodeExpression :: Expr s Import -> Term
encodeExpression = encode
@ -867,13 +911,14 @@ decodeExpression term =
Just expression -> Right expression
Nothing -> Left (CBORIsNotDhall term)
where
strippedTerm = strip55799Tag term
-- This is the behavior specified by the standard
decodeWithoutVersion = decode term
decodeWithoutVersion = decode strippedTerm
-- For backwards compatibility with older expressions that have a version
-- tag to ease the migration
decodeWithVersion = do
TList [ TString _, taggedTerm ] <- return term
TList [ TString _, taggedTerm ] <- return strippedTerm
decode taggedTerm
data DecodingFailure = CBORIsNotDhall Term

5
dhall/src/Dhall/Import/HTTP.hs
View File

@ -28,7 +28,6 @@ import Dhall.Core
import qualified Control.Monad.Trans.State.Strict as State
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
@ -239,7 +238,7 @@ fetchFromHttpUrl
-> StateT (Status m) IO (String, Text.Text)
#ifdef __GHCJS__
fetchFromHttpUrl childURL Nothing = do
let childURLText = Dhall.Core.pretty childURL
let childURLText = renderURL childURL
let childURLString = Text.unpack childURLText
@ -256,7 +255,7 @@ fetchFromHttpUrl _ _ = do
fail "Dhall does not yet support custom headers when built using GHCJS"
#else
fetchFromHttpUrl childURL mheaders = do
let childURLString = Text.unpack (Dhall.Core.pretty childURL)
let childURLString = Text.unpack (renderURL childURL)
m <- needManager

43
dhall/src/Dhall/Parser/Expression.hs
View File

@ -660,24 +660,24 @@ localRaw =
where
parentPath = do
_ <- ".." :: Parser Text
file <- file_
file <- file_ FileComponent
return (Local Parent file)
herePath = do
_ <- "." :: Parser Text
file <- file_
file <- file_ FileComponent
return (Local Here file)
homePath = do
_ <- "~" :: Parser Text
file <- file_
file <- file_ FileComponent
return (Local Home file)
absolutePath = do
file <- file_
file <- file_ FileComponent
return (Local Absolute file)
@ -778,10 +778,15 @@ unlinesLiteral :: NonEmpty (Chunks s a) -> Chunks s a
unlinesLiteral chunks =
Data.Foldable.fold (Data.List.NonEmpty.intersperse "\n" chunks)
leadingSpaces :: Chunks s a -> Int
leadingSpaces chunks =
Data.Text.length (Data.Text.takeWhile Data.Char.isSpace firstText)
emptyLine :: Chunks s a -> Bool
emptyLine (Chunks [] "") = True
emptyLine _ = False
leadingSpaces :: Chunks s a -> Text
leadingSpaces chunks = Data.Text.takeWhile isSpace firstText
where
isSpace c = c == '\x20' || c == '\x09'
firstText =
case chunks of
Chunks [] suffix -> suffix
@ -799,6 +804,26 @@ toDoubleQuoted literal =
where
literals = linesLiteral literal
l :| ls = literals
sharedPrefix ab ac =
case Data.Text.commonPrefixes ab ac of
Just (a, _b, _c) -> a
Nothing -> ""
indent = Data.Foldable.foldl' min (leadingSpaces l) (fmap leadingSpaces ls)
-- The standard specifies to filter out blank lines for all lines *except*
-- for the last line
filteredLines = newInit <> pure oldLast
where
oldInit = Data.List.NonEmpty.init literals
oldLast = Data.List.NonEmpty.last literals
newInit = filter (not . emptyLine) oldInit
longestSharedPrefix =
case filteredLines of
l : ls ->
Data.Foldable.foldl' sharedPrefix (leadingSpaces l) (fmap leadingSpaces ls)
[] ->
""
indent = Data.Text.length longestSharedPrefix

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

@ -6,6 +6,7 @@ module Dhall.Parser.Token (
whitespace,
bashEnvironmentVariable,
posixEnvironmentVariable,
ComponentType(..),
file_,
label,
anyLabel,
@ -332,9 +333,24 @@ posixEnvironmentVariable = plus posixEnvironmentVariableCharacter
posixEnvironmentVariableCharacter :: Parser Text
posixEnvironmentVariableCharacter =
("\\" <> satisfy predicate0) <|> satisfy predicate1
escapeCharacter <|> satisfy predicate1
where
predicate0 c = c `elem` ("\"\\abfnrtv" :: String)
escapeCharacter = do
_ <- Text.Parser.Char.char '\\'
c <- Text.Parser.Char.satisfy (`elem` ("\"\\abfnrtv" :: String))
case c of
'"' -> return "\""
'\\' -> return "\\"
'a' -> return "\a"
'b' -> return "\b"
'f' -> return "\f"
'n' -> return "\n"
'r' -> return "\r"
't' -> return "\t"
'v' -> return "\v"
_ -> empty
predicate1 c =
('\x20' <= c && c <= '\x21')
@ -348,23 +364,31 @@ quotedPathCharacter c =
|| ('\x23' <= c && c <= '\x2E')
|| ('\x30' <= c && c <= '\x10FFFF')
pathComponent :: Parser Text
pathComponent = do
_ <- "/" :: Parser Text
data ComponentType = URLComponent | FileComponent
let pathData = Text.Megaparsec.takeWhile1P Nothing Dhall.Core.pathCharacter
pathComponent :: ComponentType -> Parser Text
pathComponent componentType = do
_ <- "/" :: Parser Text
let pathData = do
text <- Text.Megaparsec.takeWhile1P Nothing Dhall.Core.pathCharacter
case componentType of
FileComponent -> return text
URLComponent -> return (URI.Encode.decodeText text)
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
path <- Data.List.NonEmpty.some1 pathComponent
file_ :: ComponentType -> Parser File
file_ componentType = do
path <- Data.List.NonEmpty.some1 (pathComponent componentType)
let directory = Directory (reverse (Data.List.NonEmpty.init path))
let file = Data.List.NonEmpty.last path
@ -381,19 +405,9 @@ httpRaw :: Parser URL
httpRaw = do
scheme <- scheme_
authority <- authority_
oldPath <- file_
path <- file_ URLComponent
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 {..})
@ -441,28 +455,32 @@ ipV6Address =
alternative2 = option h16 <> "::" <> count 4 (h16 <> ":") <> ls32
alternative3 =
option (range 0 1 (h16 <> ":") <> h16)
option (h16 <> range 0 1 (try (":" <> h16)))
<> "::"
<> count 3 (h16 <> ":")
<> ls32
alternative4 =
option (range 0 2 (h16 <> ":") <> h16)
option (h16 <> range 0 2 (try (":" <> h16)))
<> "::"
<> count 2 (h16 <> ":")
<> ls32
alternative5 =
option (range 0 3 (h16 <> ":") <> h16) <> "::" <> h16 <> ":" <> ls32
option (h16 <> range 0 3 (try (":" <> h16)))
<> "::"
<> h16
<> ":"
<> ls32
alternative6 =
option (range 0 4 (h16 <> ":") <> h16) <> "::" <> ls32
option (h16 <> range 0 4 (try (":" <> h16))) <> "::" <> ls32
alternative7 =
option (range 0 5 (h16 <> ":") <> h16) <> "::" <> h16
option (h16 <> range 0 5 (try (":" <> h16))) <> "::" <> h16
alternative8 =
option (range 0 6 (h16 <> ":") <> h16) <> "::"
option (h16 <> range 0 6 (try (":" <> h16))) <> "::"
h16 :: Parser Text
h16 = range 1 3 (satisfy hexdig)

2
dhall/tests/Dhall/Test/Normalization.hs
View File

@ -41,7 +41,7 @@ getTests = do
alphaNormalizationTests <- do
Test.Util.discover pattern alphaNormalizationTest
(Turtle.lstree "./dhall-lang/tests/α-normalization/success/")
(Turtle.lstree "./dhall-lang/tests/alpha-normalization/success/")
let unitTestFiles = do
path <- Turtle.lstree "./dhall-lang/tests/normalization/success/unit"

68
dhall/tests/Dhall/Test/Parser.hs
View File

@ -3,6 +3,8 @@
module Dhall.Test.Parser where
import Data.Text (Text)
import Dhall.Core (Expr, Import)
import Dhall.TypeCheck (X)
import Prelude hiding (FilePath)
import Test.Tasty (TestTree)
import Turtle (FilePath, (</>))
@ -23,17 +25,49 @@ import qualified Turtle
parseDirectory :: FilePath
parseDirectory = "./dhall-lang/tests/parser"
binaryDecodeDirectory :: FilePath
binaryDecodeDirectory = "./dhall-lang/tests/binary-decode"
getTests :: IO TestTree
getTests = do
let successFiles = do
path <- Turtle.lstree (parseDirectory </> "success")
let skip =
-- This is a bug created by a parsing performance
-- improvement
[ parseDirectory </> "success/unit/MergeParenAnnotationA.dhall"
]
Monad.guard (path `notElem` skip)
return path
successTests <- do
Test.Util.discover (Turtle.chars <* "A.dhall") shouldParse (Turtle.lstree (parseDirectory </> "success"))
Test.Util.discover (Turtle.chars <* "A.dhall") shouldParse successFiles
let failureFiles = do
path <- Turtle.lstree (parseDirectory </> "failure")
let skip =
[ parseDirectory </> "failure/annotation.dhall"
[ -- These two unexpected successes are due to not correctly
-- requiring non-empty whitespace after the `:` in a type
-- annotatoin
parseDirectory </> "failure/annotation.dhall"
, parseDirectory </> "failure/unit/ImportEnvWrongEscape.dhall"
-- Similarly, the implementation does not correctly
-- require a space between a function and its argument
, parseDirectory </> "failure/missingSpace.dhall"
-- For parsing performance reasons the implementation
-- treats a missing type annotation on an empty list as
-- as a type-checking failure instead of a parse failure,
-- but this might be fixable.
, parseDirectory </> "failure/unit/ListLitEmptyAnnotation.dhall"
-- The same performance improvements also broke the
-- precedence of parsing empty list literals
, parseDirectory </> "failure/unit/ListLitEmptyPrecedence.dhall"
]
Monad.guard (path `notElem` skip)
@ -43,10 +77,17 @@ getTests = do
failureTests <- do
Test.Util.discover (Turtle.chars <> ".dhall") shouldNotParse failureFiles
let binaryDecodeFiles =
Turtle.lstree (binaryDecodeDirectory </> "success")
binaryDecodeTests <- do
Test.Util.discover (Turtle.chars <* "A.dhallb") shouldDecode binaryDecodeFiles
let testTree =
Tasty.testGroup "parser tests"
[ successTests
, failureTests
, binaryDecodeTests
]
return testTree
@ -79,3 +120,26 @@ shouldNotParse path = do
case Parser.exprFromText mempty text of
Left _ -> return ()
Right _ -> fail "Unexpected successful parser" )
shouldDecode :: Text -> TestTree
shouldDecode pathText = do
let pathString = Text.unpack pathText
Tasty.HUnit.testCase pathString (do
bytes <- ByteString.Lazy.readFile (pathString <> "A.dhallb")
term <- Core.throws (Serialise.deserialiseOrFail bytes)
decodedExpression <- Core.throws (Binary.decodeExpression term)
text <- Text.IO.readFile (pathString <> "B.dhall")
parsedExpression <- Core.throws (Parser.exprFromText mempty text)
let strippedExpression :: Expr X Import
strippedExpression = Core.denote parsedExpression
let message =
"The decoded expression didn't match the parsed expression"
Tasty.HUnit.assertEqual message decodedExpression strippedExpression )