diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,37 @@ +1.39.0 + +* [Supports version 20.2.0 of the standard](https://github.com/dhall-lang/dhall-lang/releases/tag/v20.2.0) + * [Add support for Unix shebangs](https://github.com/dhall-lang/dhall-haskell/pull/2175) +* [BREAKING CHANGE TO THE API: `dhall {format,freeze,lint}` now accept multiple + files](https://github.com/dhall-lang/dhall-haskell/pull/2169) + * The `--inplace` flag is no longer necessary and you can now specify + multiple files to update in place on the command line, like + `dhall format foo.dhall bar.dhall` + * The `--inplace` flag is still accepted, but does nothing, and will emit a + warning + * This is a breaking change to the API for formatting/freezing/linting files + because now you can specify multiple inputs instead of one input +* [BREAKING CHANGE: Pre-6.0.0 hashes are no longer supported](https://github.com/dhall-lang/dhall-haskell/pull/2190) + * The interpreter no longer provides backwards compatibility for integrity + checks computed before standard version 6.0.0 + * This is a breaking change to the API of the `Dhall.Binary` module, where + certain utilities are no longer parameterized on a `StandardVersion` + * This is also a breaking change to any Dhall code that depended on these + really old integrity checks +* [BUG FIX: Formatting `≡` now correctly preserves the original character set](https://github.com/dhall-lang/dhall-haskell/pull/2176) +* [BUG FIX: Don't panic on `Text/replace ""`](https://github.com/dhall-lang/dhall-haskell/pull/2184) +* [Quasiquotation support for Dhall](https://github.com/dhall-lang/dhall-haskell/pull/2198) + * You can now convert a Dhall expression to the corresponding syntax tree + using a quasiquoter like this: `[dhall| \x -> x + 2 ]` +* [New `Dhall.Marshal.{Encode,Decode}` modules](https://github.com/dhall-lang/dhall-haskell/pull/2193) + * These modules split up the `Dhall` module into two smaller modules for + encoding and decoding logic, respectively + * The `Dhall` module still re-exports the same functionality as before, so + this is not a breaking change +* [Support GHC 9.0.1](https://github.com/dhall-lang/dhall-haskell/pull/2154) +* Fixes and improvements to code formatting + * [Improve pretty-printing of `sha256`](https://github.com/dhall-lang/dhall-haskell/pull/2189) + 1.38.1 * [Add `INLINABLE` annotations in more places](https://github.com/dhall-lang/dhall-haskell/pull/2164) diff --git a/dhall-lang/Prelude/List/fold.dhall b/dhall-lang/Prelude/List/fold.dhall --- a/dhall-lang/Prelude/List/fold.dhall +++ b/dhall-lang/Prelude/List/fold.dhall @@ -18,34 +18,26 @@ : fold Natural [ 2, 3, 5 ] - Natural - (λ(x : Natural) → λ(y : Natural) → x + y) - 0 - ≡ 10 + Text + (λ(x : Natural) → λ(y : Text) → Natural/show x ++ y) + "0" + ≡ "2350" let example1 = - assert - : ( λ(nil : Natural) → - fold - Natural - [ 2, 3, 5 ] - Natural - (λ(x : Natural) → λ(y : Natural) → x + y) - nil - ) - ≡ (λ(nil : Natural) → 2 + (3 + (5 + nil))) + λ(nil : Text) → + assert + : fold + Natural + [ 2, 3, 5 ] + Text + (λ(x : Natural) → λ(y : Text) → Natural/show x ++ y) + nil + ≡ "2" ++ ("3" ++ ("5" ++ nil)) let example2 = - assert - : ( λ(list : Type) → - λ(cons : Natural → list → list) → - λ(nil : list) → - fold Natural [ 2, 3, 5 ] list cons nil - ) - ≡ ( λ(list : Type) → - λ(cons : Natural → list → list) → - λ(nil : list) → - cons 2 (cons 3 (cons 5 nil)) - ) + λ(cons : Natural → Text → Text) → + λ(nil : Text) → + assert + : fold Natural [ 2, 3, 5 ] Text cons nil ≡ cons 2 (cons 3 (cons 5 nil)) in fold diff --git a/dhall-lang/Prelude/List/foldLeft.dhall b/dhall-lang/Prelude/List/foldLeft.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/List/foldLeft.dhall @@ -0,0 +1,60 @@ +{-| +`foldLeft` is like `List/fold` except that the accumulation starts from the left + +If you treat the list `[ x, y, z ]` as `cons (cons (cons nil x) y) z`, then +`foldLeft` just replaces each `cons` and `nil` with something else +-} +let foldLeft + : ∀(a : Type) → + List a → + ∀(list : Type) → + ∀(cons : list → a → list) → + ∀(nil : list) → + list + = λ(a : Type) → + λ(xs : List a) → + λ(list : Type) → + λ(cons : list → a → list) → + λ(nil : list) → + List/fold + a + xs + (list → list) + (λ(x : a) → λ(f : list → list) → λ(l : list) → f (cons l x)) + (λ(l : list) → l) + nil + +let example0 = + assert + : foldLeft + Natural + [ 2, 3, 5 ] + Text + (λ(x : Text) → λ(y : Natural) → x ++ Natural/show y) + "0" + ≡ "0235" + +let example1 = + assert + : ( λ(nil : Text) → + foldLeft + Natural + [ 2, 3, 5 ] + Text + (λ(x : Text) → λ(y : Natural) → x ++ Natural/show y) + nil + ) + ≡ (λ(nil : Text) → nil ++ "2" ++ "3" ++ "5") + +let example2 = + assert + : ( λ(cons : Text → Natural → Text) → + λ(nil : Text) → + foldLeft Natural [ 2, 3, 5 ] Text cons nil + ) + ≡ ( λ(cons : Text → Natural → Text) → + λ(nil : Text) → + cons (cons (cons nil 2) 3) 5 + ) + +in foldLeft diff --git a/dhall-lang/Prelude/List/package.dhall b/dhall-lang/Prelude/List/package.dhall --- a/dhall-lang/Prelude/List/package.dhall +++ b/dhall-lang/Prelude/List/package.dhall @@ -28,6 +28,9 @@ , fold = ./fold.dhall sha256:10bb945c25ab3943bd9df5a32e633cbfae112b7d3af38591784687e436a8d814 ? ./fold.dhall +, foldLeft = + ./foldLeft.dhall sha256:3c6ab57950fe644906b7bbdef0b9523440b6ee17773ebb8cbd41ffacb8bfab61 + ? ./foldLeft.dhall , generate = ./generate.dhall sha256:78ff1ad96c08b88a8263eea7bc8381c078225cfcb759c496f792edb5a5e0b1a4 ? ./generate.dhall diff --git a/dhall-lang/Prelude/Natural/fold.dhall b/dhall-lang/Prelude/Natural/fold.dhall --- a/dhall-lang/Prelude/Natural/fold.dhall +++ b/dhall-lang/Prelude/Natural/fold.dhall @@ -12,24 +12,17 @@ natural = Natural/fold -let example0 = assert : fold 3 Natural (λ(x : Natural) → 5 * x) 1 ≡ 125 +let example0 = assert : fold 3 Text (λ(x : Text) → "A" ++ x) "B" ≡ "AAAB" let example1 = - assert - : (λ(zero : Natural) → fold 3 Natural (λ(x : Natural) → 5 * x) zero) - ≡ (λ(zero : Natural) → 5 * (5 * (5 * zero))) + λ(zero : Text) → + assert + : fold 3 Text (λ(x : Text) → "A" ++ x) zero + ≡ "A" ++ ("A" ++ ("A" ++ zero)) let example2 = - assert - : ( λ(natural : Type) → - λ(succ : natural → natural) → - λ(zero : natural) → - fold 3 natural succ zero - ) - ≡ ( λ(natural : Type) → - λ(succ : natural → natural) → - λ(zero : natural) → - succ (succ (succ zero)) - ) + λ(succ : Text → Text) → + λ(zero : Text) → + assert : fold 3 Text succ zero ≡ succ (succ (succ zero)) in fold diff --git a/dhall-lang/Prelude/Optional/fold.dhall b/dhall-lang/Prelude/Optional/fold.dhall --- a/dhall-lang/Prelude/Optional/fold.dhall +++ b/dhall-lang/Prelude/Optional/fold.dhall @@ -13,9 +13,8 @@ λ(none : optional) → merge { Some = some, None = none } o -let example0 = assert : fold Natural (Some 2) Natural (λ(x : Natural) → x) 0 ≡ 2 +let example0 = assert : fold Natural (Some 2) Text Natural/show "0" ≡ "2" -let example1 = - assert : fold Natural (None Natural) Natural (λ(x : Natural) → x) 0 ≡ 0 +let example1 = assert : fold Natural (None Natural) Text Natural/show "0" ≡ "0" in fold diff --git a/dhall-lang/Prelude/Text/lowerASCII.dhall b/dhall-lang/Prelude/Text/lowerASCII.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Text/lowerASCII.dhall @@ -0,0 +1,56 @@ +{-| +Lowercase all ASCII characters + +Note that this will also lowercase decomposed Unicode characters that contain +codepoints in the ASCII range +-} +let lowerASCII + : Text → Text + = List/fold + (Text → Text) + [ Text/replace "A" "a" + , Text/replace "B" "b" + , Text/replace "C" "c" + , Text/replace "D" "d" + , Text/replace "E" "e" + , Text/replace "F" "f" + , Text/replace "G" "g" + , Text/replace "H" "h" + , Text/replace "I" "i" + , Text/replace "J" "j" + , Text/replace "K" "k" + , Text/replace "L" "l" + , Text/replace "M" "m" + , Text/replace "N" "n" + , Text/replace "O" "o" + , Text/replace "P" "p" + , Text/replace "Q" "q" + , Text/replace "R" "r" + , Text/replace "S" "s" + , Text/replace "T" "t" + , Text/replace "U" "u" + , Text/replace "V" "v" + , Text/replace "W" "w" + , Text/replace "X" "x" + , Text/replace "Y" "y" + , Text/replace "Z" "z" + ] + Text + (λ(replacement : Text → Text) → replacement) + +let example0 = assert : lowerASCII "ABCdef" ≡ "abcdef" + +let -- This does not lowercase precomposed Unicode characters + -- + -- • The `Á` in the following example is U+00C1 + example1 = + assert : lowerASCII "Á" ≡ "Á" + +let -- … but this does lowercase decomposed Unicode characters + -- + -- • The `Á` in the following example is U+0041 U+0301 + -- • The `á` in the following example is U+0061 U+0301 + example1 = + assert : lowerASCII "Á" ≡ "á" + +in lowerASCII diff --git a/dhall-lang/Prelude/Text/package.dhall b/dhall-lang/Prelude/Text/package.dhall --- a/dhall-lang/Prelude/Text/package.dhall +++ b/dhall-lang/Prelude/Text/package.dhall @@ -16,6 +16,9 @@ , defaultMap = ./defaultMap.dhall sha256:3a3fa1264f6198800c27483cb144de2c5366484876d60b9c739a710ce0288588 ? ./defaultMap.dhall +, lowerASCII = + ./lowerASCII.dhall sha256:26b076651120b907e869396bd3dc16271f2e12433062b2f26f296968a69515e7 + ? ./lowerASCII.dhall , replace = ./replace.dhall sha256:7d132df0e091a43817bba8afa06d1bb487ee51c091430404ad6f8c78bc0328a6 ? ./replace.dhall @@ -28,4 +31,7 @@ , spaces = ./spaces.dhall sha256:fccfd4f26601e006bf6a79ca948dbd37c676cdd0db439554447320293d23b3dc ? ./spaces.dhall +, upperASCII = + ./upperASCII.dhall sha256:45ae4fbd814b0474e65c28a4ee92b23b979892fa5bb73730bc99675ae790ca29 + ? ./upperASCII.dhall } diff --git a/dhall-lang/Prelude/Text/upperASCII.dhall b/dhall-lang/Prelude/Text/upperASCII.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Text/upperASCII.dhall @@ -0,0 +1,56 @@ +{-| +Uppercase all ASCII characters + +Note that this will also uppercase decomposed Unicode characters that contain +codepoints in the ASCII range +-} +let upperASCII + : Text → Text + = List/fold + (Text → Text) + [ Text/replace "a" "A" + , Text/replace "b" "B" + , Text/replace "c" "C" + , Text/replace "d" "D" + , Text/replace "e" "E" + , Text/replace "f" "F" + , Text/replace "g" "G" + , Text/replace "h" "H" + , Text/replace "i" "I" + , Text/replace "j" "J" + , Text/replace "k" "K" + , Text/replace "l" "L" + , Text/replace "m" "M" + , Text/replace "n" "N" + , Text/replace "o" "O" + , Text/replace "p" "P" + , Text/replace "q" "Q" + , Text/replace "r" "R" + , Text/replace "s" "S" + , Text/replace "t" "T" + , Text/replace "u" "U" + , Text/replace "v" "V" + , Text/replace "w" "W" + , Text/replace "x" "X" + , Text/replace "y" "Y" + , Text/replace "z" "Z" + ] + Text + (λ(replacement : Text → Text) → replacement) + +let example0 = assert : upperASCII "ABCdef" ≡ "ABCDEF" + +let -- This does not uppercase precomposed Unicode characters + -- + -- • The `á` in the following example is U+00E1 + example1 = + assert : upperASCII "á" ≡ "á" + +let -- … but this does uppercase decomposed Unicode characters + -- + -- • The `Á` in the following example is U+0041 U+0301 + -- • The `á` in the following example is U+0061 U+0301 + example1 = + assert : upperASCII "á" ≡ "Á" + +in upperASCII diff --git a/dhall-lang/Prelude/XML/package.dhall b/dhall-lang/Prelude/XML/package.dhall --- a/dhall-lang/Prelude/XML/package.dhall +++ b/dhall-lang/Prelude/XML/package.dhall @@ -5,7 +5,7 @@ ./attribute.dhall sha256:f7b6c802ca5764d03d5e9a6e48d9cb167c01392f775d9c2c87b83cdaa60ea0cc ? ./attribute.dhall , render = - ./render.dhall sha256:aff7efe61ce299381edca023e24bb5aaa0656c41bfa45dd705dab63519b7c5db + ./render.dhall sha256:550c8900fe199b83d629181d53c646f2f9425d9c64670dabb30d28e95bfa4c75 ? ./render.dhall , element = ./element.dhall sha256:e0b948053c8cd8ccca9c39244d89e3f42db43d222531c18151551dfc75208b4b diff --git a/dhall-lang/Prelude/XML/render b/dhall-lang/Prelude/XML/render --- a/dhall-lang/Prelude/XML/render +++ b/dhall-lang/Prelude/XML/render @@ -1,2 +1,2 @@ - ./render.dhall sha256:aff7efe61ce299381edca023e24bb5aaa0656c41bfa45dd705dab63519b7c5db + ./render.dhall sha256:550c8900fe199b83d629181d53c646f2f9425d9c64670dabb30d28e95bfa4c75 ? ./render.dhall diff --git a/dhall-lang/Prelude/XML/render.dhall b/dhall-lang/Prelude/XML/render.dhall --- a/dhall-lang/Prelude/XML/render.dhall +++ b/dhall-lang/Prelude/XML/render.dhall @@ -1,10 +1,6 @@ {-| Render an `XML` value as `Text` -*WARNING:* rendering does not include any XML injection mitigations, -therefore it should not be used to process arbitrary strings into -element attributes or element data. - For indentation and schema validation, see the `xmllint` utility bundled with libxml2. @@ -48,16 +44,24 @@ let Attr = { mapKey : Text, mapValue : Text } -let `escape"` = Text/replace "\"" "\\\"" +let esc = λ(x : Text) → λ(y : Text) → Text/replace x "&${y};" -let `escape<` = Text/replace "<" "\\<" +let `escape&` = esc "&" "amp" -let `escape&` = Text/replace "&" "\\&" +let `escape<` = esc "<" "lt" -let escapeText = λ(text : Text) → `escape<` (`escape&` text) +let `escape>` = esc ">" "gt" -let escapeAttr = λ(text : Text) → `escape"` (`escape<` (`escape&` text)) +let `escape'` = esc "'" "apos" +let `escape"` = esc "\"" "quot" + +let escapeCommon = λ(text : Text) → `escape<` (`escape&` text) + +let escapeAttr = λ(text : Text) → `escape"` (`escape'` (escapeCommon text)) + +let escapeText = λ(text : Text) → `escape>` (escapeCommon text) + let renderAttr = λ(x : Attr) → " ${x.mapKey}=\"${escapeAttr x.mapValue}\"" let render @@ -123,9 +127,7 @@ "\n" "" '' - - \<>'"\& - + <>'"& '' in render diff --git a/dhall-lang/Prelude/package.dhall b/dhall-lang/Prelude/package.dhall --- a/dhall-lang/Prelude/package.dhall +++ b/dhall-lang/Prelude/package.dhall @@ -11,7 +11,7 @@ ./Integer/package.dhall sha256:d1a572ca3a764781496847e4921d7d9a881c18ffcfac6ae28d0e5299066938a0 ? ./Integer/package.dhall , List = - ./List/package.dhall sha256:547cd881988c6c5e3673ae80491224158e93a4627690db0196cb5efbbf00d2ba + ./List/package.dhall sha256:11081c23436cb9c5fa60d53416e62845071990b43b3c48973cb2f19f5d5adbee ? ./List/package.dhall , Location = ./Location/package.dhall sha256:0eb4e4a60814018009c720f6820aaa13cf9491eb1b09afb7b832039c6ee4d470 @@ -35,9 +35,9 @@ ./JSON/package.dhall sha256:5f98b7722fd13509ef448b075e02b9ff98312ae7a406cf53ed25012dbc9990ac ? ./JSON/package.dhall , Text = - ./Text/package.dhall sha256:46c53957c10bd4c332a5716d6e06068cd24ae1392ca171e6da31e30b9b33c07c + ./Text/package.dhall sha256:17a0e0e881b05436d7e3ae94a658af9da5ba2a921fafa0d1d545890978853434 ? ./Text/package.dhall , XML = - ./XML/package.dhall sha256:8f57bda3087cbb34568d58e5dd5ee6860a50576caf48ebe49a5fc60b9af9a1fa + ./XML/package.dhall sha256:6a15ea2ab1918f97374ec2fe3b90c056fb807fb3a90c1c44ce9fb9233f59c0e5 ? ./XML/package.dhall } diff --git a/dhall-lang/tests/import/data/cycle.dhall b/dhall-lang/tests/import/data/cycle.dhall --- a/dhall-lang/tests/import/data/cycle.dhall +++ b/dhall-lang/tests/import/data/cycle.dhall @@ -1,1 +1,1 @@ -../failure/cycle.dhall +../failure/unit/Cycle.dhall diff --git a/dhall-lang/tests/import/failure/cycle.dhall b/dhall-lang/tests/import/failure/cycle.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/failure/cycle.dhall +++ /dev/null @@ -1,1 +0,0 @@ -../data/cycle.dhall diff --git a/dhall-lang/tests/import/failure/hashMismatch.dhall b/dhall-lang/tests/import/failure/hashMismatch.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/failure/hashMismatch.dhall +++ /dev/null @@ -1,1 +0,0 @@ -../data/simple.dhall sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/dhall-lang/tests/import/failure/importBoundary.dhall b/dhall-lang/tests/import/failure/importBoundary.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/failure/importBoundary.dhall +++ /dev/null @@ -1,1 +0,0 @@ -\(x: Bool) -> ../data/importBoundary.dhall diff --git a/dhall-lang/tests/import/failure/missing.dhall b/dhall-lang/tests/import/failure/missing.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/failure/missing.dhall +++ /dev/null @@ -1,1 +0,0 @@ -missing diff --git a/dhall-lang/tests/import/failure/referentiallyInsane.dhall b/dhall-lang/tests/import/failure/referentiallyInsane.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/failure/referentiallyInsane.dhall +++ /dev/null @@ -1,13 +0,0 @@ -{- The following remote import attempts to import an environment variable, which - must be disallowed by the referential sanity check - - One reason for doing this is to protect against remote imports exfiltrating - environment variables (such as via custom headers). Only referentially - opaque imports (i.e. local imports) have permission to refer to other - referentially opaque imports in order to protect against this attack. - - The referential sanity check also ensures that remote imports are - referentially transparent. Or in other words, any import that is globally - addressable must have a meaning that is not context-sensitive. --} -https://raw.githubusercontent.com/dhall-lang/dhall-lang/master/tests/import/data/referentiallyOpaque.dhall diff --git a/dhall-lang/tests/import/failure/unit/404.dhall b/dhall-lang/tests/import/failure/unit/404.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/failure/unit/404.dhall @@ -0,0 +1,1 @@ +https://test.dhall-lang.org/nonexistent-file.dhall diff --git a/dhall-lang/tests/import/failure/unit/Cycle.dhall b/dhall-lang/tests/import/failure/unit/Cycle.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/failure/unit/Cycle.dhall @@ -0,0 +1,1 @@ +../../data/cycle.dhall diff --git a/dhall-lang/tests/import/failure/unit/DontRecoverCycle.dhall b/dhall-lang/tests/import/failure/unit/DontRecoverCycle.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/failure/unit/DontRecoverCycle.dhall @@ -0,0 +1,1 @@ +./cycle.dhall ? 0 diff --git a/dhall-lang/tests/import/failure/unit/DontRecoverTypeError.dhall b/dhall-lang/tests/import/failure/unit/DontRecoverTypeError.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/failure/unit/DontRecoverTypeError.dhall @@ -0,0 +1,1 @@ +../../../type-inference/failure/unit/VariableFree.dhall ? 0 diff --git a/dhall-lang/tests/import/failure/unit/EnvFromRemote.dhall b/dhall-lang/tests/import/failure/unit/EnvFromRemote.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/failure/unit/EnvFromRemote.dhall @@ -0,0 +1,13 @@ +{- The following remote import attempts to import an environment variable, which + must be disallowed by the referential sanity check + + One reason for doing this is to protect against remote imports exfiltrating + environment variables (such as via custom headers). Only referentially + opaque imports (i.e. local imports) have permission to refer to other + referentially opaque imports in order to protect against this attack. + + The referential sanity check also ensures that remote imports are + referentially transparent. Or in other words, any import that is globally + addressable must have a meaning that is not context-sensitive. +-} +https://raw.githubusercontent.com/dhall-lang/dhall-lang/master/tests/import/data/referentiallyOpaque.dhall diff --git a/dhall-lang/tests/import/failure/unit/FileMissing.dhall b/dhall-lang/tests/import/failure/unit/FileMissing.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/failure/unit/FileMissing.dhall @@ -0,0 +1,1 @@ +./not-a-file.dhall diff --git a/dhall-lang/tests/import/failure/unit/HashMismatch.dhall b/dhall-lang/tests/import/failure/unit/HashMismatch.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/failure/unit/HashMismatch.dhall @@ -0,0 +1,1 @@ +../data/simple.dhall sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/dhall-lang/tests/import/failure/unit/HashMismatch2.dhall b/dhall-lang/tests/import/failure/unit/HashMismatch2.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/failure/unit/HashMismatch2.dhall @@ -0,0 +1,2 @@ +-- This ensures that even if the file gets imported without hash first, the hash check is not skipped later +../../data/simple.dhall + ../../data/simple.dhall sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + ../../data/simple.dhall diff --git a/dhall-lang/tests/import/failure/unit/Missing.dhall b/dhall-lang/tests/import/failure/unit/Missing.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/failure/unit/Missing.dhall @@ -0,0 +1,1 @@ +missing diff --git a/dhall-lang/tests/import/failure/unit/VarAcrossImportBoundary.dhall b/dhall-lang/tests/import/failure/unit/VarAcrossImportBoundary.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/failure/unit/VarAcrossImportBoundary.dhall @@ -0,0 +1,1 @@ +\(x: Bool) -> ../../data/importBoundary.dhall diff --git a/dhall-lang/tests/import/success/unit/AlternativeWithVariableA.dhall b/dhall-lang/tests/import/success/unit/AlternativeWithVariableA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/unit/AlternativeWithVariableA.dhall @@ -0,0 +1,1 @@ +let x = 0 in (missing ? x) diff --git a/dhall-lang/tests/import/success/unit/AlternativeWithVariableB.dhall b/dhall-lang/tests/import/success/unit/AlternativeWithVariableB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/unit/AlternativeWithVariableB.dhall @@ -0,0 +1,1 @@ +0 diff --git a/dhall-lang/tests/import/success/unit/AlternativeWithWrongVariable1A.dhall b/dhall-lang/tests/import/success/unit/AlternativeWithWrongVariable1A.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/unit/AlternativeWithWrongVariable1A.dhall @@ -0,0 +1,1 @@ +\(x: Natural) -> x ? y diff --git a/dhall-lang/tests/import/success/unit/AlternativeWithWrongVariable1B.dhall b/dhall-lang/tests/import/success/unit/AlternativeWithWrongVariable1B.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/unit/AlternativeWithWrongVariable1B.dhall @@ -0,0 +1,1 @@ +λ(x : Natural) → x diff --git a/dhall-lang/tests/import/success/unit/AlternativeWithWrongVariable2A.dhall b/dhall-lang/tests/import/success/unit/AlternativeWithWrongVariable2A.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/unit/AlternativeWithWrongVariable2A.dhall @@ -0,0 +1,1 @@ +\(x: Natural) -> (y + missing) ? x diff --git a/dhall-lang/tests/import/success/unit/AlternativeWithWrongVariable2B.dhall b/dhall-lang/tests/import/success/unit/AlternativeWithWrongVariable2B.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/unit/AlternativeWithWrongVariable2B.dhall @@ -0,0 +1,1 @@ +λ(x : Natural) → x diff --git a/dhall-lang/tests/import/success/unit/DontCacheIfHashA.dhall b/dhall-lang/tests/import/success/unit/DontCacheIfHashA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/unit/DontCacheIfHashA.dhall @@ -0,0 +1,5 @@ +-- The let triggers a loading of `simple.dhall` in the cache, +-- but the second import uses a hash that corresponds to a different file already in the content-addressed store. +-- This test ensures that we retrieve the value corresponding to the hash and not the path even if the path is in cache. +let x = ../../data/simple.dhall +in ../../data/simple.dhall sha256:3871180b87ecaba8b53fffb2a8b52d3fce98098fab09a6f759358b9e8042eedc diff --git a/dhall-lang/tests/import/success/unit/DontCacheIfHashB.dhall b/dhall-lang/tests/import/success/unit/DontCacheIfHashB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/unit/DontCacheIfHashB.dhall @@ -0,0 +1,1 @@ +λ(_ : Type) → λ(_ : Optional _) → merge { `None` = True, `Some` = λ(_ : _@1) → False } _ diff --git a/dhall-lang/tests/import/success/unit/MixImportModesA.dhall b/dhall-lang/tests/import/success/unit/MixImportModesA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/unit/MixImportModesA.dhall @@ -0,0 +1,2 @@ +-- This is to ensure caching doesn't accidentally confuse import modes +{ n = ../../data/simple.dhall, txt = ../../data/simple.dhall as Text, loc = ../../data/simple.dhall as Location } diff --git a/dhall-lang/tests/import/success/unit/MixImportModesB.dhall b/dhall-lang/tests/import/success/unit/MixImportModesB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/unit/MixImportModesB.dhall @@ -0,0 +1,1 @@ +{ loc = < Environment: Text | Local: Text | Missing | Remote: Text >.Local "./dhall-lang/tests/import/data/simple.dhall", n = 3, txt = "3\n" } diff --git a/dhall-lang/tests/import/success/unit/RecoverTransitiveFailureA.dhall b/dhall-lang/tests/import/success/unit/RecoverTransitiveFailureA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/unit/RecoverTransitiveFailureA.dhall @@ -0,0 +1,1 @@ +../../failure/unit/FileMissing.dhall ? 0 diff --git a/dhall-lang/tests/import/success/unit/RecoverTransitiveFailureB.dhall b/dhall-lang/tests/import/success/unit/RecoverTransitiveFailureB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/unit/RecoverTransitiveFailureB.dhall @@ -0,0 +1,1 @@ +0 diff --git a/dhall-lang/tests/normalization/success/regression/ComplexRecordSimplificationA.dhall b/dhall-lang/tests/normalization/success/regression/ComplexRecordSimplificationA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/regression/ComplexRecordSimplificationA.dhall @@ -0,0 +1,1 @@ +\(foo: { x: Bool, y: Bool }) -> \(bar: { x: Bool }) -> (foo.{x, y} // bar).{ x } diff --git a/dhall-lang/tests/normalization/success/regression/ComplexRecordSimplificationB.dhall b/dhall-lang/tests/normalization/success/regression/ComplexRecordSimplificationB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/regression/ComplexRecordSimplificationB.dhall @@ -0,0 +1,3 @@ +λ(foo : { x : Bool, y : Bool }) → +λ(bar : { x : Bool }) → + (foo.{ x, y } ⫽ bar).{ x } diff --git a/dhall-lang/tests/normalization/success/regression/ToMapQuotedFieldsA.dhall b/dhall-lang/tests/normalization/success/regression/ToMapQuotedFieldsA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/regression/ToMapQuotedFieldsA.dhall @@ -0,0 +1,1 @@ +toMap { `if` = 0, `foo%bar` = 1 } diff --git a/dhall-lang/tests/normalization/success/regression/ToMapQuotedFieldsB.dhall b/dhall-lang/tests/normalization/success/regression/ToMapQuotedFieldsB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/regression/ToMapQuotedFieldsB.dhall @@ -0,0 +1,1 @@ +[ { mapKey = "foo%bar", mapValue = 1 }, { mapKey = "if", mapValue = 0 } ] diff --git a/dhall-lang/tests/normalization/success/unit/RecordSortFieldsA.dhall b/dhall-lang/tests/normalization/success/unit/RecordSortFieldsA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordSortFieldsA.dhall @@ -0,0 +1,1 @@ +{ b = 1, a = 0 } diff --git a/dhall-lang/tests/normalization/success/unit/RecordSortFieldsB.dhall b/dhall-lang/tests/normalization/success/unit/RecordSortFieldsB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordSortFieldsB.dhall @@ -0,0 +1,1 @@ +{ a = 0, b = 1 } diff --git a/dhall-lang/tests/normalization/success/unit/RecordTypeSortFieldsA.dhall b/dhall-lang/tests/normalization/success/unit/RecordTypeSortFieldsA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordTypeSortFieldsA.dhall @@ -0,0 +1,1 @@ +{ b : Bool, a : Natural } diff --git a/dhall-lang/tests/normalization/success/unit/RecordTypeSortFieldsB.dhall b/dhall-lang/tests/normalization/success/unit/RecordTypeSortFieldsB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordTypeSortFieldsB.dhall @@ -0,0 +1,1 @@ +{ a : Natural, b : Bool } diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty1A.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty1A.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty1A.dhall @@ -0,0 +1,1 @@ +Text/replace "" diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty1B.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty1B.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty1B.dhall @@ -0,0 +1,1 @@ +Text/replace "" diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty2A.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty2A.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty2A.dhall @@ -0,0 +1,2 @@ +λ(replacement : Text) → + Text/replace "" replacement diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty2B.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty2B.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty2B.dhall @@ -0,0 +1,2 @@ +λ(replacement : Text) → + Text/replace "" replacement diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty3A.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty3A.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty3A.dhall @@ -0,0 +1,3 @@ +λ(replacement : Text) → +λ(haystack : Text) → + Text/replace "" replacement haystack diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty3B.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty3B.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextReplaceEmpty3B.dhall @@ -0,0 +1,1 @@ +λ(replacement : Text) → λ(haystack : Text) → haystack diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceEmptyA.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceEmptyA.dhall deleted file mode 100644 --- a/dhall-lang/tests/normalization/success/unit/TextReplaceEmptyA.dhall +++ /dev/null @@ -1,3 +0,0 @@ -λ(replacement : Text) → -λ(haystack : Text) → - Text/replace "" replacement haystack diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceEmptyB.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceEmptyB.dhall deleted file mode 100644 --- a/dhall-lang/tests/normalization/success/unit/TextReplaceEmptyB.dhall +++ /dev/null @@ -1,1 +0,0 @@ -λ(replacement : Text) → λ(haystack : Text) → haystack diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceOverlappingA.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceOverlappingA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextReplaceOverlappingA.dhall @@ -0,0 +1,1 @@ +Text/replace "aa" "b" "aaaaa" diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceOverlappingB.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceOverlappingB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextReplaceOverlappingB.dhall @@ -0,0 +1,1 @@ +"bba" diff --git a/dhall-lang/tests/parser/success/unit/ShebangA.dhall b/dhall-lang/tests/parser/success/unit/ShebangA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/ShebangA.dhall @@ -0,0 +1,2 @@ +#!/usr/bin/env -S dhall text --file +"A" diff --git a/dhall-lang/tests/parser/success/unit/ShebangB.dhallb b/dhall-lang/tests/parser/success/unit/ShebangB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/ShebangB.dhallb @@ -0,0 +1,1 @@ +‚aA diff --git a/dhall-lang/tests/parser/success/unit/ShebangNixA.dhall b/dhall-lang/tests/parser/success/unit/ShebangNixA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/ShebangNixA.dhall @@ -0,0 +1,3 @@ +#! /usr/bin/env nix-shell +#! nix-shell -i "dhall --file" -p dhall +42 diff --git a/dhall-lang/tests/parser/success/unit/ShebangNixB.dhallb b/dhall-lang/tests/parser/success/unit/ShebangNixB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/ShebangNixB.dhallb @@ -0,0 +1,1 @@ +‚* diff --git a/dhall-lang/tests/type-inference/success/preludeB.dhall b/dhall-lang/tests/type-inference/success/preludeB.dhall --- a/dhall-lang/tests/type-inference/success/preludeB.dhall +++ b/dhall-lang/tests/type-inference/success/preludeB.dhall @@ -319,6 +319,13 @@ ∀(cons : a → list → list) → ∀(nil : list) → list + , foldLeft : + ∀(a : Type) → + ∀(xs : List a) → + ∀(list : Type) → + ∀(cons : list → a → list) → + ∀(nil : list) → + list , generate : ∀(n : Natural) → ∀(a : Type) → ∀(f : Natural → a) → List a , head : ∀(a : Type) → List a → Optional a , index : ∀(n : Natural) → ∀(a : Type) → ∀(xs : List a) → Optional a @@ -491,11 +498,13 @@ , concatSep : ∀(separator : Text) → ∀(elements : List Text) → Text , default : ∀(o : Optional Text) → Text , defaultMap : ∀(a : Type) → ∀(f : a → Text) → ∀(o : Optional a) → Text + , lowerASCII : ∀(nil : Text) → Text , replace : ∀(needle : Text) → ∀(replacement : Text) → ∀(haystack : Text) → Text , replicate : ∀(num : Natural) → ∀(text : Text) → Text , show : Text → Text , spaces : ∀(a : Natural) → Text + , upperASCII : ∀(nil : Text) → Text } , XML : { Type : Type diff --git a/dhall-lang/tests/type-inference/success/unit/WithInfersKindA.dhall b/dhall-lang/tests/type-inference/success/unit/WithInfersKindA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/WithInfersKindA.dhall @@ -0,0 +1,1 @@ +Some ({ x = Bool } with x = 0) diff --git a/dhall-lang/tests/type-inference/success/unit/WithInfersKindB.dhall b/dhall-lang/tests/type-inference/success/unit/WithInfersKindB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/WithInfersKindB.dhall @@ -0,0 +1,1 @@ +Optional { x : Natural } diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,5 +1,5 @@ Name: dhall -Version: 1.38.1 +Version: 1.39.0 Cabal-Version: 2.0 Build-Type: Simple Tested-With: GHC == 8.4.3, GHC == 8.6.1 @@ -496,7 +496,7 @@ hashable >= 1.2 && < 1.4 , lens-family-core >= 1.0.0 && < 2.2 , megaparsec >= 7 && < 9.1 , - memory >= 0.14 && < 0.16, + memory >= 0.14 && < 0.17, mmorph < 1.2 , mtl >= 2.2.1 && < 2.3 , network-uri >= 2.6 && < 2.7 , @@ -510,7 +510,7 @@ repline >= 0.4.0.0 && < 0.5 , serialise >= 0.2.0.0 && < 0.3 , scientific >= 0.3.0.0 && < 0.4 , - template-haskell >= 2.13.0.0 && < 2.17, + template-haskell >= 2.13.0.0 && < 2.18, text >= 0.11.1.0 && < 1.3 , text-manipulate >= 0.2.0.1 && < 0.4 , th-lift-instances >= 0.1.13 && < 0.2 , @@ -533,7 +533,7 @@ else Hs-Source-Dirs: ghc-src Build-Depends: - cryptonite >= 0.23 && < 1.0 + cryptonite >= 0.23 && < 0.30 if flag(with-http) Build-Depends: http-types >= 0.7.0 && < 0.13, @@ -583,6 +583,8 @@ Dhall.Import Dhall.Lint Dhall.Main + Dhall.Marshal.Decode + Dhall.Marshal.Encode Dhall.Map Dhall.Optics Dhall.Parser @@ -608,6 +610,7 @@ Other-Modules: Dhall.Eval Dhall.Import.Types + Dhall.Marshal.Internal Dhall.Normalize Dhall.Parser.Combinators Dhall.Pretty.Internal @@ -667,7 +670,7 @@ either , filepath , foldl < 1.5 , - generic-random >= 1.3.0.0 && < 1.4 , + generic-random >= 1.3.0.0 && < 1.5 , http-client , http-client-tls , lens-family-core , diff --git a/src/Dhall.hs b/src/Dhall.hs --- a/src/Dhall.hs +++ b/src/Dhall.hs @@ -46,2862 +46,452 @@ , detailed -- * Decoders - , Decoder (..) - , RecordDecoder(..) - , UnionDecoder(..) - , Encoder(..) - , FromDhall(..) - , Interpret - , InvalidDecoder(..) - , ExtractErrors - , ExtractError(..) - , Extractor - , MonadicExtractor - , typeError - , extractError - , toMonadic - , fromMonadic - , ExpectedTypeErrors - , ExpectedTypeError(..) - , Expector - , auto - , genericAuto - , genericAutoWith - , InterpretOptions(..) - , InputNormalizer(..) - , defaultInputNormalizer - , SingletonConstructors(..) - , defaultInterpretOptions - , bool - , natural - , integer - , word - , word8 - , word16 - , word32 - , word64 - , int - , int8 - , int16 - , int32 - , int64 - , scientific - , double - , lazyText - , strictText - , maybe - , sequence - , list - , vector - , function - , functionWith - , setFromDistinctList - , setIgnoringDuplicates - , hashSetFromDistinctList - , hashSetIgnoringDuplicates - , Dhall.map - , hashMap - , pairFromMapEntry - , unit - , void - , string - , pair - , record - , field - , union - , constructor - , GenericFromDhall(..) - , GenericFromDhallUnion(..) - , ToDhall(..) - , Inject - , inject - , genericToDhall - , genericToDhallWith - , RecordEncoder(..) - , encodeFieldWith - , encodeField - , recordEncoder - , UnionEncoder(..) - , encodeConstructorWith - , encodeConstructor - , unionEncoder - , (>|<) - , GenericToDhall(..) - - -- * Miscellaneous - , DhallErrors(..) - , showDhallErrors - , rawInput - , (>$<) - , (>*<) - , Result - - -- * Re-exports - , Natural - , Seq - , Text - , Vector - , Generic - ) where - -import Control.Applicative (Alternative, empty, liftA2) -import Control.Exception (Exception) -import Control.Monad (guard) -import Control.Monad.Trans.State.Strict -import Data.Coerce (coerce) -import Data.Either.Validation - ( Validation (..) - , eitherToValidation - , validationToEither - ) -import Data.Fix (Fix (..)) -import Data.Functor.Contravariant (Contravariant (..), Op (..), (>$<)) -import Data.Functor.Contravariant.Divisible (Divisible (..), divided) -import Data.Hashable (Hashable) -import Data.HashMap.Strict (HashMap) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Map (Map) -import Data.Scientific (Scientific) -import Data.Sequence (Seq) -import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Pretty) -import Data.Typeable (Proxy (..), Typeable) -import Data.Vector (Vector) -import Data.Void (Void) -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int8, Int16, Int32, Int64) -import Dhall.Import (Imported (..)) -import Dhall.Parser (Src (..)) -import Dhall.Syntax - ( Chunks (..) - , DhallDouble (..) - , Expr (..) - , FunctionBinding (..) - , RecordField (..) - , Var (..) - ) -import Dhall.TypeCheck (DetailedTypeError (..), TypeError) -import GHC.Generics -import Lens.Family (LensLike', view) -import Numeric.Natural (Natural) -import Prelude hiding (maybe, sequence) -import System.FilePath (takeDirectory) - -import qualified Control.Applicative -import qualified Control.Exception -import qualified Control.Monad.Trans.State.Strict as State -import qualified Data.Foldable -import qualified Data.Functor.Compose -import qualified Data.Functor.Product -import qualified Data.HashMap.Strict as HashMap -import qualified Data.HashSet -import qualified Data.List as List -import qualified Data.List.NonEmpty -import qualified Data.Map -import qualified Data.Maybe -import qualified Data.Scientific -import qualified Data.Sequence -import qualified Data.Set -import qualified Data.Text -import qualified Data.Text.IO -import qualified Data.Text.Lazy -import qualified Data.Vector -import qualified Data.Void -import qualified Dhall.Context -import qualified Dhall.Core as Core -import qualified Dhall.Import -import qualified Dhall.Map -import qualified Dhall.Parser -import qualified Dhall.Pretty.Internal -import qualified Dhall.Substitution -import qualified Dhall.TypeCheck -import qualified Dhall.Util -import qualified Lens.Family - --- $setup --- >>> :set -XOverloadedStrings --- >>> :set -XRecordWildCards --- >>> import Data.Word (Word8, Word16, Word32, Word64) --- >>> import Dhall.Pretty.Internal (prettyExpr) - -{-| A newtype suitable for collecting one or more errors --} -newtype DhallErrors e = DhallErrors - { getErrors :: NonEmpty e - } deriving (Eq, Functor, Semigroup) - -instance (Show (DhallErrors e), Typeable e) => Exception (DhallErrors e) - -{-| Render a given prefix and some errors to a string. --} -showDhallErrors :: Show e => String -> DhallErrors e -> String -showDhallErrors _ (DhallErrors (e :| [])) = show e -showDhallErrors ctx (DhallErrors es) = prefix <> (unlines . Data.List.NonEmpty.toList . fmap show $ es) - where - prefix = - "Multiple errors were encountered" ++ ctx ++ ": \n\ - \ \n" - -{-| Useful synonym for the `Validation` type used when marshalling Dhall - expressions --} -type Extractor s a = Validation (ExtractErrors s a) - -{-| Useful synonym for the equivalent `Either` type used when marshalling Dhall - code --} -type MonadicExtractor s a = Either (ExtractErrors s a) - -{-| Generate a type error during extraction by specifying the expected type - and the actual type. - The expected type is not yet determined. --} -typeError :: Expector (Expr s a) -> Expr s a -> Extractor s a b -typeError expected actual = Failure $ case expected of - Failure e -> fmap ExpectedTypeError e - Success expected' -> DhallErrors $ pure $ TypeMismatch $ InvalidDecoder expected' actual - --- | Turn a `Data.Text.Text` message into an extraction failure -extractError :: Text -> Extractor s a b -extractError = Failure . DhallErrors . pure . ExtractError - -{-| Useful synonym for the `Validation` type used when marshalling Dhall - expressions --} -type Expector = Validation ExpectedTypeErrors - -{-| One or more errors returned when determining the Dhall type of a - Haskell expression --} -type ExpectedTypeErrors = DhallErrors ExpectedTypeError - -{-| Error type used when determining the Dhall type of a Haskell expression --} -data ExpectedTypeError = RecursiveTypeError - deriving (Eq, Show) - -instance Exception ExpectedTypeError - -instance Show ExpectedTypeErrors where - show = showDhallErrors " while determining the expected type" - --- | Switches from an @Applicative@ extraction result, able to accumulate errors, --- to a @Monad@ extraction result, able to chain sequential operations -toMonadic :: Extractor s a b -> MonadicExtractor s a b -toMonadic = validationToEither - --- | Switches from a @Monad@ extraction result, able to chain sequential errors, --- to an @Applicative@ extraction result, able to accumulate errors -fromMonadic :: MonadicExtractor s a b -> Extractor s a b -fromMonadic = eitherToValidation - -{-| One or more errors returned from extracting a Dhall expression to a - Haskell expression --} -type ExtractErrors s a = DhallErrors (ExtractError s a) - -instance (Pretty s, Pretty a, Typeable s, Typeable a) => Show (ExtractErrors s a) where - show = showDhallErrors " during extraction" - -{-| Extraction of a value can fail for two reasons, either a type mismatch (which should not happen, - as expressions are type-checked against the expected type before being passed to @extract@), or - a term-level error, described with a freeform text value. --} -data ExtractError s a = - TypeMismatch (InvalidDecoder s a) - | ExpectedTypeError ExpectedTypeError - | ExtractError Text - -instance (Pretty s, Pretty a, Typeable s, Typeable a) => Show (ExtractError s a) where - show (TypeMismatch e) = show e - show (ExpectedTypeError e) = show e - show (ExtractError es) = - _ERROR <> ": Failed extraction \n\ - \ \n\ - \The expression type-checked successfully but the transformation to the target \n\ - \type failed with the following error: \n\ - \ \n\ - \" <> Data.Text.unpack es <> "\n\ - \ \n" - -instance (Pretty s, Pretty a, Typeable s, Typeable a) => Exception (ExtractError s a) - -{-| Every `Decoder` must obey the contract that if an expression's type matches - the `expected` type then the `extract` function must not fail with a type - error. However, decoding may still fail for other reasons (such as the - decoder for `Data.Map.Set`s rejecting a Dhall @List@ with duplicate - elements). - - This error type is used to indicate an internal error in the implementation - of a `Decoder` where the expected type matched the Dhall expression, but the - expression supplied to the extraction function did not match the expected - type. If this happens that means that the `Decoder` itself needs to be - fixed. --} -data InvalidDecoder s a = InvalidDecoder - { invalidDecoderExpected :: Expr s a - , invalidDecoderExpression :: Expr s a - } - deriving (Typeable) - -instance (Pretty s, Typeable s, Pretty a, Typeable a) => Exception (InvalidDecoder s a) - -_ERROR :: String -_ERROR = "\ESC[1;31mError\ESC[0m" - -instance (Pretty s, Pretty a, Typeable s, Typeable a) => Show (InvalidDecoder s a) where - show InvalidDecoder { .. } = - _ERROR <> ": Invalid Dhall.Decoder \n\ - \ \n\ - \Every Decoder must provide an extract function that does not fail with a type \n\ - \error if an expression matches the expected type. You provided a Decoder that \n\ - \disobeys this contract \n\ - \ \n\ - \The Decoder provided has the expected dhall type: \n\ - \ \n\ - \" <> show txt0 <> "\n\ - \ \n\ - \and it threw a type error during extraction from the well-typed expression: \n\ - \ \n\ - \" <> show txt1 <> "\n\ - \ \n" - where - txt0 = Dhall.Util.insert invalidDecoderExpected - txt1 = Dhall.Util.insert invalidDecoderExpression - --- | @since 1.16 -data InputSettings = InputSettings - { _rootDirectory :: FilePath - , _sourceName :: FilePath - , _evaluateSettings :: EvaluateSettings - } - --- | Default input settings: resolves imports relative to @.@ (the --- current working directory), report errors as coming from @(input)@, --- and default evaluation settings from 'defaultEvaluateSettings'. --- --- @since 1.16 -defaultInputSettings :: InputSettings -defaultInputSettings = InputSettings - { _rootDirectory = "." - , _sourceName = "(input)" - , _evaluateSettings = defaultEvaluateSettings - } - - --- | Access the directory to resolve imports relative to. --- --- @since 1.16 -rootDirectory - :: (Functor f) - => LensLike' f InputSettings FilePath -rootDirectory k s = - fmap (\x -> s { _rootDirectory = x }) (k (_rootDirectory s)) - --- | Access the name of the source to report locations from; this is --- only used in error messages, so it's okay if this is a best guess --- or something symbolic. --- --- @since 1.16 -sourceName - :: (Functor f) - => LensLike' f InputSettings FilePath -sourceName k s = - fmap (\x -> s { _sourceName = x}) (k (_sourceName s)) - --- | @since 1.16 -data EvaluateSettings = EvaluateSettings - { _substitutions :: Dhall.Substitution.Substitutions Src Void - , _startingContext :: Dhall.Context.Context (Expr Src Void) - , _normalizer :: Maybe (Core.ReifiedNormalizer Void) - , _newManager :: IO Dhall.Import.Manager - } - --- | Default evaluation settings: no extra entries in the initial --- context, and no special normalizer behaviour. --- --- @since 1.16 -defaultEvaluateSettings :: EvaluateSettings -defaultEvaluateSettings = EvaluateSettings - { _substitutions = Dhall.Substitution.empty - , _startingContext = Dhall.Context.empty - , _normalizer = Nothing - , _newManager = Dhall.Import.defaultNewManager - } - --- | Access the starting context used for evaluation and type-checking. --- --- @since 1.16 -startingContext - :: (Functor f, HasEvaluateSettings s) - => LensLike' f s (Dhall.Context.Context (Expr Src Void)) -startingContext = evaluateSettings . l - where - l :: (Functor f) - => LensLike' f EvaluateSettings (Dhall.Context.Context (Expr Src Void)) - l k s = fmap (\x -> s { _startingContext = x}) (k (_startingContext s)) - --- | Access the custom substitutions. --- --- @since 1.30 -substitutions - :: (Functor f, HasEvaluateSettings s) - => LensLike' f s (Dhall.Substitution.Substitutions Src Void) -substitutions = evaluateSettings . l - where - l :: (Functor f) - => LensLike' f EvaluateSettings (Dhall.Substitution.Substitutions Src Void) - l k s = fmap (\x -> s { _substitutions = x }) (k (_substitutions s)) - --- | Access the custom normalizer. --- --- @since 1.16 -normalizer - :: (Functor f, HasEvaluateSettings s) - => LensLike' f s (Maybe (Core.ReifiedNormalizer Void)) -normalizer = evaluateSettings . l - where - l :: (Functor f) - => LensLike' f EvaluateSettings (Maybe (Core.ReifiedNormalizer Void)) - l k s = fmap (\x -> s { _normalizer = x }) (k (_normalizer s)) - --- | Access the HTTP manager initializer. --- --- @since 1.36 -newManager - :: (Functor f, HasEvaluateSettings s) - => LensLike' f s (IO Dhall.Import.Manager) -newManager = evaluateSettings . l - where - l :: (Functor f) - => LensLike' f EvaluateSettings (IO Dhall.Import.Manager) - l k s = fmap (\x -> s { _newManager = x }) (k (_newManager s)) - --- | @since 1.16 -class HasEvaluateSettings s where - evaluateSettings - :: (Functor f) - => LensLike' f s EvaluateSettings - -instance HasEvaluateSettings InputSettings where - evaluateSettings k s = - fmap (\x -> s { _evaluateSettings = x }) (k (_evaluateSettings s)) - -instance HasEvaluateSettings EvaluateSettings where - evaluateSettings = id - -{-| Type-check and evaluate a Dhall program, decoding the result into Haskell - - The first argument determines the type of value that you decode: - ->>> input integer "+2" -2 ->>> input (vector double) "[1.0, 2.0]" -[1.0,2.0] - - Use `auto` to automatically select which type to decode based on the - inferred return type: - ->>> input auto "True" :: IO Bool -True - - This uses the settings from 'defaultInputSettings'. --} -input - :: Decoder a - -- ^ The decoder for the Dhall value - -> Text - -- ^ The Dhall program - -> IO a - -- ^ The decoded value in Haskell -input = - inputWithSettings defaultInputSettings - -{-| Extend 'input' with a root directory to resolve imports relative - to, a file to mention in errors as the source, a custom typing - context, and a custom normalization process. - -@since 1.16 --} -inputWithSettings - :: InputSettings - -> Decoder a - -- ^ The decoder for the Dhall value - -> Text - -- ^ The Dhall program - -> IO a - -- ^ The decoded value in Haskell -inputWithSettings settings (Decoder {..}) txt = do - expected' <- case expected of - Success x -> return x - Failure e -> Control.Exception.throwIO e - - let suffix = Dhall.Pretty.Internal.prettyToStrictText expected' - let annotate substituted = case substituted of - Note (Src begin end bytes) _ -> - Note (Src begin end bytes') (Annot substituted expected') - where - bytes' = bytes <> " : " <> suffix - _ -> - Annot substituted expected' - - normExpr <- inputHelper annotate settings txt - - case extract normExpr of - Success x -> return x - Failure e -> Control.Exception.throwIO e - -{-| Type-check and evaluate a Dhall program that is read from the - file-system. - - This uses the settings from 'defaultEvaluateSettings'. - - @since 1.16 --} -inputFile - :: Decoder a - -- ^ The decoder for the Dhall value - -> FilePath - -- ^ The path to the Dhall program. - -> IO a - -- ^ The decoded value in Haskell. -inputFile = - inputFileWithSettings defaultEvaluateSettings - -{-| Extend 'inputFile' with a custom typing context and a custom - normalization process. - -@since 1.16 --} -inputFileWithSettings - :: EvaluateSettings - -> Decoder a - -- ^ The decoder for the Dhall value - -> FilePath - -- ^ The path to the Dhall program. - -> IO a - -- ^ The decoded value in Haskell. -inputFileWithSettings settings ty path = do - text <- Data.Text.IO.readFile path - let inputSettings = InputSettings - { _rootDirectory = takeDirectory path - , _sourceName = path - , _evaluateSettings = settings - } - inputWithSettings inputSettings ty text - -{-| Similar to `input`, but without interpreting the Dhall `Expr` into a Haskell - type. - - Uses the settings from 'defaultInputSettings'. --} -inputExpr - :: Text - -- ^ The Dhall program - -> IO (Expr Src Void) - -- ^ The fully normalized AST -inputExpr = - inputExprWithSettings defaultInputSettings - -{-| Extend 'inputExpr' with a root directory to resolve imports relative - to, a file to mention in errors as the source, a custom typing - context, and a custom normalization process. - -@since 1.16 --} -inputExprWithSettings - :: InputSettings - -> Text - -- ^ The Dhall program - -> IO (Expr Src Void) - -- ^ The fully normalized AST -inputExprWithSettings = inputHelper id - -{-| Helper function for the input* function family - -@since 1.30 --} -inputHelper - :: (Expr Src Void -> Expr Src Void) - -> InputSettings - -> Text - -- ^ The Dhall program - -> IO (Expr Src Void) - -- ^ The fully normalized AST -inputHelper annotate settings txt = do - expr <- Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt) - - let InputSettings {..} = settings - - let EvaluateSettings {..} = _evaluateSettings - - let transform = - Lens.Family.set Dhall.Import.substitutions _substitutions - . Lens.Family.set Dhall.Import.normalizer _normalizer - . Lens.Family.set Dhall.Import.startingContext _startingContext - - let status = transform (Dhall.Import.emptyStatusWithManager _newManager _rootDirectory) - - expr' <- State.evalStateT (Dhall.Import.loadWith expr) status - - let substituted = Dhall.Substitution.substitute expr' $ view substitutions settings - let annot = annotate substituted - _ <- Core.throws (Dhall.TypeCheck.typeWith (view startingContext settings) annot) - pure (Core.normalizeWith (view normalizer settings) substituted) - --- | Use this function to extract Haskell values directly from Dhall AST. --- The intended use case is to allow easy extraction of Dhall values for --- making the function `Core.normalizeWith` easier to use. --- --- For other use cases, use `input` from "Dhall" module. It will give you --- a much better user experience. -rawInput - :: Alternative f - => Decoder a - -- ^ The decoder for the Dhall value - -> Expr s Void - -- ^ a closed form Dhall program, which evaluates to the expected type - -> f a - -- ^ The decoded value in Haskell -rawInput (Decoder {..}) expr = - case extract (Core.normalize expr) of - Success x -> pure x - Failure _e -> empty - -{-| Use this to provide more detailed error messages - ->> input auto "True" :: IO Integer -> *** Exception: Error: Expression doesn't match annotation -> -> True : Integer -> -> (input):1:1 - ->> detailed (input auto "True") :: IO Integer -> *** Exception: Error: Expression doesn't match annotation -> -> Explanation: You can annotate an expression with its type or kind using the -> ❰:❱ symbol, like this: -> -> -> ┌───────┐ -> │ x : t │ ❰x❱ is an expression and ❰t❱ is the annotated type or kind of ❰x❱ -> └───────┘ -> -> The type checker verifies that the expression's type or kind matches the -> provided annotation -> -> For example, all of the following are valid annotations that the type checker -> accepts: -> -> -> ┌─────────────┐ -> │ 1 : Natural │ ❰1❱ is an expression that has type ❰Natural❱, so the type -> └─────────────┘ checker accepts the annotation -> -> -> ┌───────────────────────┐ -> │ Natural/even 2 : Bool │ ❰Natural/even 2❱ has type ❰Bool❱, so the type -> └───────────────────────┘ checker accepts the annotation -> -> -> ┌────────────────────┐ -> │ List : Type → Type │ ❰List❱ is an expression that has kind ❰Type → Type❱, -> └────────────────────┘ so the type checker accepts the annotation -> -> -> ┌──────────────────┐ -> │ List Text : Type │ ❰List Text❱ is an expression that has kind ❰Type❱, so -> └──────────────────┘ the type checker accepts the annotation -> -> -> However, the following annotations are not valid and the type checker will -> reject them: -> -> -> ┌──────────┐ -> │ 1 : Text │ The type checker rejects this because ❰1❱ does not have type -> └──────────┘ ❰Text❱ -> -> -> ┌─────────────┐ -> │ List : Type │ ❰List❱ does not have kind ❰Type❱ -> └─────────────┘ -> -> -> You or the interpreter annotated this expression: -> -> ↳ True -> -> ... with this type or kind: -> -> ↳ Integer -> -> ... but the inferred type or kind of the expression is actually: -> -> ↳ Bool -> -> Some common reasons why you might get this error: -> -> ● The Haskell Dhall interpreter implicitly inserts a top-level annotation -> matching the expected type -> -> For example, if you run the following Haskell code: -> -> -> ┌───────────────────────────────┐ -> │ >>> input auto "1" :: IO Text │ -> └───────────────────────────────┘ -> -> -> ... then the interpreter will actually type check the following annotated -> expression: -> -> -> ┌──────────┐ -> │ 1 : Text │ -> └──────────┘ -> -> -> ... and then type-checking will fail -> -> ──────────────────────────────────────────────────────────────────────────────── -> -> True : Integer -> -> (input):1:1 - --} -detailed :: IO a -> IO a -detailed = - Control.Exception.handle handler1 . Control.Exception.handle handler0 - where - handler0 :: Imported (TypeError Src Void) -> IO a - handler0 (Imported ps e) = - Control.Exception.throwIO (Imported ps (DetailedTypeError e)) - - handler1 :: TypeError Src Void -> IO a - handler1 e = Control.Exception.throwIO (DetailedTypeError e) - -{-| A @(Decoder a)@ represents a way to marshal a value of type @\'a\'@ from Dhall - into Haskell - - You can produce `Decoder`s either explicitly: - -> example :: Decoder (Vector Text) -> example = vector text - - ... or implicitly using `auto`: - -> example :: Decoder (Vector Text) -> example = auto - - You can consume `Decoder`s using the `input` function: - -> input :: Decoder a -> Text -> IO a --} -data Decoder a = Decoder - { extract :: Expr Src Void -> Extractor Src Void a - -- ^ Extracts Haskell value from the Dhall expression - , expected :: Expector (Expr Src Void) - -- ^ Dhall type of the Haskell value - } - deriving (Functor) - -{-| Decode a `Prelude.Bool` - ->>> input bool "True" -True --} -bool :: Decoder Bool -bool = Decoder {..} - where - extract (BoolLit b) = pure b - extract expr = typeError expected expr - - expected = pure Bool - -{-| Decode a `Prelude.Natural` - ->>> input natural "42" -42 --} -natural :: Decoder Natural -natural = Decoder {..} - where - extract (NaturalLit n) = pure n - extract expr = typeError expected expr - - expected = pure Natural - -{-| Decode an `Prelude.Integer` - ->>> input integer "+42" -42 --} -integer :: Decoder Integer -integer = Decoder {..} - where - extract (IntegerLit n) = pure n - extract expr = typeError expected expr - - expected = pure Integer - -wordHelper :: forall a . (Bounded a, Integral a) => Text -> Decoder a -wordHelper name = Decoder {..} - where - extract (NaturalLit n) - | toInteger n <= toInteger (maxBound @a) = - pure (fromIntegral n) - | otherwise = - extractError ("Decoded " <> name <> " is out of bounds: " <> Data.Text.pack (show n)) - extract expr = - typeError expected expr - - expected = pure Natural - -{-| Decode a `Word` from a Dhall @Natural@ - ->>> input word "42" -42 --} -word :: Decoder Word -word = wordHelper "Word" - -{-| Decode a `Word8` from a Dhall @Natural@ - ->>> input word8 "42" -42 --} -word8 :: Decoder Word8 -word8 = wordHelper "Word8" - -{-| Decode a `Word16` from a Dhall @Natural@ - ->>> input word16 "42" -42 --} -word16 :: Decoder Word16 -word16 = wordHelper "Word16" - -{-| Decode a `Word32` from a Dhall @Natural@ - ->>> input word32 "42" -42 --} -word32 :: Decoder Word32 -word32 = wordHelper "Word32" - -{-| Decode a `Word64` from a Dhall @Natural@ - ->>> input word64 "42" -42 --} -word64 :: Decoder Word64 -word64 = wordHelper "Word64" - -intHelper :: forall a . (Bounded a, Integral a) => Text -> Decoder a -intHelper name = Decoder {..} - where - extract (IntegerLit n) - | toInteger (minBound @a) <= n && n <= toInteger (maxBound @a) = - pure (fromIntegral n) - | otherwise = - extractError ("Decoded " <> name <> " is out of bounds: " <> Data.Text.pack (show n)) - extract expr = - typeError expected expr - - expected = pure Integer - -{-| Decode an `Int` from a Dhall @Integer@ - ->>> input int "-42" --42 --} -int :: Decoder Int -int = intHelper "Int" - -{-| Decode an `Int8` from a Dhall @Integer@ - ->>> input int8 "-42" --42 --} -int8 :: Decoder Int8 -int8 = intHelper "Int8" - -{-| Decode an `Int16` from a Dhall @Integer@ - ->>> input int16 "-42" --42 --} -int16 :: Decoder Int16 -int16 = intHelper "Int16" - -{-| Decode an `Int32` from a Dhall @Integer@ - ->>> input int32 "-42" --42 --} -int32 :: Decoder Int32 -int32 = intHelper "Int32" - -{-| Decode an `Int64` from a Dhall @Integer@ - ->>> input int64 "-42" --42 --} -int64 :: Decoder Int64 -int64 = intHelper "Int64" - -{-| Decode a `Scientific` -r - ->>> input scientific "1e100" -1.0e100 --} -scientific :: Decoder Scientific -scientific = fmap Data.Scientific.fromFloatDigits double - -{-| Decode a `Prelude.Double` - ->>> input double "42.0" -42.0 --} -double :: Decoder Double -double = Decoder {..} - where - extract (DoubleLit (DhallDouble n)) = pure n - extract expr = typeError expected expr - - expected = pure Double - -{-| Decode lazy `Data.Text.Text` - ->>> input lazyText "\"Test\"" -"Test" --} -lazyText :: Decoder Data.Text.Lazy.Text -lazyText = fmap Data.Text.Lazy.fromStrict strictText - -{-| Decode strict `Data.Text.Text` - ->>> input strictText "\"Test\"" -"Test" --} -strictText :: Decoder Text -strictText = Decoder {..} - where - extract (TextLit (Chunks [] t)) = pure t - extract expr = typeError expected expr - - expected = pure Text - -{-| Decode a `Maybe` - ->>> input (maybe natural) "Some 1" -Just 1 --} -maybe :: Decoder a -> Decoder (Maybe a) -maybe (Decoder extractIn expectedIn) = Decoder extractOut expectedOut - where - extractOut (Some e ) = fmap Just (extractIn e) - extractOut (App None _) = pure Nothing - extractOut expr = typeError expectedOut expr - - expectedOut = App Optional <$> expectedIn - -{-| Decode a `Seq` - ->>> input (sequence natural) "[1, 2, 3]" -fromList [1,2,3] --} -sequence :: Decoder a -> Decoder (Seq a) -sequence (Decoder extractIn expectedIn) = Decoder extractOut expectedOut - where - extractOut (ListLit _ es) = traverse extractIn es - extractOut expr = typeError expectedOut expr - - expectedOut = App List <$> expectedIn - -{-| Decode a list - ->>> input (list natural) "[1, 2, 3]" -[1,2,3] --} -list :: Decoder a -> Decoder [a] -list = fmap Data.Foldable.toList . sequence - -{-| Decode a `Vector` - ->>> input (vector natural) "[1, 2, 3]" -[1,2,3] --} -vector :: Decoder a -> Decoder (Vector a) -vector = fmap Data.Vector.fromList . list - -{-| Decode a Dhall function into a Haskell function - ->>> f <- input (function inject bool) "Natural/even" :: IO (Natural -> Bool) ->>> f 0 -True ->>> f 1 -False --} -function - :: Encoder a - -> Decoder b - -> Decoder (a -> b) -function = functionWith defaultInputNormalizer - -{-| Decode a Dhall function into a Haskell function using the specified normalizer - ->>> f <- input (functionWith defaultInputNormalizer inject bool) "Natural/even" :: IO (Natural -> Bool) ->>> f 0 -True ->>> f 1 -False --} -functionWith - :: InputNormalizer - -> Encoder a - -> Decoder b - -> Decoder (a -> b) -functionWith inputNormalizer (Encoder {..}) (Decoder extractIn expectedIn) = - Decoder extractOut expectedOut - where - normalizer_ = Just (getInputNormalizer inputNormalizer) - - extractOut e = pure (\i -> case extractIn (Core.normalizeWith normalizer_ (App e (embed i))) of - Success o -> o - Failure _e -> error "FromDhall: You cannot decode a function if it does not have the correct type" ) - - expectedOut = Pi mempty "_" declared <$> expectedIn - -{-| Decode a `Data.Set.Set` from a `List` - ->>> input (setIgnoringDuplicates natural) "[1, 2, 3]" -fromList [1,2,3] - -Duplicate elements are ignored. - ->>> input (setIgnoringDuplicates natural) "[1, 1, 3]" -fromList [1,3] - --} -setIgnoringDuplicates :: (Ord a) => Decoder a -> Decoder (Data.Set.Set a) -setIgnoringDuplicates = fmap Data.Set.fromList . list - -{-| Decode a `Data.HashSet.HashSet` from a `List` - ->>> input (hashSetIgnoringDuplicates natural) "[1, 2, 3]" -fromList [1,2,3] - -Duplicate elements are ignored. - ->>> input (hashSetIgnoringDuplicates natural) "[1, 1, 3]" -fromList [1,3] - --} -hashSetIgnoringDuplicates :: (Hashable a, Ord a) - => Decoder a - -> Decoder (Data.HashSet.HashSet a) -hashSetIgnoringDuplicates = fmap Data.HashSet.fromList . list - -{-| Decode a `Data.Set.Set` from a `List` with distinct elements - ->>> input (setFromDistinctList natural) "[1, 2, 3]" -fromList [1,2,3] - -An error is thrown if the list contains duplicates. - -> >>> input (setFromDistinctList natural) "[1, 1, 3]" -> *** Exception: Error: Failed extraction -> -> The expression type-checked successfully but the transformation to the target -> type failed with the following error: -> -> One duplicate element in the list: 1 -> - -> >>> input (setFromDistinctList natural) "[1, 1, 3, 3]" -> *** Exception: Error: Failed extraction -> -> The expression type-checked successfully but the transformation to the target -> type failed with the following error: -> -> 2 duplicates were found in the list, including 1 -> - --} -setFromDistinctList :: (Ord a, Show a) => Decoder a -> Decoder (Data.Set.Set a) -setFromDistinctList = setHelper Data.Set.size Data.Set.fromList - -{-| Decode a `Data.HashSet.HashSet` from a `List` with distinct elements - ->>> input (hashSetFromDistinctList natural) "[1, 2, 3]" -fromList [1,2,3] - -An error is thrown if the list contains duplicates. - -> >>> input (hashSetFromDistinctList natural) "[1, 1, 3]" -> *** Exception: Error: Failed extraction -> -> The expression type-checked successfully but the transformation to the target -> type failed with the following error: -> -> One duplicate element in the list: 1 -> - -> >>> input (hashSetFromDistinctList natural) "[1, 1, 3, 3]" -> *** Exception: Error: Failed extraction -> -> The expression type-checked successfully but the transformation to the target -> type failed with the following error: -> -> 2 duplicates were found in the list, including 1 -> - --} -hashSetFromDistinctList :: (Hashable a, Ord a, Show a) - => Decoder a - -> Decoder (Data.HashSet.HashSet a) -hashSetFromDistinctList = setHelper Data.HashSet.size Data.HashSet.fromList - - -setHelper :: (Eq a, Foldable t, Show a) - => (t a -> Int) - -> ([a] -> t a) - -> Decoder a - -> Decoder (t a) -setHelper size toSet (Decoder extractIn expectedIn) = Decoder extractOut expectedOut - where - extractOut (ListLit _ es) = case traverse extractIn es of - Success vSeq - | sameSize -> Success vSet - | otherwise -> extractError err - where - vList = Data.Foldable.toList vSeq - vSet = toSet vList - sameSize = size vSet == Data.Sequence.length vSeq - duplicates = vList List.\\ Data.Foldable.toList vSet - err | length duplicates == 1 = - "One duplicate element in the list: " - <> (Data.Text.pack $ show $ head duplicates) - | otherwise = Data.Text.pack $ unwords - [ show $ length duplicates - , "duplicates were found in the list, including" - , show $ head duplicates - ] - Failure f -> Failure f - extractOut expr = typeError expectedOut expr - - expectedOut = App List <$> expectedIn - -{-| Decode a `Map` from a @toMap@ expression or generally a @Prelude.Map.Type@ - ->>> input (Dhall.map strictText bool) "toMap { a = True, b = False }" -fromList [("a",True),("b",False)] ->>> input (Dhall.map strictText bool) "[ { mapKey = \"foo\", mapValue = True } ]" -fromList [("foo",True)] - -If there are duplicate @mapKey@s, later @mapValue@s take precedence: - ->>> let expr = "[ { mapKey = 1, mapValue = True }, { mapKey = 1, mapValue = False } ]" ->>> input (Dhall.map natural bool) expr -fromList [(1,False)] - --} -map :: Ord k => Decoder k -> Decoder v -> Decoder (Map k v) -map k v = fmap Data.Map.fromList (list (pairFromMapEntry k v)) - -{-| Decode a `HashMap` from a @toMap@ expression or generally a @Prelude.Map.Type@ - ->>> fmap (List.sort . HashMap.toList) (input (Dhall.hashMap strictText bool) "toMap { a = True, b = False }") -[("a",True),("b",False)] ->>> fmap (List.sort . HashMap.toList) (input (Dhall.hashMap strictText bool) "[ { mapKey = \"foo\", mapValue = True } ]") -[("foo",True)] - -If there are duplicate @mapKey@s, later @mapValue@s take precedence: - ->>> let expr = "[ { mapKey = 1, mapValue = True }, { mapKey = 1, mapValue = False } ]" ->>> input (Dhall.hashMap natural bool) expr -fromList [(1,False)] - --} -hashMap :: (Eq k, Hashable k) => Decoder k -> Decoder v -> Decoder (HashMap k v) -hashMap k v = fmap HashMap.fromList (list (pairFromMapEntry k v)) - -{-| Decode a tuple from a @Prelude.Map.Entry@ record - ->>> input (pairFromMapEntry strictText natural) "{ mapKey = \"foo\", mapValue = 3 }" -("foo",3) --} -pairFromMapEntry :: Decoder k -> Decoder v -> Decoder (k, v) -pairFromMapEntry k v = Decoder extractOut expectedOut - where - extractOut (RecordLit kvs) - | Just key <- Core.recordFieldValue <$> Dhall.Map.lookup "mapKey" kvs - , Just value <- Core.recordFieldValue <$> Dhall.Map.lookup "mapValue" kvs - = liftA2 (,) (extract k key) (extract v value) - extractOut expr = typeError expectedOut expr - - expectedOut = do - k' <- Core.makeRecordField <$> expected k - v' <- Core.makeRecordField <$> expected v - pure $ Record $ Dhall.Map.fromList - [ ("mapKey", k') - , ("mapValue", v')] - -{-| Decode @()@ from an empty record. - ->>> input unit "{=}" -- GHC doesn't print the result if it is () - --} -unit :: Decoder () -unit = Decoder {..} - where - extract (RecordLit fields) - | Data.Foldable.null fields = pure () - extract expr = typeError expected expr - - expected = pure $ Record mempty - -{-| Decode 'Void' from an empty union. - -Since @<>@ is uninhabited, @'input' 'void'@ will always fail. --} -void :: Decoder Void -void = union mempty - -{-| Decode a `String` - ->>> input string "\"ABC\"" -"ABC" - --} -string :: Decoder String -string = Data.Text.Lazy.unpack <$> lazyText - -{-| Given a pair of `Decoder`s, decode a tuple-record into their pairing. - ->>> input (pair natural bool) "{ _1 = 42, _2 = False }" -(42,False) --} -pair :: Decoder a -> Decoder b -> Decoder (a, b) -pair l r = Decoder extractOut expectedOut - where - extractOut expr@(RecordLit fields) = - (,) <$> Data.Maybe.maybe (typeError expectedOut expr) (extract l) - (Core.recordFieldValue <$> Dhall.Map.lookup "_1" fields) - <*> Data.Maybe.maybe (typeError expectedOut expr) (extract r) - (Core.recordFieldValue <$> Dhall.Map.lookup "_2" fields) - extractOut expr = typeError expectedOut expr - - expectedOut = do - l' <- Core.makeRecordField <$> expected l - r' <- Core.makeRecordField <$> expected r - pure $ Record $ Dhall.Map.fromList - [ ("_1", l') - , ("_2", r')] - -{-| Any value that implements `FromDhall` can be automatically decoded based on - the inferred return type of `input` - ->>> input auto "[1, 2, 3]" :: IO (Vector Natural) -[1,2,3] ->>> input auto "toMap { a = False, b = True }" :: IO (Map Text Bool) -fromList [("a",False),("b",True)] - - This class auto-generates a default implementation for types that - implement `Generic`. This does not auto-generate an instance for recursive - types. - - The default instance can be tweaked using 'genericAutoWith' and custom - 'InterpretOptions', or using - [DerivingVia](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-DerivingVia) - and 'Dhall.Deriving.Codec' from "Dhall.Deriving". --} -class FromDhall a where - autoWith :: InputNormalizer -> Decoder a - default autoWith - :: (Generic a, GenericFromDhall a (Rep a)) => InputNormalizer -> Decoder a - autoWith _ = genericAuto - --- | A compatibility alias for `FromDhall` -type Interpret = FromDhall -{-# DEPRECATED Interpret "Use FromDhall instead" #-} - -instance FromDhall Void where - autoWith _ = void - -instance FromDhall () where - autoWith _ = unit - -instance FromDhall Bool where - autoWith _ = bool - -instance FromDhall Natural where - autoWith _ = natural - -instance FromDhall Word where - autoWith _ = word - -instance FromDhall Word8 where - autoWith _ = word8 - -instance FromDhall Word16 where - autoWith _ = word16 - -instance FromDhall Word32 where - autoWith _ = word32 - -instance FromDhall Word64 where - autoWith _ = word64 - -instance FromDhall Integer where - autoWith _ = integer - -instance FromDhall Int where - autoWith _ = int - -instance FromDhall Int8 where - autoWith _ = int8 - -instance FromDhall Int16 where - autoWith _ = int16 - -instance FromDhall Int32 where - autoWith _ = int32 - -instance FromDhall Int64 where - autoWith _ = int64 - -instance FromDhall Scientific where - autoWith _ = scientific - -instance FromDhall Double where - autoWith _ = double - -instance {-# OVERLAPS #-} FromDhall [Char] where - autoWith _ = string - -instance FromDhall Data.Text.Lazy.Text where - autoWith _ = lazyText - -instance FromDhall Text where - autoWith _ = strictText - -instance FromDhall a => FromDhall (Maybe a) where - autoWith opts = maybe (autoWith opts) - -instance FromDhall a => FromDhall (Seq a) where - autoWith opts = sequence (autoWith opts) - -instance FromDhall a => FromDhall [a] where - autoWith opts = list (autoWith opts) - -instance FromDhall a => FromDhall (Vector a) where - autoWith opts = vector (autoWith opts) - -{-| Note that this instance will throw errors in the presence of duplicates in - the list. To ignore duplicates, use `setIgnoringDuplicates`. --} -instance (FromDhall a, Ord a, Show a) => FromDhall (Data.Set.Set a) where - autoWith opts = setFromDistinctList (autoWith opts) - -{-| Note that this instance will throw errors in the presence of duplicates in - the list. To ignore duplicates, use `hashSetIgnoringDuplicates`. --} -instance (FromDhall a, Hashable a, Ord a, Show a) => FromDhall (Data.HashSet.HashSet a) where - autoWith inputNormalizer = hashSetFromDistinctList (autoWith inputNormalizer) - -instance (Ord k, FromDhall k, FromDhall v) => FromDhall (Map k v) where - autoWith inputNormalizer = Dhall.map (autoWith inputNormalizer) (autoWith inputNormalizer) - -instance (Eq k, Hashable k, FromDhall k, FromDhall v) => FromDhall (HashMap k v) where - autoWith inputNormalizer = Dhall.hashMap (autoWith inputNormalizer) (autoWith inputNormalizer) - -instance (ToDhall a, FromDhall b) => FromDhall (a -> b) where - autoWith inputNormalizer = - functionWith inputNormalizer (injectWith inputNormalizer) (autoWith inputNormalizer) - -instance (FromDhall a, FromDhall b) => FromDhall (a, b) - -{-| Use the default input normalizer for interpreting a configuration file - -> auto = autoWith defaultInputNormalizer --} -auto :: FromDhall a => Decoder a -auto = autoWith defaultInputNormalizer - -{-| This type is exactly the same as `Data.Fix.Fix` except with a different - `FromDhall` instance. This intermediate type simplifies the implementation - of the inner loop for the `FromDhall` instance for `Fix` --} -newtype Result f = Result { _unResult :: f (Result f) } - -resultToFix :: Functor f => Result f -> Fix f -resultToFix (Result x) = Fix (fmap resultToFix x) - -fixToResult :: Functor f => Fix f -> Result f -fixToResult (Fix x) = Result (fmap fixToResult x) - -instance FromDhall (f (Result f)) => FromDhall (Result f) where - autoWith inputNormalizer = Decoder {..} - where - extract (App _ expr) = - fmap Result (Dhall.extract (autoWith inputNormalizer) expr) - extract expr = typeError expected expr - - expected = pure "result" - -instance ToDhall (f (Result f)) => ToDhall (Result f) where - injectWith inputNormalizer = Encoder {..} - where - embed = App "Make" . Dhall.embed (injectWith inputNormalizer) . _unResult - declared = "result" - --- | You can use this instance to marshal recursive types from Dhall to Haskell. --- --- Here is an example use of this instance: --- --- > {-# LANGUAGE DeriveAnyClass #-} --- > {-# LANGUAGE DeriveFoldable #-} --- > {-# LANGUAGE DeriveFunctor #-} --- > {-# LANGUAGE DeriveTraversable #-} --- > {-# LANGUAGE DeriveGeneric #-} --- > {-# LANGUAGE KindSignatures #-} --- > {-# LANGUAGE QuasiQuotes #-} --- > {-# LANGUAGE StandaloneDeriving #-} --- > {-# LANGUAGE TypeFamilies #-} --- > {-# LANGUAGE TemplateHaskell #-} --- > --- > import Data.Fix (Fix(..)) --- > import Data.Text (Text) --- > import Dhall (FromDhall) --- > import GHC.Generics (Generic) --- > import Numeric.Natural (Natural) --- > --- > import qualified Data.Fix as Fix --- > import qualified Data.Functor.Foldable as Foldable --- > import qualified Data.Functor.Foldable.TH as TH --- > import qualified Dhall --- > import qualified NeatInterpolation --- > --- > data Expr --- > = Lit Natural --- > | Add Expr Expr --- > | Mul Expr Expr --- > deriving (Show) --- > --- > TH.makeBaseFunctor ''Expr --- > --- > deriving instance Generic (ExprF a) --- > deriving instance FromDhall a => FromDhall (ExprF a) --- > --- > example :: Text --- > example = [NeatInterpolation.text| --- > \(Expr : Type) --- > -> let ExprF = --- > < LitF : --- > Natural --- > | AddF : --- > { _1 : Expr, _2 : Expr } --- > | MulF : --- > { _1 : Expr, _2 : Expr } --- > > --- > --- > in \(Fix : ExprF -> Expr) --- > -> let Lit = \(x : Natural) -> Fix (ExprF.LitF x) --- > --- > let Add = --- > \(x : Expr) --- > -> \(y : Expr) --- > -> Fix (ExprF.AddF { _1 = x, _2 = y }) --- > --- > let Mul = --- > \(x : Expr) --- > -> \(y : Expr) --- > -> Fix (ExprF.MulF { _1 = x, _2 = y }) --- > --- > in Add (Mul (Lit 3) (Lit 7)) (Add (Lit 1) (Lit 2)) --- > |] --- > --- > convert :: Fix ExprF -> Expr --- > convert = Fix.foldFix Foldable.embed --- > --- > main :: IO () --- > main = do --- > x <- Dhall.input Dhall.auto example :: IO (Fix ExprF) --- > --- > print (convert x :: Expr) -instance (Functor f, FromDhall (f (Result f))) => FromDhall (Fix f) where - autoWith inputNormalizer = Decoder {..} - where - extract expr0 = extract0 expr0 - where - die = typeError expected expr0 - - extract0 (Lam _ (FunctionBinding { functionBindingVariable = x }) expr) = - extract1 (rename x "result" expr) - extract0 _ = die - - extract1 (Lam _ (FunctionBinding { functionBindingVariable = y }) expr) = - extract2 (rename y "Make" expr) - extract1 _ = die - - extract2 expr = fmap resultToFix (Dhall.extract (autoWith inputNormalizer) expr) - - rename a b expr - | a /= b = Core.subst (V a 0) (Var (V b 0)) (Core.shift 1 (V b 0) expr) - | otherwise = expr - - expected = (\x -> Pi mempty "result" (Const Core.Type) (Pi mempty "Make" (Pi mempty "_" x "result") "result")) - <$> Dhall.expected (autoWith inputNormalizer :: Decoder (f (Result f))) - -instance forall f. (Functor f, ToDhall (f (Result f))) => ToDhall (Fix f) where - injectWith inputNormalizer = Encoder {..} - where - embed fixf = - Lam Nothing (Core.makeFunctionBinding "result" (Const Core.Type)) $ - Lam Nothing (Core.makeFunctionBinding "Make" makeType) $ - embed' . fixToResult $ fixf - - declared = Pi Nothing "result" (Const Core.Type) $ Pi Nothing "_" makeType "result" - - makeType = Pi Nothing "_" declared' "result" - Encoder embed' _ = injectWith @(Dhall.Result f) inputNormalizer - Encoder _ declared' = injectWith @(f (Dhall.Result f)) inputNormalizer - -{-| `genericAuto` is the default implementation for `auto` if you derive - `FromDhall`. The difference is that you can use `genericAuto` without - having to explicitly provide a `FromDhall` instance for a type as long as - the type derives `Generic` --} -genericAuto :: (Generic a, GenericFromDhall a (Rep a)) => Decoder a -genericAuto = genericAutoWith defaultInterpretOptions - -{-| `genericAutoWith` is a configurable version of `genericAuto`. --} -genericAutoWith :: (Generic a, GenericFromDhall a (Rep a)) => InterpretOptions -> Decoder a -genericAutoWith options = withProxy (\p -> fmap to (evalState (genericAutoWithNormalizer p defaultInputNormalizer options) 1)) - where - withProxy :: (Proxy a -> Decoder a) -> Decoder a - withProxy f = f Proxy - - -{-| Use these options to tweak how Dhall derives a generic implementation of - `FromDhall` --} -data InterpretOptions = InterpretOptions - { fieldModifier :: Text -> Text - -- ^ Function used to transform Haskell field names into their corresponding - -- Dhall field names - , constructorModifier :: Text -> Text - -- ^ Function used to transform Haskell constructor names into their - -- corresponding Dhall alternative names - , singletonConstructors :: SingletonConstructors - -- ^ Specify how to handle constructors with only one field. The default is - -- `Smart` - } - --- | This is only used by the `FromDhall` instance for functions in order --- to normalize the function input before marshaling the input into a --- Dhall expression -newtype InputNormalizer = InputNormalizer - { getInputNormalizer :: Core.ReifiedNormalizer Void } - --- | Default normalization-related settings (no custom normalization) -defaultInputNormalizer :: InputNormalizer -defaultInputNormalizer = InputNormalizer - { getInputNormalizer = Core.ReifiedNormalizer (const (pure Nothing)) } - -{-| This type specifies how to model a Haskell constructor with 1 field in - Dhall - - For example, consider the following Haskell datatype definition: - - > data Example = Foo { x :: Double } | Bar Double - - Depending on which option you pick, the corresponding Dhall type could be: - - > < Foo : Double | Bar : Double > -- Bare - - > < Foo : { x : Double } | Bar : { _1 : Double } > -- Wrapped - - > < Foo : { x : Double } | Bar : Double > -- Smart --} -data SingletonConstructors - = Bare - -- ^ Never wrap the field in a record - | Wrapped - -- ^ Always wrap the field in a record - | Smart - -- ^ Only fields in a record if they are named - -{-| Default interpret options for generics-based instances, - which you can tweak or override, like this: - -> genericAutoWith -> (defaultInterpretOptions { fieldModifier = Data.Text.Lazy.dropWhile (== '_') }) --} -defaultInterpretOptions :: InterpretOptions -defaultInterpretOptions = InterpretOptions - { fieldModifier = - id - , constructorModifier = - id - , singletonConstructors = - Smart - } - -{-| This is the underlying class that powers the `FromDhall` class's support - for automatically deriving a generic implementation --} -class GenericFromDhall t f where - genericAutoWithNormalizer :: Proxy t -> InputNormalizer -> InterpretOptions -> State Int (Decoder (f a)) - -instance GenericFromDhall t f => GenericFromDhall t (M1 D d f) where - genericAutoWithNormalizer p inputNormalizer options = do - res <- genericAutoWithNormalizer p inputNormalizer options - pure (fmap M1 res) - -instance GenericFromDhall t V1 where - genericAutoWithNormalizer _ _ _ = pure Decoder {..} - where - extract expr = typeError expected expr - - expected = pure $ Union mempty - -unsafeExpectUnion - :: Text -> Expr Src Void -> Dhall.Map.Map Text (Maybe (Expr Src Void)) -unsafeExpectUnion _ (Union kts) = - kts -unsafeExpectUnion name expression = - Core.internalError - (name <> ": Unexpected constructor: " <> Core.pretty expression) - -unsafeExpectRecord - :: Text -> Expr Src Void -> Dhall.Map.Map Text (RecordField Src Void) -unsafeExpectRecord _ (Record kts) = - kts -unsafeExpectRecord name expression = - Core.internalError - (name <> ": Unexpected constructor: " <> Core.pretty expression) - -unsafeExpectUnionLit - :: Text - -> Expr Src Void - -> (Text, Maybe (Expr Src Void)) -unsafeExpectUnionLit _ (Field (Union _) (Core.fieldSelectionLabel -> k)) = - (k, Nothing) -unsafeExpectUnionLit _ (App (Field (Union _) (Core.fieldSelectionLabel -> k)) v) = - (k, Just v) -unsafeExpectUnionLit name expression = - Core.internalError - (name <> ": Unexpected constructor: " <> Core.pretty expression) - -unsafeExpectRecordLit - :: Text -> Expr Src Void -> Dhall.Map.Map Text (RecordField Src Void) -unsafeExpectRecordLit _ (RecordLit kvs) = - kvs -unsafeExpectRecordLit name expression = - Core.internalError - (name <> ": Unexpected constructor: " <> Core.pretty expression) - -notEmptyRecordLit :: Expr s a -> Maybe (Expr s a) -notEmptyRecordLit e = case e of - RecordLit m | null m -> Nothing - _ -> Just e - -notEmptyRecord :: Expr s a -> Maybe (Expr s a) -notEmptyRecord e = case e of - Record m | null m -> Nothing - _ -> Just e -extractUnionConstructor - :: Expr s a -> Maybe (Text, Expr s a, Dhall.Map.Map Text (Maybe (Expr s a))) -extractUnionConstructor (App (Field (Union kts) (Core.fieldSelectionLabel -> fld)) e) = - return (fld, e, Dhall.Map.delete fld kts) -extractUnionConstructor (Field (Union kts) (Core.fieldSelectionLabel -> fld)) = - return (fld, RecordLit mempty, Dhall.Map.delete fld kts) -extractUnionConstructor _ = - empty - -{-| This is the underlying class that powers the `FromDhall` class's support - for automatically deriving a generic implementation for a union type --} -class GenericFromDhallUnion t f where - genericUnionAutoWithNormalizer :: Proxy t -> InputNormalizer -> InterpretOptions -> UnionDecoder (f a) - -instance (GenericFromDhallUnion t f1, GenericFromDhallUnion t f2) => GenericFromDhallUnion t (f1 :+: f2) where - genericUnionAutoWithNormalizer p inputNormalizer options = - (<>) - (L1 <$> genericUnionAutoWithNormalizer p inputNormalizer options) - (R1 <$> genericUnionAutoWithNormalizer p inputNormalizer options) - -instance (Constructor c1, GenericFromDhall t f1) => GenericFromDhallUnion t (M1 C c1 f1) where - genericUnionAutoWithNormalizer p inputNormalizer options@(InterpretOptions {..}) = - constructor name (evalState (genericAutoWithNormalizer p inputNormalizer options) 1) - where - n :: M1 C c1 f1 a - n = undefined - - name = constructorModifier (Data.Text.pack (conName n)) - -instance GenericFromDhallUnion t (f :+: g) => GenericFromDhall t (f :+: g) where - genericAutoWithNormalizer p inputNormalizer options = - pure (union (genericUnionAutoWithNormalizer p inputNormalizer options)) - -instance GenericFromDhall t f => GenericFromDhall t (M1 C c f) where - genericAutoWithNormalizer p inputNormalizer options = do - res <- genericAutoWithNormalizer p inputNormalizer options - pure (fmap M1 res) - -instance GenericFromDhall t U1 where - genericAutoWithNormalizer _ _ _ = pure (Decoder {..}) - where - extract _ = pure U1 - - expected = pure expected' - - expected' = Record (Dhall.Map.fromList []) - -getSelName :: Selector s => M1 i s f a -> State Int Text -getSelName n = case selName n of - "" -> do i <- get - put (i + 1) - pure (Data.Text.pack ("_" ++ show i)) - nn -> pure (Data.Text.pack nn) - -instance (GenericFromDhall t (f :*: g), GenericFromDhall t (h :*: i)) => GenericFromDhall t ((f :*: g) :*: (h :*: i)) where - genericAutoWithNormalizer p inputNormalizer options = do - Decoder extractL expectedL <- genericAutoWithNormalizer p inputNormalizer options - Decoder extractR expectedR <- genericAutoWithNormalizer p inputNormalizer options - - let ktsL = unsafeExpectRecord "genericAutoWithNormalizer (:*:)" <$> expectedL - let ktsR = unsafeExpectRecord "genericAutoWithNormalizer (:*:)" <$> expectedR - - let expected = Record <$> (Dhall.Map.union <$> ktsL <*> ktsR) - - let extract expression = - liftA2 (:*:) (extractL expression) (extractR expression) - - return (Decoder {..}) - -instance (GenericFromDhall t (f :*: g), Selector s, FromDhall a) => GenericFromDhall t ((f :*: g) :*: M1 S s (K1 i a)) where - genericAutoWithNormalizer p inputNormalizer options@InterpretOptions{..} = do - let nR :: M1 S s (K1 i a) r - nR = undefined - - nameR <- fmap fieldModifier (getSelName nR) - - Decoder extractL expectedL <- genericAutoWithNormalizer p inputNormalizer options - - let Decoder extractR expectedR = autoWith inputNormalizer - - let ktsL = unsafeExpectRecord "genericAutoWithNormalizer (:*:)" <$> expectedL - - let expected = Record <$> (Dhall.Map.insert nameR . Core.makeRecordField <$> expectedR <*> ktsL) - - let extract expression = do - let die = typeError expected expression - - case expression of - RecordLit kvs -> - case Core.recordFieldValue <$> Dhall.Map.lookup nameR kvs of - Just expressionR -> - liftA2 (:*:) - (extractL expression) - (fmap (M1 . K1) (extractR expressionR)) - _ -> die - _ -> die - - return (Decoder {..}) - -instance (Selector s, FromDhall a, GenericFromDhall t (f :*: g)) => GenericFromDhall t (M1 S s (K1 i a) :*: (f :*: g)) where - genericAutoWithNormalizer p inputNormalizer options@InterpretOptions{..} = do - let nL :: M1 S s (K1 i a) r - nL = undefined - - nameL <- fmap fieldModifier (getSelName nL) - - let Decoder extractL expectedL = autoWith inputNormalizer - - Decoder extractR expectedR <- genericAutoWithNormalizer p inputNormalizer options - - let ktsR = unsafeExpectRecord "genericAutoWithNormalizer (:*:)" <$> expectedR - - let expected = Record <$> (Dhall.Map.insert nameL . Core.makeRecordField <$> expectedL <*> ktsR) - - let extract expression = do - let die = typeError expected expression - - case expression of - RecordLit kvs -> - case Core.recordFieldValue <$> Dhall.Map.lookup nameL kvs of - Just expressionL -> - liftA2 (:*:) - (fmap (M1 . K1) (extractL expressionL)) - (extractR expression) - _ -> die - _ -> die - - return (Decoder {..}) - -instance {-# OVERLAPPING #-} GenericFromDhall a1 (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where - genericAutoWithNormalizer _ _ _ = pure $ Decoder - { extract = \_ -> Failure $ DhallErrors $ pure $ ExpectedTypeError RecursiveTypeError - , expected = Failure $ DhallErrors $ pure RecursiveTypeError - } - -instance {-# OVERLAPPING #-} GenericFromDhall a2 (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where - genericAutoWithNormalizer _ _ _ = pure $ Decoder - { extract = \_ -> Failure $ DhallErrors $ pure $ ExpectedTypeError RecursiveTypeError - , expected = Failure $ DhallErrors $ pure RecursiveTypeError - } - -instance {-# OVERLAPPABLE #-} (Selector s1, Selector s2, FromDhall a1, FromDhall a2) => GenericFromDhall t (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where - genericAutoWithNormalizer _ inputNormalizer InterpretOptions{..} = do - let nL :: M1 S s1 (K1 i1 a1) r - nL = undefined - - let nR :: M1 S s2 (K1 i2 a2) r - nR = undefined - - nameL <- fmap fieldModifier (getSelName nL) - nameR <- fmap fieldModifier (getSelName nR) - - let Decoder extractL expectedL = autoWith inputNormalizer - let Decoder extractR expectedR = autoWith inputNormalizer - - let expected = do - l <- Core.makeRecordField <$> expectedL - r <- Core.makeRecordField <$> expectedR - pure $ Record - (Dhall.Map.fromList - [ (nameL, l) - , (nameR, r) - ] - ) - - let extract expression = do - let die = typeError expected expression - - case expression of - RecordLit kvs -> - case liftA2 (,) (Dhall.Map.lookup nameL kvs) (Dhall.Map.lookup nameR kvs) of - Just (expressionL, expressionR) -> - liftA2 (:*:) - (fmap (M1 . K1) (extractL $ Core.recordFieldValue expressionL)) - (fmap (M1 . K1) (extractR $ Core.recordFieldValue expressionR)) - Nothing -> die - _ -> die - - return (Decoder {..}) - -instance {-# OVERLAPPING #-} GenericFromDhall a (M1 S s (K1 i a)) where - genericAutoWithNormalizer _ _ _ = pure $ Decoder - { extract = \_ -> Failure $ DhallErrors $ pure $ ExpectedTypeError RecursiveTypeError - , expected = Failure $ DhallErrors $ pure RecursiveTypeError - } - -instance {-# OVERLAPPABLE #-} (Selector s, FromDhall a) => GenericFromDhall t (M1 S s (K1 i a)) where - genericAutoWithNormalizer _ inputNormalizer InterpretOptions{..} = do - let n :: M1 S s (K1 i a) r - n = undefined - - name <- fmap fieldModifier (getSelName n) - - let Decoder { extract = extract', expected = expected'} = autoWith inputNormalizer - - let expected = - case singletonConstructors of - Bare -> - expected' - Smart | selName n == "" -> - expected' - _ -> - Record . Dhall.Map.singleton name . Core.makeRecordField <$> expected' - - let extract0 expression = fmap (M1 . K1) (extract' expression) - - let extract1 expression = do - let die = typeError expected expression - - case expression of - RecordLit kvs -> - case Core.recordFieldValue <$> Dhall.Map.lookup name kvs of - Just subExpression -> - fmap (M1 . K1) (extract' subExpression) - Nothing -> - die - _ -> die - - let extract = - case singletonConstructors of - Bare -> extract0 - Smart | selName n == "" -> extract0 - _ -> extract1 - - return (Decoder {..}) - -{-| An @(Encoder a)@ represents a way to marshal a value of type @\'a\'@ from - Haskell into Dhall --} -data Encoder a = Encoder - { embed :: a -> Expr Src Void - -- ^ Embeds a Haskell value as a Dhall expression - , declared :: Expr Src Void - -- ^ Dhall type of the Haskell value - } - -instance Contravariant Encoder where - contramap f (Encoder embed declared) = Encoder embed' declared - where - embed' x = embed (f x) - -{-| This class is used by `FromDhall` instance for functions: - -> instance (ToDhall a, FromDhall b) => FromDhall (a -> b) - - You can convert Dhall functions with "simple" inputs (i.e. instances of this - class) into Haskell functions. This works by: - - * Marshaling the input to the Haskell function into a Dhall expression (i.e. - @x :: Expr Src Void@) - * Applying the Dhall function (i.e. @f :: Expr Src Void@) to the Dhall input - (i.e. @App f x@) - * Normalizing the syntax tree (i.e. @normalize (App f x)@) - * Marshaling the resulting Dhall expression back into a Haskell value - - This class auto-generates a default implementation for types that - implement `Generic`. This does not auto-generate an instance for recursive - types. - - The default instance can be tweaked using 'genericToDhallWith' and custom - 'InterpretOptions', or using - [DerivingVia](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-DerivingVia) - and 'Dhall.Deriving.Codec' from "Dhall.Deriving". --} -class ToDhall a where - injectWith :: InputNormalizer -> Encoder a - default injectWith - :: (Generic a, GenericToDhall (Rep a)) => InputNormalizer -> Encoder a - injectWith _ = genericToDhall - --- | A compatibility alias for `ToDhall` -type Inject = ToDhall -{-# DEPRECATED Inject "Use ToDhall instead" #-} - -{-| Use the default input normalizer for injecting a value - -> inject = injectWith defaultInputNormalizer --} -inject :: ToDhall a => Encoder a -inject = injectWith defaultInputNormalizer - -{-| Use the default options for injecting a value, whose structure is -determined generically. - -This can be used when you want to use 'ToDhall' on types that you don't -want to define orphan instances for. --} -genericToDhall - :: (Generic a, GenericToDhall (Rep a)) => Encoder a -genericToDhall - = genericToDhallWith defaultInterpretOptions - -{-| Use custom options for injecting a value, whose structure is -determined generically. - -This can be used when you want to use 'ToDhall' on types that you don't -want to define orphan instances for. --} -genericToDhallWith - :: (Generic a, GenericToDhall (Rep a)) => InterpretOptions -> Encoder a -genericToDhallWith options - = contramap GHC.Generics.from (evalState (genericToDhallWithNormalizer defaultInputNormalizer options) 1) - -instance ToDhall Void where - injectWith _ = Encoder {..} - where - embed = Data.Void.absurd - - declared = Union mempty - -instance ToDhall Bool where - injectWith _ = Encoder {..} - where - embed = BoolLit - - declared = Bool - -instance ToDhall Data.Text.Lazy.Text where - injectWith _ = Encoder {..} - where - embed text = - TextLit (Chunks [] (Data.Text.Lazy.toStrict text)) - - declared = Text - -instance ToDhall Text where - injectWith _ = Encoder {..} - where - embed text = TextLit (Chunks [] text) - - declared = Text - -instance {-# OVERLAPS #-} ToDhall String where - injectWith inputNormalizer = - contramap Data.Text.pack (injectWith inputNormalizer :: Encoder Text) - -instance ToDhall Natural where - injectWith _ = Encoder {..} - where - embed = NaturalLit - - declared = Natural - -instance ToDhall Integer where - injectWith _ = Encoder {..} - where - embed = IntegerLit - - declared = Integer - -instance ToDhall Int where - injectWith _ = Encoder {..} - where - embed = IntegerLit . toInteger - - declared = Integer - -{-| - ->>> embed inject (12 :: Word) -NaturalLit 12 --} - -instance ToDhall Word where - injectWith _ = Encoder {..} - where - embed = NaturalLit . fromIntegral - - declared = Natural - -{-| - ->>> embed inject (12 :: Word8) -NaturalLit 12 --} - -instance ToDhall Word8 where - injectWith _ = Encoder {..} - where - embed = NaturalLit . fromIntegral - - declared = Natural - -{-| - ->>> embed inject (12 :: Word16) -NaturalLit 12 --} - -instance ToDhall Word16 where - injectWith _ = Encoder {..} - where - embed = NaturalLit . fromIntegral - - declared = Natural - -{-| - ->>> embed inject (12 :: Word32) -NaturalLit 12 --} - -instance ToDhall Word32 where - injectWith _ = Encoder {..} - where - embed = NaturalLit . fromIntegral - - declared = Natural - -{-| - ->>> embed inject (12 :: Word64) -NaturalLit 12 --} - -instance ToDhall Word64 where - injectWith _ = Encoder {..} - where - embed = NaturalLit . fromIntegral - - declared = Natural - -instance ToDhall Double where - injectWith _ = Encoder {..} - where - embed = DoubleLit . DhallDouble - - declared = Double - -instance ToDhall Scientific where - injectWith inputNormalizer = - contramap Data.Scientific.toRealFloat (injectWith inputNormalizer :: Encoder Double) - -instance ToDhall () where - injectWith _ = Encoder {..} - where - embed = const (RecordLit mempty) - - declared = Record mempty - -instance ToDhall a => ToDhall (Maybe a) where - injectWith inputNormalizer = Encoder embedOut declaredOut - where - embedOut (Just x ) = Some (embedIn x) - embedOut Nothing = App None declaredIn - - Encoder embedIn declaredIn = injectWith inputNormalizer - - declaredOut = App Optional declaredIn - -instance ToDhall a => ToDhall (Seq a) where - injectWith inputNormalizer = Encoder embedOut declaredOut - where - embedOut xs = ListLit listType (fmap embedIn xs) - where - listType - | null xs = Just (App List declaredIn) - | otherwise = Nothing - - declaredOut = App List declaredIn - - Encoder embedIn declaredIn = injectWith inputNormalizer - -instance ToDhall a => ToDhall [a] where - injectWith = fmap (contramap Data.Sequence.fromList) injectWith - -instance ToDhall a => ToDhall (Vector a) where - injectWith = fmap (contramap Data.Vector.toList) injectWith - -{-| Note that the output list will be sorted - ->>> let x = Data.Set.fromList ["mom", "hi" :: Text] ->>> prettyExpr $ embed inject x -[ "hi", "mom" ] - --} -instance ToDhall a => ToDhall (Data.Set.Set a) where - injectWith = fmap (contramap Data.Set.toAscList) injectWith - --- | Note that the output list may not be sorted -instance ToDhall a => ToDhall (Data.HashSet.HashSet a) where - injectWith = fmap (contramap Data.HashSet.toList) injectWith - -instance (ToDhall a, ToDhall b) => ToDhall (a, b) - -{-| Embed a `Data.Map` as a @Prelude.Map.Type@ - ->>> prettyExpr $ embed inject (Data.Map.fromList [(1 :: Natural, True)]) -[ { mapKey = 1, mapValue = True } ] - ->>> prettyExpr $ embed inject (Data.Map.fromList [] :: Data.Map.Map Natural Bool) -[] : List { mapKey : Natural, mapValue : Bool } - --} -instance (ToDhall k, ToDhall v) => ToDhall (Data.Map.Map k v) where - injectWith inputNormalizer = Encoder embedOut declaredOut - where - embedOut m = ListLit listType (mapEntries m) - where - listType - | Data.Map.null m = Just declaredOut - | otherwise = Nothing - - declaredOut = App List (Record $ Dhall.Map.fromList - [ ("mapKey", Core.makeRecordField declaredK) - , ("mapValue", Core.makeRecordField declaredV) - ]) - - mapEntries = Data.Sequence.fromList . fmap recordPair . Data.Map.toList - recordPair (k, v) = RecordLit $ Dhall.Map.fromList - [ ("mapKey", Core.makeRecordField $ embedK k) - , ("mapValue", Core.makeRecordField $ embedV v) - ] - - Encoder embedK declaredK = injectWith inputNormalizer - Encoder embedV declaredV = injectWith inputNormalizer - -{-| Embed a `Data.HashMap` as a @Prelude.Map.Type@ - ->>> prettyExpr $ embed inject (HashMap.fromList [(1 :: Natural, True)]) -[ { mapKey = 1, mapValue = True } ] - ->>> prettyExpr $ embed inject (HashMap.fromList [] :: HashMap Natural Bool) -[] : List { mapKey : Natural, mapValue : Bool } - --} -instance (ToDhall k, ToDhall v) => ToDhall (HashMap k v) where - injectWith inputNormalizer = Encoder embedOut declaredOut - where - embedOut m = ListLit listType (mapEntries m) - where - listType - | HashMap.null m = Just declaredOut - | otherwise = Nothing - - declaredOut = App List (Record $ Dhall.Map.fromList - [ ("mapKey", Core.makeRecordField declaredK) - , ("mapValue", Core.makeRecordField declaredV) - ]) - - mapEntries = Data.Sequence.fromList . fmap recordPair . HashMap.toList - recordPair (k, v) = RecordLit $ Dhall.Map.fromList - [ ("mapKey", Core.makeRecordField $ embedK k) - , ("mapValue", Core.makeRecordField $ embedV v) - ] - - Encoder embedK declaredK = injectWith inputNormalizer - Encoder embedV declaredV = injectWith inputNormalizer - -{-| This is the underlying class that powers the `FromDhall` class's support - for automatically deriving a generic implementation --} -class GenericToDhall f where - genericToDhallWithNormalizer :: InputNormalizer -> InterpretOptions -> State Int (Encoder (f a)) - -instance GenericToDhall f => GenericToDhall (M1 D d f) where - genericToDhallWithNormalizer inputNormalizer options = do - res <- genericToDhallWithNormalizer inputNormalizer options - pure (contramap unM1 res) - -instance GenericToDhall f => GenericToDhall (M1 C c f) where - genericToDhallWithNormalizer inputNormalizer options = do - res <- genericToDhallWithNormalizer inputNormalizer options - pure (contramap unM1 res) - -instance (Selector s, ToDhall a) => GenericToDhall (M1 S s (K1 i a)) where - genericToDhallWithNormalizer inputNormalizer InterpretOptions{..} = do - let Encoder { embed = embed', declared = declared' } = - injectWith inputNormalizer - - let n :: M1 S s (K1 i a) r - n = undefined - - name <- fieldModifier <$> getSelName n - - let embed0 (M1 (K1 x)) = embed' x - - let embed1 (M1 (K1 x)) = - RecordLit (Dhall.Map.singleton name (Core.makeRecordField $ embed' x)) - - let embed = - case singletonConstructors of - Bare -> embed0 - Smart | selName n == "" -> embed0 - _ -> embed1 - - let declared = - case singletonConstructors of - Bare -> - declared' - Smart | selName n == "" -> - declared' - _ -> - Record (Dhall.Map.singleton name $ Core.makeRecordField declared') - - return (Encoder {..}) - -instance (Constructor c1, Constructor c2, GenericToDhall f1, GenericToDhall f2) => GenericToDhall (M1 C c1 f1 :+: M1 C c2 f2) where - genericToDhallWithNormalizer inputNormalizer options@(InterpretOptions {..}) = pure (Encoder {..}) - where - embed (L1 (M1 l)) = - case notEmptyRecordLit (embedL l) of - Nothing -> - Field declared $ Core.makeFieldSelection keyL - Just valL -> - App (Field declared $ Core.makeFieldSelection keyL) valL - - embed (R1 (M1 r)) = - case notEmptyRecordLit (embedR r) of - Nothing -> - Field declared $ Core.makeFieldSelection keyR - Just valR -> - App (Field declared $ Core.makeFieldSelection keyR) valR - - declared = - Union - (Dhall.Map.fromList - [ (keyL, notEmptyRecord declaredL) - , (keyR, notEmptyRecord declaredR) - ] - ) - - nL :: M1 i c1 f1 a - nL = undefined - - nR :: M1 i c2 f2 a - nR = undefined - - keyL = constructorModifier (Data.Text.pack (conName nL)) - keyR = constructorModifier (Data.Text.pack (conName nR)) - - Encoder embedL declaredL = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 - Encoder embedR declaredR = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 - -instance (Constructor c, GenericToDhall (f :+: g), GenericToDhall h) => GenericToDhall ((f :+: g) :+: M1 C c h) where - genericToDhallWithNormalizer inputNormalizer options@(InterpretOptions {..}) = pure (Encoder {..}) - where - embed (L1 l) = - case maybeValL of - Nothing -> Field declared $ Core.makeFieldSelection keyL - Just valL -> App (Field declared $ Core.makeFieldSelection keyL) valL - where - (keyL, maybeValL) = - unsafeExpectUnionLit "genericToDhallWithNormalizer (:+:)" (embedL l) - embed (R1 (M1 r)) = - case notEmptyRecordLit (embedR r) of - Nothing -> Field declared $ Core.makeFieldSelection keyR - Just valR -> App (Field declared $ Core.makeFieldSelection keyR) valR - - nR :: M1 i c h a - nR = undefined - - keyR = constructorModifier (Data.Text.pack (conName nR)) - - declared = Union (Dhall.Map.insert keyR (notEmptyRecord declaredR) ktsL) - - Encoder embedL declaredL = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 - Encoder embedR declaredR = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 - - ktsL = unsafeExpectUnion "genericToDhallWithNormalizer (:+:)" declaredL - -instance (Constructor c, GenericToDhall f, GenericToDhall (g :+: h)) => GenericToDhall (M1 C c f :+: (g :+: h)) where - genericToDhallWithNormalizer inputNormalizer options@(InterpretOptions {..}) = pure (Encoder {..}) - where - embed (L1 (M1 l)) = - case notEmptyRecordLit (embedL l) of - Nothing -> Field declared $ Core.makeFieldSelection keyL - Just valL -> App (Field declared $ Core.makeFieldSelection keyL) valL - embed (R1 r) = - case maybeValR of - Nothing -> Field declared $ Core.makeFieldSelection keyR - Just valR -> App (Field declared $ Core.makeFieldSelection keyR) valR - where - (keyR, maybeValR) = - unsafeExpectUnionLit "genericToDhallWithNormalizer (:+:)" (embedR r) - - nL :: M1 i c f a - nL = undefined - - keyL = constructorModifier (Data.Text.pack (conName nL)) - - declared = Union (Dhall.Map.insert keyL (notEmptyRecord declaredL) ktsR) - - Encoder embedL declaredL = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 - Encoder embedR declaredR = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 - - ktsR = unsafeExpectUnion "genericToDhallWithNormalizer (:+:)" declaredR - -instance (GenericToDhall (f :+: g), GenericToDhall (h :+: i)) => GenericToDhall ((f :+: g) :+: (h :+: i)) where - genericToDhallWithNormalizer inputNormalizer options = pure (Encoder {..}) - where - embed (L1 l) = - case maybeValL of - Nothing -> Field declared $ Core.makeFieldSelection keyL - Just valL -> App (Field declared $ Core.makeFieldSelection keyL) valL - where - (keyL, maybeValL) = - unsafeExpectUnionLit "genericToDhallWithNormalizer (:+:)" (embedL l) - embed (R1 r) = - case maybeValR of - Nothing -> Field declared $ Core.makeFieldSelection keyR - Just valR -> App (Field declared $ Core.makeFieldSelection keyR) valR - where - (keyR, maybeValR) = - unsafeExpectUnionLit "genericToDhallWithNormalizer (:+:)" (embedR r) - - declared = Union (Dhall.Map.union ktsL ktsR) - - Encoder embedL declaredL = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 - Encoder embedR declaredR = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 - - ktsL = unsafeExpectUnion "genericToDhallWithNormalizer (:+:)" declaredL - ktsR = unsafeExpectUnion "genericToDhallWithNormalizer (:+:)" declaredR - -instance (GenericToDhall (f :*: g), GenericToDhall (h :*: i)) => GenericToDhall ((f :*: g) :*: (h :*: i)) where - genericToDhallWithNormalizer inputNormalizer options = do - Encoder embedL declaredL <- genericToDhallWithNormalizer inputNormalizer options - Encoder embedR declaredR <- genericToDhallWithNormalizer inputNormalizer options - - let embed (l :*: r) = - RecordLit (Dhall.Map.union mapL mapR) - where - mapL = - unsafeExpectRecordLit "genericToDhallWithNormalizer (:*:)" (embedL l) - - mapR = - unsafeExpectRecordLit "genericToDhallWithNormalizer (:*:)" (embedR r) - - let declared = Record (Dhall.Map.union mapL mapR) - where - mapL = unsafeExpectRecord "genericToDhallWithNormalizer (:*:)" declaredL - mapR = unsafeExpectRecord "genericToDhallWithNormalizer (:*:)" declaredR - - pure (Encoder {..}) - -instance (GenericToDhall (f :*: g), Selector s, ToDhall a) => GenericToDhall ((f :*: g) :*: M1 S s (K1 i a)) where - genericToDhallWithNormalizer inputNormalizer options@InterpretOptions{..} = do - let nR :: M1 S s (K1 i a) r - nR = undefined - - nameR <- fmap fieldModifier (getSelName nR) - - Encoder embedL declaredL <- genericToDhallWithNormalizer inputNormalizer options - - let Encoder embedR declaredR = injectWith inputNormalizer - - let embed (l :*: M1 (K1 r)) = - RecordLit (Dhall.Map.insert nameR (Core.makeRecordField $ embedR r) mapL) - where - mapL = - unsafeExpectRecordLit "genericToDhallWithNormalizer (:*:)" (embedL l) - - let declared = Record (Dhall.Map.insert nameR (Core.makeRecordField declaredR) mapL) - where - mapL = unsafeExpectRecord "genericToDhallWithNormalizer (:*:)" declaredL - - return (Encoder {..}) - -instance (Selector s, ToDhall a, GenericToDhall (f :*: g)) => GenericToDhall (M1 S s (K1 i a) :*: (f :*: g)) where - genericToDhallWithNormalizer inputNormalizer options@InterpretOptions{..} = do - let nL :: M1 S s (K1 i a) r - nL = undefined - - nameL <- fmap fieldModifier (getSelName nL) - - let Encoder embedL declaredL = injectWith inputNormalizer - - Encoder embedR declaredR <- genericToDhallWithNormalizer inputNormalizer options - - let embed (M1 (K1 l) :*: r) = - RecordLit (Dhall.Map.insert nameL (Core.makeRecordField $ embedL l) mapR) - where - mapR = - unsafeExpectRecordLit "genericToDhallWithNormalizer (:*:)" (embedR r) - - let declared = Record (Dhall.Map.insert nameL (Core.makeRecordField declaredL) mapR) - where - mapR = unsafeExpectRecord "genericToDhallWithNormalizer (:*:)" declaredR - - return (Encoder {..}) - -instance (Selector s1, Selector s2, ToDhall a1, ToDhall a2) => GenericToDhall (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where - genericToDhallWithNormalizer inputNormalizer InterpretOptions{..} = do - let nL :: M1 S s1 (K1 i1 a1) r - nL = undefined - - let nR :: M1 S s2 (K1 i2 a2) r - nR = undefined - - nameL <- fmap fieldModifier (getSelName nL) - nameR <- fmap fieldModifier (getSelName nR) - - let Encoder embedL declaredL = injectWith inputNormalizer - let Encoder embedR declaredR = injectWith inputNormalizer - - let embed (M1 (K1 l) :*: M1 (K1 r)) = - RecordLit $ - Dhall.Map.fromList - [ (nameL, Core.makeRecordField $ embedL l) - , (nameR, Core.makeRecordField $ embedR r) ] - - - let declared = - Record $ Dhall.Map.fromList - [ (nameL, Core.makeRecordField declaredL) - , (nameR, Core.makeRecordField declaredR) ] - - - return (Encoder {..}) - -instance GenericToDhall U1 where - genericToDhallWithNormalizer _ _ = pure (Encoder {..}) - where - embed _ = RecordLit mempty - - declared = Record mempty - -{-| The 'RecordDecoder' applicative functor allows you to build a 'Decoder' - from a Dhall record. - - For example, let's take the following Haskell data type: - ->>> :{ -data Project = Project - { projectName :: Text - , projectDescription :: Text - , projectStars :: Natural - } -:} - - And assume that we have the following Dhall record that we would like to - parse as a @Project@: - -> { name = -> "dhall-haskell" -> , description = -> "A configuration language guaranteed to terminate" -> , stars = -> 289 -> } - - Our decoder has type 'Decoder' @Project@, but we can't build that out of any - smaller decoders, as 'Decoder's cannot be combined (they are only 'Functor's). - However, we can use a 'RecordDecoder' to build a 'Decoder' for @Project@: - ->>> :{ -project :: Decoder Project -project = - record - ( Project <$> field "name" strictText - <*> field "description" strictText - <*> field "stars" natural - ) -:} --} - -newtype RecordDecoder a = - RecordDecoder - ( Data.Functor.Product.Product - ( Control.Applicative.Const - (Dhall.Map.Map Text (Expector (Expr Src Void))) - ) - ( Data.Functor.Compose.Compose ((->) (Expr Src Void)) (Extractor Src Void) - ) - a - ) - deriving (Functor, Applicative) - - --- | Run a 'RecordDecoder' to build a 'Decoder'. -record :: RecordDecoder a -> Dhall.Decoder a -record - (RecordDecoder - (Data.Functor.Product.Pair - (Control.Applicative.Const fields) - (Data.Functor.Compose.Compose extract) - ) - ) = Decoder {..} - where - expected = Record <$> traverse (fmap Core.makeRecordField) fields - - --- | Parse a single field of a record. -field :: Text -> Decoder a -> RecordDecoder a -field key (Decoder {..}) = - RecordDecoder - ( Data.Functor.Product.Pair - ( Control.Applicative.Const - (Dhall.Map.singleton key expected) - ) - ( Data.Functor.Compose.Compose extractBody ) - ) - where - extractBody expr@(RecordLit fields) = case Core.recordFieldValue <$> Dhall.Map.lookup key fields of - Just v -> extract v - _ -> typeError expected expr - extractBody expr = typeError expected expr - -{-| The 'UnionDecoder' monoid allows you to build a 'Decoder' from a Dhall union - - For example, let's take the following Haskell data type: - ->>> :{ -data Status = Queued Natural - | Result Text - | Errored Text -:} - - And assume that we have the following Dhall union that we would like to - parse as a @Status@: - -> < Result : Text -> | Queued : Natural -> | Errored : Text -> >.Result "Finish successfully" - - Our decoder has type 'Decoder' @Status@, but we can't build that out of any - smaller decoders, as 'Decoder's cannot be combined (they are only 'Functor's). - However, we can use a 'UnionDecoder' to build a 'Decoder' for @Status@: - ->>> :{ -status :: Decoder Status -status = union - ( ( Queued <$> constructor "Queued" natural ) - <> ( Result <$> constructor "Result" strictText ) - <> ( Errored <$> constructor "Errored" strictText ) - ) -:} - --} -newtype UnionDecoder a = - UnionDecoder - ( Data.Functor.Compose.Compose (Dhall.Map.Map Text) Decoder a ) - deriving (Functor) - -instance Semigroup (UnionDecoder a) where - (<>) = coerce ((<>) :: Dhall.Map.Map Text (Decoder a) -> Dhall.Map.Map Text (Decoder a) -> Dhall.Map.Map Text (Decoder a)) - -instance Monoid (UnionDecoder a) where - mempty = coerce (mempty :: Dhall.Map.Map Text (Decoder a)) - --- | Run a 'UnionDecoder' to build a 'Decoder'. -union :: UnionDecoder a -> Decoder a -union (UnionDecoder (Data.Functor.Compose.Compose mp)) = Decoder {..} - where - extract expr = case expected' of - Failure e -> Failure $ fmap ExpectedTypeError e - Success x -> extract' expr x - - extract' e0 mp' = Data.Maybe.maybe (typeError expected e0) (uncurry Dhall.extract) $ do - (fld, e1, rest) <- extractUnionConstructor e0 - - t <- Dhall.Map.lookup fld mp - - guard $ - Core.Union rest `Core.judgmentallyEqual` Core.Union (Dhall.Map.delete fld mp') - - pure (t, e1) - - expected = Union <$> expected' - - expected' = traverse (fmap notEmptyRecord . Dhall.expected) mp - --- | Parse a single constructor of a union -constructor :: Text -> Decoder a -> UnionDecoder a -constructor key valueDecoder = UnionDecoder - ( Data.Functor.Compose.Compose (Dhall.Map.singleton key valueDecoder) ) - --- | Infix 'divided' -(>*<) :: Divisible f => f a -> f b -> f (a, b) -(>*<) = divided - -infixr 5 >*< - -{-| The 'RecordEncoder' divisible (contravariant) functor allows you to build - an 'Encoder' for a Dhall record. - - For example, let's take the following Haskell data type: - ->>> :{ -data Project = Project - { projectName :: Text - , projectDescription :: Text - , projectStars :: Natural - } -:} - - And assume that we have the following Dhall record that we would like to - parse as a @Project@: - -> { name = -> "dhall-haskell" -> , description = -> "A configuration language guaranteed to terminate" -> , stars = -> 289 -> } - - Our encoder has type 'Encoder' @Project@, but we can't build that out of any - smaller encoders, as 'Encoder's cannot be combined (they are only 'Contravariant's). - However, we can use an 'RecordEncoder' to build an 'Encoder' for @Project@: - ->>> :{ -injectProject :: Encoder Project -injectProject = - recordEncoder - ( adapt >$< encodeFieldWith "name" inject - >*< encodeFieldWith "description" inject - >*< encodeFieldWith "stars" inject - ) - where - adapt (Project{..}) = (projectName, (projectDescription, projectStars)) -:} - - Or, since we are simply using the `ToDhall` instance to inject each field, we could write - ->>> :{ -injectProject :: Encoder Project -injectProject = - recordEncoder - ( adapt >$< encodeField "name" - >*< encodeField "description" - >*< encodeField "stars" - ) - where - adapt (Project{..}) = (projectName, (projectDescription, projectStars)) -:} - --} - -newtype RecordEncoder a - = RecordEncoder (Dhall.Map.Map Text (Encoder a)) - -instance Contravariant RecordEncoder where - contramap f (RecordEncoder encodeTypeRecord) = RecordEncoder $ contramap f <$> encodeTypeRecord - -instance Divisible RecordEncoder where - divide f (RecordEncoder bEncoderRecord) (RecordEncoder cEncoderRecord) = - RecordEncoder - $ Dhall.Map.union - ((contramap $ fst . f) <$> bEncoderRecord) - ((contramap $ snd . f) <$> cEncoderRecord) - conquer = RecordEncoder mempty - -{-| Specify how to encode one field of a record by supplying an explicit - `Encoder` for that field --} -encodeFieldWith :: Text -> Encoder a -> RecordEncoder a -encodeFieldWith name encodeType = RecordEncoder $ Dhall.Map.singleton name encodeType - -{-| Specify how to encode one field of a record using the default `ToDhall` - instance for that type --} -encodeField :: ToDhall a => Text -> RecordEncoder a -encodeField name = encodeFieldWith name inject - --- | Convert a `RecordEncoder` into the equivalent `Encoder` -recordEncoder :: RecordEncoder a -> Encoder a -recordEncoder (RecordEncoder encodeTypeRecord) = Encoder makeRecordLit recordType - where - recordType = Record $ (Core.makeRecordField . declared) <$> encodeTypeRecord - makeRecordLit x = RecordLit $ (Core.makeRecordField . ($ x) . embed) <$> encodeTypeRecord - -{-| 'UnionEncoder' allows you to build an 'Encoder' for a Dhall record. - - For example, let's take the following Haskell data type: - ->>> :{ -data Status = Queued Natural - | Result Text - | Errored Text -:} - - And assume that we have the following Dhall union that we would like to - parse as a @Status@: - -> < Result : Text -> | Queued : Natural -> | Errored : Text -> >.Result "Finish successfully" - - Our encoder has type 'Encoder' @Status@, but we can't build that out of any - smaller encoders, as 'Encoder's cannot be combined. - However, we can use an 'UnionEncoder' to build an 'Encoder' for @Status@: - ->>> :{ -injectStatus :: Encoder Status -injectStatus = adapt >$< unionEncoder - ( encodeConstructorWith "Queued" inject - >|< encodeConstructorWith "Result" inject - >|< encodeConstructorWith "Errored" inject - ) - where - adapt (Queued n) = Left n - adapt (Result t) = Right (Left t) - adapt (Errored e) = Right (Right e) -:} - - Or, since we are simply using the `ToDhall` instance to inject each branch, we could write - ->>> :{ -injectStatus :: Encoder Status -injectStatus = adapt >$< unionEncoder - ( encodeConstructor "Queued" - >|< encodeConstructor "Result" - >|< encodeConstructor "Errored" - ) - where - adapt (Queued n) = Left n - adapt (Result t) = Right (Left t) - adapt (Errored e) = Right (Right e) -:} - --} -newtype UnionEncoder a = - UnionEncoder - ( Data.Functor.Product.Product - ( Control.Applicative.Const - ( Dhall.Map.Map - Text - ( Expr Src Void ) - ) - ) - ( Op (Text, Expr Src Void) ) - a - ) - deriving (Contravariant) - --- | Combines two 'UnionEncoder' values. See 'UnionEncoder' for usage --- notes. --- --- Ideally, this matches 'Data.Functor.Contravariant.Divisible.chosen'; --- however, this allows 'UnionEncoder' to not need a 'Divisible' instance --- itself (since no instance is possible). -(>|<) :: UnionEncoder a -> UnionEncoder b -> UnionEncoder (Either a b) -UnionEncoder (Data.Functor.Product.Pair (Control.Applicative.Const mx) (Op fx)) - >|< UnionEncoder (Data.Functor.Product.Pair (Control.Applicative.Const my) (Op fy)) = - UnionEncoder - ( Data.Functor.Product.Pair - ( Control.Applicative.Const (mx <> my) ) - ( Op (either fx fy) ) - ) - -infixr 5 >|< - --- | Convert a `UnionEncoder` into the equivalent `Encoder` -unionEncoder :: UnionEncoder a -> Encoder a -unionEncoder ( UnionEncoder ( Data.Functor.Product.Pair ( Control.Applicative.Const fields ) ( Op embedF ) ) ) = - Encoder - { embed = \x -> - let (name, y) = embedF x - in case notEmptyRecordLit y of - Nothing -> Field (Union fields') $ Core.makeFieldSelection name - Just val -> App (Field (Union fields') $ Core.makeFieldSelection name) val - , declared = - Union fields' - } - where - fields' = fmap notEmptyRecord fields - -{-| Specify how to encode an alternative by providing an explicit `Encoder` - for that alternative --} -encodeConstructorWith - :: Text - -> Encoder a - -> UnionEncoder a -encodeConstructorWith name encodeType = UnionEncoder $ - Data.Functor.Product.Pair - ( Control.Applicative.Const - ( Dhall.Map.singleton - name - ( declared encodeType ) - ) - ) - ( Op ( (name,) . embed encodeType ) - ) - -{-| Specify how to encode an alternative by using the default `ToDhall` instance - for that type --} -encodeConstructor - :: ToDhall a - => Text - -> UnionEncoder a -encodeConstructor name = encodeConstructorWith name inject + , module Dhall.Marshal.Decode + + -- * Encoders + , module Dhall.Marshal.Encode + + -- * Miscellaneous + , rawInput + ) where + +import Control.Applicative (Alternative, empty) +import Data.Either.Validation (Validation (..)) +import Data.Void (Void) +import Dhall.Import (Imported (..)) +import Dhall.Parser (Src (..)) +import Dhall.Syntax (Expr (..)) +import Dhall.TypeCheck (DetailedTypeError (..), TypeError) +import GHC.Generics +import Lens.Family (LensLike', view) +import Prelude hiding (maybe, sequence) +import System.FilePath (takeDirectory) + +import qualified Control.Exception +import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.Text.IO +import qualified Dhall.Context +import qualified Dhall.Core as Core +import qualified Dhall.Import +import qualified Dhall.Parser +import qualified Dhall.Pretty.Internal +import qualified Dhall.Substitution +import qualified Dhall.TypeCheck +import qualified Lens.Family + +import Dhall.Marshal.Decode +import Dhall.Marshal.Encode + +-- | @since 1.16 +data InputSettings = InputSettings + { _rootDirectory :: FilePath + , _sourceName :: FilePath + , _evaluateSettings :: EvaluateSettings + } + +-- | Default input settings: resolves imports relative to @.@ (the +-- current working directory), report errors as coming from @(input)@, +-- and default evaluation settings from 'defaultEvaluateSettings'. +-- +-- @since 1.16 +defaultInputSettings :: InputSettings +defaultInputSettings = InputSettings + { _rootDirectory = "." + , _sourceName = "(input)" + , _evaluateSettings = defaultEvaluateSettings + } + + +-- | Access the directory to resolve imports relative to. +-- +-- @since 1.16 +rootDirectory + :: (Functor f) + => LensLike' f InputSettings FilePath +rootDirectory k s = + fmap (\x -> s { _rootDirectory = x }) (k (_rootDirectory s)) + +-- | Access the name of the source to report locations from; this is +-- only used in error messages, so it's okay if this is a best guess +-- or something symbolic. +-- +-- @since 1.16 +sourceName + :: (Functor f) + => LensLike' f InputSettings FilePath +sourceName k s = + fmap (\x -> s { _sourceName = x}) (k (_sourceName s)) + +-- | @since 1.16 +data EvaluateSettings = EvaluateSettings + { _substitutions :: Dhall.Substitution.Substitutions Src Void + , _startingContext :: Dhall.Context.Context (Expr Src Void) + , _normalizer :: Maybe (Core.ReifiedNormalizer Void) + , _newManager :: IO Dhall.Import.Manager + } + +-- | Default evaluation settings: no extra entries in the initial +-- context, and no special normalizer behaviour. +-- +-- @since 1.16 +defaultEvaluateSettings :: EvaluateSettings +defaultEvaluateSettings = EvaluateSettings + { _substitutions = Dhall.Substitution.empty + , _startingContext = Dhall.Context.empty + , _normalizer = Nothing + , _newManager = Dhall.Import.defaultNewManager + } + +-- | Access the starting context used for evaluation and type-checking. +-- +-- @since 1.16 +startingContext + :: (Functor f, HasEvaluateSettings s) + => LensLike' f s (Dhall.Context.Context (Expr Src Void)) +startingContext = evaluateSettings . l + where + l :: (Functor f) + => LensLike' f EvaluateSettings (Dhall.Context.Context (Expr Src Void)) + l k s = fmap (\x -> s { _startingContext = x}) (k (_startingContext s)) + +-- | Access the custom substitutions. +-- +-- @since 1.30 +substitutions + :: (Functor f, HasEvaluateSettings s) + => LensLike' f s (Dhall.Substitution.Substitutions Src Void) +substitutions = evaluateSettings . l + where + l :: (Functor f) + => LensLike' f EvaluateSettings (Dhall.Substitution.Substitutions Src Void) + l k s = fmap (\x -> s { _substitutions = x }) (k (_substitutions s)) + +-- | Access the custom normalizer. +-- +-- @since 1.16 +normalizer + :: (Functor f, HasEvaluateSettings s) + => LensLike' f s (Maybe (Core.ReifiedNormalizer Void)) +normalizer = evaluateSettings . l + where + l :: (Functor f) + => LensLike' f EvaluateSettings (Maybe (Core.ReifiedNormalizer Void)) + l k s = fmap (\x -> s { _normalizer = x }) (k (_normalizer s)) + +-- | Access the HTTP manager initializer. +-- +-- @since 1.36 +newManager + :: (Functor f, HasEvaluateSettings s) + => LensLike' f s (IO Dhall.Import.Manager) +newManager = evaluateSettings . l + where + l :: (Functor f) + => LensLike' f EvaluateSettings (IO Dhall.Import.Manager) + l k s = fmap (\x -> s { _newManager = x }) (k (_newManager s)) + +-- | @since 1.16 +class HasEvaluateSettings s where + evaluateSettings + :: (Functor f) + => LensLike' f s EvaluateSettings + +instance HasEvaluateSettings InputSettings where + evaluateSettings k s = + fmap (\x -> s { _evaluateSettings = x }) (k (_evaluateSettings s)) + +instance HasEvaluateSettings EvaluateSettings where + evaluateSettings = id + +{-| Type-check and evaluate a Dhall program, decoding the result into Haskell + + The first argument determines the type of value that you decode: + +>>> input integer "+2" +2 +>>> input (vector double) "[1.0, 2.0]" +[1.0,2.0] + + Use `auto` to automatically select which type to decode based on the + inferred return type: + +>>> input auto "True" :: IO Bool +True + + This uses the settings from 'defaultInputSettings'. +-} +input + :: Decoder a + -- ^ The decoder for the Dhall value + -> Text + -- ^ The Dhall program + -> IO a + -- ^ The decoded value in Haskell +input = + inputWithSettings defaultInputSettings + +{-| Extend 'input' with a root directory to resolve imports relative + to, a file to mention in errors as the source, a custom typing + context, and a custom normalization process. + +@since 1.16 +-} +inputWithSettings + :: InputSettings + -> Decoder a + -- ^ The decoder for the Dhall value + -> Text + -- ^ The Dhall program + -> IO a + -- ^ The decoded value in Haskell +inputWithSettings settings (Decoder {..}) txt = do + expected' <- case expected of + Success x -> return x + Failure e -> Control.Exception.throwIO e + + let suffix = Dhall.Pretty.Internal.prettyToStrictText expected' + let annotate substituted = case substituted of + Note (Src begin end bytes) _ -> + Note (Src begin end bytes') (Annot substituted expected') + where + bytes' = bytes <> " : " <> suffix + _ -> + Annot substituted expected' + + normExpr <- inputHelper annotate settings txt + + case extract normExpr of + Success x -> return x + Failure e -> Control.Exception.throwIO e + +{-| Type-check and evaluate a Dhall program that is read from the + file-system. + + This uses the settings from 'defaultEvaluateSettings'. + + @since 1.16 +-} +inputFile + :: Decoder a + -- ^ The decoder for the Dhall value + -> FilePath + -- ^ The path to the Dhall program. + -> IO a + -- ^ The decoded value in Haskell. +inputFile = + inputFileWithSettings defaultEvaluateSettings + +{-| Extend 'inputFile' with a custom typing context and a custom + normalization process. + +@since 1.16 +-} +inputFileWithSettings + :: EvaluateSettings + -> Decoder a + -- ^ The decoder for the Dhall value + -> FilePath + -- ^ The path to the Dhall program. + -> IO a + -- ^ The decoded value in Haskell. +inputFileWithSettings settings ty path = do + text <- Data.Text.IO.readFile path + let inputSettings = InputSettings + { _rootDirectory = takeDirectory path + , _sourceName = path + , _evaluateSettings = settings + } + inputWithSettings inputSettings ty text + +{-| Similar to `input`, but without interpreting the Dhall `Expr` into a Haskell + type. + + Uses the settings from 'defaultInputSettings'. +-} +inputExpr + :: Text + -- ^ The Dhall program + -> IO (Expr Src Void) + -- ^ The fully normalized AST +inputExpr = + inputExprWithSettings defaultInputSettings + +{-| Extend 'inputExpr' with a root directory to resolve imports relative + to, a file to mention in errors as the source, a custom typing + context, and a custom normalization process. + +@since 1.16 +-} +inputExprWithSettings + :: InputSettings + -> Text + -- ^ The Dhall program + -> IO (Expr Src Void) + -- ^ The fully normalized AST +inputExprWithSettings = inputHelper id + +{-| Helper function for the input* function family + +@since 1.30 +-} +inputHelper + :: (Expr Src Void -> Expr Src Void) + -> InputSettings + -> Text + -- ^ The Dhall program + -> IO (Expr Src Void) + -- ^ The fully normalized AST +inputHelper annotate settings txt = do + expr <- Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt) + + let InputSettings {..} = settings + + let EvaluateSettings {..} = _evaluateSettings + + let transform = + Lens.Family.set Dhall.Import.substitutions _substitutions + . Lens.Family.set Dhall.Import.normalizer _normalizer + . Lens.Family.set Dhall.Import.startingContext _startingContext + + let status = transform (Dhall.Import.emptyStatusWithManager _newManager _rootDirectory) + + expr' <- State.evalStateT (Dhall.Import.loadWith expr) status + + let substituted = Dhall.Substitution.substitute expr' $ view substitutions settings + let annot = annotate substituted + _ <- Core.throws (Dhall.TypeCheck.typeWith (view startingContext settings) annot) + pure (Core.normalizeWith (view normalizer settings) substituted) + +-- | Use this function to extract Haskell values directly from Dhall AST. +-- The intended use case is to allow easy extraction of Dhall values for +-- making the function `Core.normalizeWith` easier to use. +-- +-- For other use cases, use `input` from "Dhall" module. It will give you +-- a much better user experience. +rawInput + :: Alternative f + => Decoder a + -- ^ The decoder for the Dhall value + -> Expr s Void + -- ^ a closed form Dhall program, which evaluates to the expected type + -> f a + -- ^ The decoded value in Haskell +rawInput (Decoder {..}) expr = + case extract (Core.normalize expr) of + Success x -> pure x + Failure _e -> empty + +{-| Use this to provide more detailed error messages + +>> input auto "True" :: IO Integer +> *** Exception: Error: Expression doesn't match annotation +> +> True : Integer +> +> (input):1:1 + +>> detailed (input auto "True") :: IO Integer +> *** Exception: Error: Expression doesn't match annotation +> +> Explanation: You can annotate an expression with its type or kind using the +> ❰:❱ symbol, like this: +> +> +> ┌───────┐ +> │ x : t │ ❰x❱ is an expression and ❰t❱ is the annotated type or kind of ❰x❱ +> └───────┘ +> +> The type checker verifies that the expression's type or kind matches the +> provided annotation +> +> For example, all of the following are valid annotations that the type checker +> accepts: +> +> +> ┌─────────────┐ +> │ 1 : Natural │ ❰1❱ is an expression that has type ❰Natural❱, so the type +> └─────────────┘ checker accepts the annotation +> +> +> ┌───────────────────────┐ +> │ Natural/even 2 : Bool │ ❰Natural/even 2❱ has type ❰Bool❱, so the type +> └───────────────────────┘ checker accepts the annotation +> +> +> ┌────────────────────┐ +> │ List : Type → Type │ ❰List❱ is an expression that has kind ❰Type → Type❱, +> └────────────────────┘ so the type checker accepts the annotation +> +> +> ┌──────────────────┐ +> │ List Text : Type │ ❰List Text❱ is an expression that has kind ❰Type❱, so +> └──────────────────┘ the type checker accepts the annotation +> +> +> However, the following annotations are not valid and the type checker will +> reject them: +> +> +> ┌──────────┐ +> │ 1 : Text │ The type checker rejects this because ❰1❱ does not have type +> └──────────┘ ❰Text❱ +> +> +> ┌─────────────┐ +> │ List : Type │ ❰List❱ does not have kind ❰Type❱ +> └─────────────┘ +> +> +> You or the interpreter annotated this expression: +> +> ↳ True +> +> ... with this type or kind: +> +> ↳ Integer +> +> ... but the inferred type or kind of the expression is actually: +> +> ↳ Bool +> +> Some common reasons why you might get this error: +> +> ● The Haskell Dhall interpreter implicitly inserts a top-level annotation +> matching the expected type +> +> For example, if you run the following Haskell code: +> +> +> ┌───────────────────────────────┐ +> │ >>> input auto "1" :: IO Text │ +> └───────────────────────────────┘ +> +> +> ... then the interpreter will actually type check the following annotated +> expression: +> +> +> ┌──────────┐ +> │ 1 : Text │ +> └──────────┘ +> +> +> ... and then type-checking will fail +> +> ──────────────────────────────────────────────────────────────────────────────── +> +> True : Integer +> +> (input):1:1 + +-} +detailed :: IO a -> IO a +detailed = + Control.Exception.handle handler1 . Control.Exception.handle handler0 + where + handler0 :: Imported (TypeError Src Void) -> IO a + handler0 (Imported ps e) = + Control.Exception.throwIO (Imported ps (DetailedTypeError e)) + + handler1 :: TypeError Src Void -> IO a + handler1 e = Control.Exception.throwIO (DetailedTypeError e) diff --git a/src/Dhall/Binary.hs b/src/Dhall/Binary.hs --- a/src/Dhall/Binary.hs +++ b/src/Dhall/Binary.hs @@ -13,15 +13,11 @@ -} module Dhall.Binary - ( -- * Standard versions - StandardVersion(..) - , renderStandardVersion - - -- * Encoding and decoding - , encodeExpression + ( -- * Encoding and decoding + encodeExpression , decodeExpression - -- * Exceptions + -- * Exceptions , DecodingFailure(..) ) where @@ -54,7 +50,6 @@ ) import Data.Foldable (toList) -import Data.Text (Text) import Data.Void (Void, absurd) import GHC.Float (double2Float, float2Double) import Numeric.Half (fromHalf, toHalf) @@ -76,35 +71,6 @@ import qualified Dhall.Syntax as Syntax import qualified Text.Printf as Printf -{-| Supported version strings - - This exists primarily for backwards compatibility for expressions encoded - before Dhall removed version tags from the binary encoding --} -data StandardVersion - = NoVersion - -- ^ No version string - | V_5_0_0 - -- ^ Version "5.0.0" - | V_4_0_0 - -- ^ Version "4.0.0" - | V_3_0_0 - -- ^ Version "3.0.0" - | V_2_0_0 - -- ^ Version "2.0.0" - | V_1_0_0 - -- ^ Version "1.0.0" - deriving (Enum, Bounded) - --- | Render a `StandardVersion` as `Data.Text.Text` -renderStandardVersion :: StandardVersion -> Text -renderStandardVersion NoVersion = "none" -renderStandardVersion V_1_0_0 = "1.0.0" -renderStandardVersion V_2_0_0 = "2.0.0" -renderStandardVersion V_3_0_0 = "3.0.0" -renderStandardVersion V_4_0_0 = "4.0.0" -renderStandardVersion V_5_0_0 = "5.0.0" - {-| Convert a function applied to multiple arguments to the base function and the list of arguments -} @@ -319,7 +285,7 @@ 9 -> return (Prefer mempty PreferFromSource) 10 -> return (CombineTypes mempty) 11 -> return ImportAlt - 12 -> return Equivalent + 12 -> return (Equivalent mempty) 13 -> return RecordCompletion _ -> die ("Unrecognized operator code: " <> show opcode) @@ -792,7 +758,7 @@ ImportAlt l r -> encodeOperator 11 l r - Equivalent l r -> + Equivalent _ l r -> encodeOperator 12 l r RecordCompletion l r -> diff --git a/src/Dhall/Diff.hs b/src/Dhall/Diff.hs --- a/src/Dhall/Diff.hs +++ b/src/Dhall/Diff.hs @@ -992,7 +992,7 @@ diffEquivalentExpression l@(Equivalent {}) r@(Equivalent {}) = enclosed' " " (operator "≡" <> " ") (docs l r) where - docs (Equivalent aL bL) (Equivalent aR bR) = + docs (Equivalent _ aL bL) (Equivalent _ aR bR) = Data.List.NonEmpty.cons (diffApplicationExpression aL aR) (docs bL bR) docs aL aR = pure (diffApplicationExpression aL aR) diff --git a/src/Dhall/Eval.hs b/src/Dhall/Eval.hs --- a/src/Dhall/Eval.hs +++ b/src/Dhall/Eval.hs @@ -134,6 +134,10 @@ -- ^ The original function was a @Natural/subtract 0@. We need to preserve -- this information in case the @Natural/subtract@ ends up not being fully -- saturated, in which case we need to recover the unsaturated built-in + | TextReplaceEmpty + -- ^ The original function was a @Text/replace ""@ + | TextReplaceEmptyArgument (Val a) + -- ^ The original function was a @Text/replace "" replacement@ deriving instance (Show a, Show (Val a -> Val a)) => Show (HLamInfo a) @@ -603,33 +607,43 @@ t -> VTextShow t TextReplace -> VPrim $ \needle -> - VPrim $ \replacement -> - VPrim $ \haystack -> - case needle of + let hLamInfo0 = case needle of + VTextLit (VChunks [] "") -> TextReplaceEmpty + _ -> Prim + + in VHLam hLamInfo0 $ \replacement -> + let hLamInfo1 = case needle of VTextLit (VChunks [] "") -> - haystack - VTextLit (VChunks [] needleText) -> - case haystack of - VTextLit (VChunks [] haystackText) -> - case replacement of - VTextLit (VChunks [] replacementText) -> - VTextLit $ VChunks [] - (Text.replace - needleText - replacementText - haystackText - ) - _ -> - VTextLit - (vTextReplace - needleText - replacement - haystackText - ) - _ -> - VTextReplace needle replacement haystack + TextReplaceEmptyArgument replacement _ -> - VTextReplace needle replacement haystack + Prim + in VHLam hLamInfo1 $ \haystack -> + case needle of + VTextLit (VChunks [] "") -> + haystack + + VTextLit (VChunks [] needleText) -> + case haystack of + VTextLit (VChunks [] haystackText) -> + case replacement of + VTextLit (VChunks [] replacementText) -> + VTextLit $ VChunks [] + (Text.replace + needleText + replacementText + haystackText + ) + _ -> + VTextLit + (vTextReplace + needleText + replacement + haystackText + ) + _ -> + VTextReplace needle replacement haystack + _ -> + VTextReplace needle replacement haystack List -> VPrim VList ListLit ma ts -> @@ -787,7 +801,7 @@ VProject (eval env t) (Right e') Assert t -> VAssert (eval env t) - Equivalent t u -> + Equivalent _ t u -> VEquivalent (eval env t) (eval env u) With e₀ ks v -> vWith (eval env e₀) ks (eval env v) @@ -1062,12 +1076,18 @@ VHLam i t -> case i of Typed (fresh -> (x, v)) a -> - Lam - mempty + Lam mempty (Syntax.makeFunctionBinding x (quote env a)) (quoteBind x (t v)) - Prim -> quote env (t VPrimVar) - NaturalSubtractZero -> App NaturalSubtract (NaturalLit 0) + Prim -> + quote env (t VPrimVar) + NaturalSubtractZero -> + App NaturalSubtract (NaturalLit 0) + TextReplaceEmpty -> + App TextReplace (TextLit (Chunks [] "")) + TextReplaceEmptyArgument replacement -> + App (App TextReplace (TextLit (Chunks [] ""))) + (quote env replacement) VPi a (freshClosure -> (x, v, b)) -> Pi mempty x (quote env a) (quoteBind x (instantiate b v)) @@ -1188,7 +1208,7 @@ VAssert t -> Assert (quote env t) VEquivalent t u -> - Equivalent (quote env t) (quote env u) + Equivalent mempty (quote env t) (quote env u) VWith e ks v -> With (quote env e) ks (quote env v) VInject m k Nothing -> @@ -1374,8 +1394,8 @@ Project (go t) (fmap go ks) Assert t -> Assert (go t) - Equivalent t u -> - Equivalent (go t) (go u) + Equivalent cs t u -> + Equivalent cs (go t) (go u) With e k v -> With (go e) k (go v) Note s e -> diff --git a/src/Dhall/Format.hs b/src/Dhall/Format.hs --- a/src/Dhall/Format.hs +++ b/src/Dhall/Format.hs @@ -11,19 +11,24 @@ , format ) where -import Data.Foldable (for_) -import Data.Maybe (fromMaybe) -import Dhall.Pretty (CharacterSet, annToAnsiStyle, detectCharacterSet) +import Data.Foldable (for_) +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (fromMaybe) +import Dhall.Pretty + ( CharacterSet + , annToAnsiStyle + , detectCharacterSet + ) import Dhall.Util ( Censor , CheckFailed (..) , Header (..) + , Input (..) , OutputMode (..) - , PossiblyTransitiveInput (..) , Transitivity (..) + , handleMultipleChecksFailed ) -import qualified Control.Exception import qualified Data.Text.IO import qualified Data.Text.Prettyprint.Doc as Pretty import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal @@ -40,19 +45,21 @@ data Format = Format { chosenCharacterSet :: Maybe CharacterSet , censor :: Censor - , input :: PossiblyTransitiveInput + , transitivity :: Transitivity + , inputs :: NonEmpty Input , outputMode :: OutputMode } -- | Implementation of the @dhall format@ subcommand format :: Format -> IO () -format (Format { input = input0, ..}) = go input0 +format (Format { inputs = inputs0, transitivity = transitivity0, ..}) = + handleMultipleChecksFailed "format" "formatted" go inputs0 where go input = do let directory = case input of - NonTransitiveStandardInput -> + StandardInput -> "." - PossiblyTransitiveInputFile file _ -> + InputFile file -> System.FilePath.takeDirectory file let status = Dhall.Import.emptyStatus directory @@ -65,26 +72,26 @@ <> Dhall.Pretty.prettyCharacterSet characterSet expr <> "\n") - (originalText, transitivity) <- case input of - PossiblyTransitiveInputFile file transitivity -> do + (inputName, originalText, transitivity) <- case input of + InputFile file -> do text <- Data.Text.IO.readFile file - return (text, transitivity) - - NonTransitiveStandardInput -> do + return (file, text, transitivity0) + StandardInput -> do text <- Data.Text.IO.getContents - return (text, NonTransitive) + return ("(input)", text, NonTransitive) - headerAndExpr@(_, parsedExpression) <- Dhall.Util.getExpressionAndHeaderFromStdinText censor originalText + headerAndExpr@(_, parsedExpression) <- Dhall.Util.getExpressionAndHeaderFromStdinText censor inputName originalText + case transitivity of Transitive -> for_ parsedExpression $ \import_ -> do maybeFilepath <- Dhall.Import.dependencyToFile status import_ for_ maybeFilepath $ \filepath -> - go (PossiblyTransitiveInputFile filepath Transitive) + go (InputFile filepath) NonTransitive -> return () @@ -94,16 +101,16 @@ let formattedText = Pretty.Text.renderStrict docStream case outputMode of - Write -> + Write -> do case input of - PossiblyTransitiveInputFile file _ -> + InputFile file -> if originalText == formattedText then return () else AtomicWrite.LazyText.atomicWriteFile file (Pretty.Text.renderLazy docStream) - NonTransitiveStandardInput -> do + StandardInput -> do supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout Pretty.Terminal.renderIO @@ -112,12 +119,10 @@ then (fmap annToAnsiStyle docStream) else (Pretty.unAnnotateS docStream)) - Check -> - if originalText == formattedText - then return () - else do - let command = "format" - - let modified = "formatted" + return (Right ()) - Control.Exception.throwIO CheckFailed{..} + Check -> + return $ + if originalText == formattedText + then Right () + else Left CheckFailed{..} diff --git a/src/Dhall/Freeze.hs b/src/Dhall/Freeze.hs --- a/src/Dhall/Freeze.hs +++ b/src/Dhall/Freeze.hs @@ -22,6 +22,7 @@ ) where import Data.Foldable (for_) +import Data.List.NonEmpty (NonEmpty) import Data.Maybe (fromMaybe) import Dhall.Pretty (CharacterSet, detectCharacterSet) import Dhall.Syntax @@ -34,9 +35,10 @@ ( Censor , CheckFailed (..) , Header (..) + , Input (..) , OutputMode (..) - , PossiblyTransitiveInput (..) , Transitivity (..) + , handleMultipleChecksFailed ) import System.Console.ANSI (hSupportsANSI) @@ -140,7 +142,8 @@ -- | Implementation of the @dhall freeze@ subcommand freeze :: OutputMode - -> PossiblyTransitiveInput + -> Transitivity + -> NonEmpty Input -> Scope -> Intent -> Maybe CharacterSet @@ -152,35 +155,37 @@ freezeWithManager :: IO Dhall.Import.Manager -> OutputMode - -> PossiblyTransitiveInput + -> Transitivity + -> NonEmpty Input -> Scope -> Intent -> Maybe CharacterSet -> Censor -> IO () -freezeWithManager newManager outputMode input0 scope intent chosenCharacterSet censor = go input0 +freezeWithManager newManager outputMode transitivity0 inputs scope intent chosenCharacterSet censor = + handleMultipleChecksFailed "freeze" "frozen" go inputs where go input = do let directory = case input of - NonTransitiveStandardInput -> + StandardInput -> "." - PossiblyTransitiveInputFile file _ -> + InputFile file -> System.FilePath.takeDirectory file let status = Dhall.Import.emptyStatusWithManager newManager directory - (originalText, transitivity) <- case input of - PossiblyTransitiveInputFile file transitivity -> do + (inputName, originalText, transitivity) <- case input of + InputFile file -> do text <- Text.IO.readFile file - return (text, transitivity) + return (file, text, transitivity0) - NonTransitiveStandardInput -> do + StandardInput -> do text <- Text.IO.getContents - return (text, NonTransitive) + return ("(input)", text, NonTransitive) - (Header header, parsedExpression) <- Util.getExpressionAndHeaderFromStdinText censor originalText + (Header header, parsedExpression) <- Util.getExpressionAndHeaderFromStdinText censor inputName originalText let characterSet = fromMaybe (detectCharacterSet parsedExpression) chosenCharacterSet @@ -190,7 +195,7 @@ maybeFilepath <- Dhall.Import.dependencyToFile status import_ for_ maybeFilepath $ \filepath -> - go (PossiblyTransitiveInputFile filepath Transitive) + go (InputFile filepath) NonTransitive -> return () @@ -210,7 +215,7 @@ let unAnnotated = Pretty.unAnnotateS stream case input of - PossiblyTransitiveInputFile file _ -> + InputFile file -> if originalText == modifiedText then return () else @@ -218,7 +223,7 @@ file (Pretty.Text.renderLazy unAnnotated) - NonTransitiveStandardInput -> do + StandardInput -> do supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout if supportsANSI then @@ -226,15 +231,13 @@ else Pretty.renderIO System.IO.stdout unAnnotated - Check -> - if originalText == modifiedText - then return () - else do - let command = "freeze" - - let modified = "frozen" + return (Right ()) - Exception.throwIO CheckFailed{..} + Check -> + return $ + if originalText == modifiedText + then Right () + else Left CheckFailed{..} {-| Slightly more pure version of the `freeze` function diff --git a/src/Dhall/Import.hs b/src/Dhall/Import.hs --- a/src/Dhall/Import.hs +++ b/src/Dhall/Import.hs @@ -167,7 +167,6 @@ import Data.Text (Text) import Data.Typeable (Typeable) import Data.Void (Void, absurd) -import Dhall.Binary (StandardVersion (..)) import Dhall.Syntax ( Chunks (..) @@ -200,7 +199,6 @@ ) import Lens.Family.State.Strict (zoom) -import qualified Codec.CBOR.Encoding as Encoding import qualified Codec.CBOR.Write as Write import qualified Codec.Serialise import qualified Control.Monad.State.Strict as State @@ -566,22 +564,27 @@ Nothing -> fetch where fetch = do - ImportSemantics { importSemantics } <- loadImportWithSemisemanticCache import_ + ImportSemantics{ importSemantics } <- loadImportWithSemisemanticCache import_ - let variants = map (\version -> encodeExpression version (Core.alphaNormalize importSemantics)) - [ minBound .. maxBound ] - case Data.Foldable.find ((== semanticHash). Dhall.Crypto.sha256Hash) variants of - Just bytes -> zoom cacheWarning (writeToSemanticCache semanticHash bytes) - Nothing -> do - let expectedHash = semanticHash - Status { _stack } <- State.get - let actualHash = hashExpression (Core.alphaNormalize importSemantics) - throwMissingImport (Imported _stack (HashMismatch {..})) + let bytes = encodeExpression (Core.alphaNormalize importSemantics) - return (ImportSemantics {..}) + let actualHash = Dhall.Crypto.sha256Hash bytes + let expectedHash = semanticHash + if actualHash == expectedHash + then do + zoom cacheWarning (writeToSemanticCache semanticHash bytes) + else do + Status{ _stack } <- State.get + + throwMissingImport (Imported _stack HashMismatch{..}) + + return ImportSemantics{..} + + + -- Fetch encoded normal form from "semantic cache" fetchFromSemanticCache :: (MonadState CacheWarning m, MonadCatch m, MonadIO m) @@ -600,7 +603,8 @@ -- with the old behavior State.evalStateT (writeToSemanticCache hash bytes) CacheWarned where - bytes = encodeExpression NoVersion expression + bytes = encodeExpression expression + hash = Dhall.Crypto.sha256Hash bytes writeToSemanticCache @@ -682,7 +686,7 @@ let betaNormal = Core.normalizeWith _normalizer substitutedExpr - let bytes = encodeExpression NoVersion betaNormal + let bytes = encodeExpression betaNormal zoom cacheWarning (writeToSemisemanticCache semisemanticHash bytes) @@ -1206,33 +1210,19 @@ (loadWith expression) (emptyStatusWithManager newManager rootDirectory) { _semanticCacheMode = semanticCacheMode } -encodeExpression - :: StandardVersion - -- ^ `NoVersion` means to encode without the version tag - -> Expr Void Void - -> Data.ByteString.ByteString -encodeExpression _standardVersion expression = bytesStrict +encodeExpression :: Expr Void Void -> Data.ByteString.ByteString +encodeExpression expression = bytesStrict where intermediateExpression :: Expr Void Import intermediateExpression = fmap absurd expression - encoding = - case _standardVersion of - NoVersion -> - Codec.Serialise.encode intermediateExpression - s -> - Encoding.encodeListLen 2 - <> Encoding.encodeString v - <> Codec.Serialise.encode intermediateExpression - where - v = Dhall.Binary.renderStandardVersion s + encoding = Codec.Serialise.encode intermediateExpression bytesStrict = Write.toStrictByteString encoding -- | Hash a fully resolved expression hashExpression :: Expr Void Void -> Dhall.Crypto.SHA256Digest -hashExpression expression = - Dhall.Crypto.sha256Hash (encodeExpression NoVersion expression) +hashExpression = Dhall.Crypto.sha256Hash . encodeExpression {-| Convenience utility to hash a fully resolved expression and return the base-16 encoded hash with the @sha256:@ prefix diff --git a/src/Dhall/Main.hs b/src/Dhall/Main.hs --- a/src/Dhall/Main.hs +++ b/src/Dhall/Main.hs @@ -23,9 +23,10 @@ import Control.Applicative (optional, (<|>)) import Control.Exception (Handler (..), SomeException) +import Control.Monad (when) import Data.Foldable (for_) import Data.Maybe (fromMaybe) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty) import Data.Void (Void) @@ -65,8 +66,8 @@ , Input (..) , Output (..) , OutputMode (..) - , PossiblyTransitiveInput (..) , Transitivity (..) + , handleMultipleChecksFailed ) import qualified Codec.CBOR.JSON @@ -143,11 +144,11 @@ } | Normalize { file :: Input , alpha :: Bool } | Repl - | Format { possiblyTransitiveInput :: PossiblyTransitiveInput, outputMode :: OutputMode } - | Freeze { possiblyTransitiveInput :: PossiblyTransitiveInput, all_ :: Bool, cache :: Bool, outputMode :: OutputMode } + | Format { deprecatedInPlace :: Bool, transitivity :: Transitivity, outputMode :: OutputMode, inputs :: NonEmpty Input } + | Freeze { deprecatedInPlace :: Bool, transitivity :: Transitivity, all_ :: Bool, cache :: Bool, outputMode :: OutputMode, inputs :: NonEmpty Input } | Hash { file :: Input, cache :: Bool } | Diff { expr1 :: Text, expr2 :: Text } - | Lint { possiblyTransitiveInput :: PossiblyTransitiveInput, outputMode :: OutputMode } + | Lint { deprecatedInPlace :: Bool, transitivity :: Transitivity, outputMode :: OutputMode, inputs :: NonEmpty Input } | Tags { input :: Input , output :: Output @@ -242,17 +243,17 @@ Manipulate "format" "Standard code formatter for the Dhall language" - (Format <$> parseInplaceTransitive <*> parseCheck "formatted") + (Format <$> deprecatedInPlace <*> parseTransitiveSwitch <*> parseCheck "formatted" <*> parseFiles) <|> subcommand Manipulate "freeze" "Add integrity checks to remote import statements of an expression" - (Freeze <$> parseInplaceTransitive <*> parseAllFlag <*> parseCacheFlag <*> parseCheck "frozen") + (Freeze <$> deprecatedInPlace <*> parseTransitiveSwitch <*> parseAllFlag <*> parseCacheFlag <*> parseCheck "frozen" <*> parseFiles) <|> subcommand Manipulate "lint" "Improve Dhall code by using newer language features and removing dead code" - (Lint <$> parseInplaceTransitive <*> parseCheck "linted") + (Lint <$> deprecatedInPlace <*> parseTransitiveSwitch <*> parseCheck "linted" <*> parseFiles) <|> subcommand Manipulate "rewrite-with-schemas" @@ -332,6 +333,12 @@ <*> parseVersion ) where + deprecatedInPlace = + Options.Applicative.switch + ( Options.Applicative.long "inplace" + <> Options.Applicative.internal -- completely hidden from help + ) + argument = fmap Data.Text.pack . Options.Applicative.strArgument @@ -349,6 +356,21 @@ <> Options.Applicative.action "file" ) + parseFiles = fmap f (Options.Applicative.many p) + where + -- Parse explicit stdin in the input filepaths + parseStdin inputs + | any (== InputFile "-") inputs = StandardInput : filter (/= InputFile "-") inputs + | otherwise = inputs + + f = fromMaybe (pure StandardInput) . nonEmpty . parseStdin . fmap InputFile + + p = Options.Applicative.strArgument + ( Options.Applicative.help "Read expression from files instead of standard input" + <> Options.Applicative.metavar "FILES" + <> Options.Applicative.action "file" + ) + parseOutput = fmap f (optional p) where f Nothing = StandardOutput @@ -422,22 +444,15 @@ <> Options.Applicative.action "file" ) + parseTransitiveSwitch = Options.Applicative.flag NonTransitive Transitive + ( Options.Applicative.long "transitive" + <> Options.Applicative.help "Modify the input and its transitive relative imports in-place" + ) + parseInplaceNonTransitive = fmap InputFile parseInplace <|> pure StandardInput - parseInplaceTransitive = - fmap (\f -> PossiblyTransitiveInputFile f NonTransitive) parseInplace - <|> fmap (\f -> PossiblyTransitiveInputFile f Transitive) parseTransitive - <|> pure NonTransitiveStandardInput - where - parseTransitive = Options.Applicative.strOption - ( Options.Applicative.long "transitive" - <> Options.Applicative.help "Modify the specified file and its transitive relative imports in-place" - <> Options.Applicative.metavar "FILE" - <> Options.Applicative.action "file" - ) - parseInput = fmap f (optional p) where f Nothing = StandardInput @@ -787,16 +802,21 @@ then return () else Exit.exitFailure - Format {..} -> - Dhall.Format.format - Dhall.Format.Format{ input = possiblyTransitiveInput, ..} + Format {..} -> do + when deprecatedInPlace $ + System.IO.hPutStrLn System.IO.stderr "Warning: the flag \"--inplace\" is deprecated" + Dhall.Format.format Dhall.Format.Format{..} + Freeze {..} -> do + when deprecatedInPlace $ + System.IO.hPutStrLn System.IO.stderr "Warning: the flag \"--inplace\" is deprecated" + let scope = if all_ then AllImports else OnlyRemoteImports let intent = if cache then Cache else Secure - Dhall.Freeze.freeze outputMode possiblyTransitiveInput scope intent chosenCharacterSet censor + Dhall.Freeze.freeze outputMode transitivity inputs scope intent chosenCharacterSet censor Hash {..} -> do expression <- getExpression file @@ -815,27 +835,31 @@ Data.Text.IO.putStrLn (Dhall.Import.hashExpressionToCode normalizedExpression) - Lint { possiblyTransitiveInput = input0, ..} -> go input0 + Lint { transitivity = transitivity0, ..} -> do + when deprecatedInPlace $ + System.IO.hPutStrLn System.IO.stderr "Warning: the flag \"--inplace\" is deprecated" + + handleMultipleChecksFailed "lint" "linted" go inputs where go input = do let directory = case input of - NonTransitiveStandardInput -> "." - PossiblyTransitiveInputFile file _ -> System.FilePath.takeDirectory file + StandardInput -> "." + InputFile file -> System.FilePath.takeDirectory file let status = Dhall.Import.emptyStatus directory - (originalText, transitivity) <- case input of - PossiblyTransitiveInputFile file transitivity -> do + (inputName, originalText, transitivity) <- case input of + InputFile file -> do text <- Data.Text.IO.readFile file - return (text, transitivity) - NonTransitiveStandardInput -> do + return (file, text, transitivity0) + StandardInput -> do text <- Data.Text.IO.getContents - return (text, NonTransitive) + return ("(input)", text, NonTransitive) (Header header, parsedExpression) <- - Dhall.Util.getExpressionAndHeaderFromStdinText censor originalText + Dhall.Util.getExpressionAndHeaderFromStdinText censor inputName originalText let characterSet = fromMaybe (detectCharacterSet parsedExpression) chosenCharacterSet @@ -845,7 +869,7 @@ maybeFilepath <- Dhall.Import.dependencyToFile status import_ for_ maybeFilepath $ \filepath -> - go (PossiblyTransitiveInputFile filepath Transitive) + go (InputFile filepath) NonTransitive -> return () @@ -860,23 +884,23 @@ let modifiedText = Pretty.Text.renderStrict stream <> "\n" case outputMode of - Write -> + Write -> do case input of - PossiblyTransitiveInputFile file _ -> + InputFile file -> if originalText == modifiedText then return () else writeDocToFile file doc - NonTransitiveStandardInput -> + StandardInput -> renderDoc System.IO.stdout doc - Check -> - if originalText == modifiedText - then return () - else do - let modified = "linted" + return (Right ()) - Control.Exception.throwIO CheckFailed{ command = "lint", ..} + Check -> + return $ + if originalText == modifiedText + then Right () + else Left CheckFailed{..} Encode {..} -> do expression <- getExpression file diff --git a/src/Dhall/Marshal/Decode.hs b/src/Dhall/Marshal/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Marshal/Decode.hs @@ -0,0 +1,1492 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-| Please read the "Dhall.Tutorial" module, which contains a tutorial explaining + how to use the language, the compiler, and this library +-} + +module Dhall.Marshal.Decode + ( -- * General + Decoder (..) + , FromDhall(..) + , Interpret + , auto + + -- * Building decoders + -- ** Simple decoders + , bool + , unit + , void + -- ** Numbers + , natural + , word + , word8 + , word16 + , word32 + , word64 + , integer + , int + , int8 + , int16 + , int32 + , int64 + , scientific + , double + -- ** Textual + , string + , lazyText + , strictText + -- ** Containers + , maybe + , pair + , sequence + , list + , vector + , setFromDistinctList + , setIgnoringDuplicates + , hashSetFromDistinctList + , hashSetIgnoringDuplicates + , Dhall.Marshal.Decode.map + , hashMap + , pairFromMapEntry + -- ** Functions + , function + , functionWith + -- ** Records + , RecordDecoder(..) + , record + , field + -- ** Unions + , UnionDecoder(..) + , union + , constructor + + -- * Generic decoding + , GenericFromDhall(..) + , GenericFromDhallUnion(..) + , genericAuto + , genericAutoWith + + -- * Decoding errors + , DhallErrors(..) + , showDhallErrors + , InvalidDecoder(..) + -- ** Extraction errors + , ExtractErrors + , ExtractError(..) + , Extractor + , typeError + , extractError + , MonadicExtractor + , toMonadic + , fromMonadic + -- ** Typing errors + , ExpectedTypeErrors + , ExpectedTypeError(..) + , Expector + + -- * Miscellaneous + , InputNormalizer(..) + , defaultInputNormalizer + , InterpretOptions(..) + , SingletonConstructors(..) + , defaultInterpretOptions + , Result + + -- * Re-exports + , Natural + , Seq + , Text + , Vector + , Generic + ) where + + +import Control.Applicative (empty, liftA2) +import Control.Exception (Exception) +import Control.Monad (guard) +import Control.Monad.Trans.State.Strict +import Data.Coerce (coerce) +import Data.Either.Validation + ( Validation (..) + , eitherToValidation + , validationToEither + ) +import Data.Hashable (Hashable) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text.Prettyprint.Doc (Pretty) +import Data.Typeable (Proxy (..), Typeable) +import Dhall.Parser (Src (..)) +import Dhall.Syntax + ( Chunks (..) + , DhallDouble (..) + , Expr (..) + , FunctionBinding (..) + , Var (..) + ) +import GHC.Generics +import Prelude hiding (maybe, sequence) + +import qualified Control.Applicative +import qualified Data.Foldable +import qualified Data.Functor.Compose +import qualified Data.Functor.Product +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet +import qualified Data.List as List +import qualified Data.List.NonEmpty +import qualified Data.Map +import qualified Data.Maybe +import qualified Data.Scientific +import qualified Data.Sequence +import qualified Data.Set +import qualified Data.Text +import qualified Data.Text.Lazy +import qualified Data.Vector +import qualified Dhall.Core as Core +import qualified Dhall.Map +import qualified Dhall.Util + +import Dhall.Marshal.Encode +import Dhall.Marshal.Internal + +-- $setup +-- >>> import Dhall (input) + +{-| A @(Decoder a)@ represents a way to marshal a value of type @\'a\'@ from Dhall + into Haskell. + + You can produce `Decoder`s either explicitly: + +> example :: Decoder (Vector Text) +> example = vector text + + ... or implicitly using `auto`: + +> example :: Decoder (Vector Text) +> example = auto + + You can consume `Decoder`s using the `Dhall.input` function: + +> input :: Decoder a -> Text -> IO a +-} +data Decoder a = Decoder + { extract :: Expr Src Void -> Extractor Src Void a + -- ^ Extracts Haskell value from the Dhall expression + , expected :: Expector (Expr Src Void) + -- ^ Dhall type of the Haskell value + } + deriving (Functor) + +{-| Any value that implements `FromDhall` can be automatically decoded based on + the inferred return type of `Dhall.input`. + +>>> input auto "[1, 2, 3]" :: IO (Vector Natural) +[1,2,3] +>>> input auto "toMap { a = False, b = True }" :: IO (Map Text Bool) +fromList [("a",False),("b",True)] + + This class auto-generates a default implementation for types that + implement `Generic`. This does not auto-generate an instance for recursive + types. + + The default instance can be tweaked using 'genericAutoWith' and custom + 'InterpretOptions', or using + [DerivingVia](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-DerivingVia) + and 'Dhall.Deriving.Codec' from "Dhall.Deriving". +-} +class FromDhall a where + autoWith :: InputNormalizer -> Decoder a + default autoWith + :: (Generic a, GenericFromDhall a (Rep a)) => InputNormalizer -> Decoder a + autoWith _ = genericAuto + +-- | A compatibility alias for `FromDhall`. +type Interpret = FromDhall +{-# DEPRECATED Interpret "Use FromDhall instead" #-} + +{-| Use the default input normalizer for interpreting an input. + +> auto = autoWith defaultInputNormalizer +-} +auto :: FromDhall a => Decoder a +auto = autoWith defaultInputNormalizer + + + +instance FromDhall Void where + autoWith _ = void + +instance FromDhall () where + autoWith _ = unit + +instance FromDhall Bool where + autoWith _ = bool + +instance FromDhall Natural where + autoWith _ = natural + +instance FromDhall Word where + autoWith _ = word + +instance FromDhall Word8 where + autoWith _ = word8 + +instance FromDhall Word16 where + autoWith _ = word16 + +instance FromDhall Word32 where + autoWith _ = word32 + +instance FromDhall Word64 where + autoWith _ = word64 + +instance FromDhall Integer where + autoWith _ = integer + +instance FromDhall Int where + autoWith _ = int + +instance FromDhall Int8 where + autoWith _ = int8 + +instance FromDhall Int16 where + autoWith _ = int16 + +instance FromDhall Int32 where + autoWith _ = int32 + +instance FromDhall Int64 where + autoWith _ = int64 + +instance FromDhall Scientific where + autoWith _ = scientific + +instance FromDhall Double where + autoWith _ = double + +instance {-# OVERLAPS #-} FromDhall [Char] where + autoWith _ = string + +instance FromDhall Data.Text.Lazy.Text where + autoWith _ = lazyText + +instance FromDhall Text where + autoWith _ = strictText + +instance FromDhall a => FromDhall (Maybe a) where + autoWith opts = maybe (autoWith opts) + +instance FromDhall a => FromDhall (Seq a) where + autoWith opts = sequence (autoWith opts) + +instance FromDhall a => FromDhall [a] where + autoWith opts = list (autoWith opts) + +instance FromDhall a => FromDhall (Vector a) where + autoWith opts = vector (autoWith opts) + +{-| Note that this instance will throw errors in the presence of duplicates in + the list. To ignore duplicates, use `setIgnoringDuplicates`. +-} +instance (FromDhall a, Ord a, Show a) => FromDhall (Data.Set.Set a) where + autoWith opts = setFromDistinctList (autoWith opts) + +{-| Note that this instance will throw errors in the presence of duplicates in + the list. To ignore duplicates, use `hashSetIgnoringDuplicates`. +-} +instance (FromDhall a, Hashable a, Ord a, Show a) => FromDhall (Data.HashSet.HashSet a) where + autoWith inputNormalizer = hashSetFromDistinctList (autoWith inputNormalizer) + +instance (Ord k, FromDhall k, FromDhall v) => FromDhall (Map k v) where + autoWith inputNormalizer = Dhall.Marshal.Decode.map (autoWith inputNormalizer) (autoWith inputNormalizer) + +instance (Eq k, Hashable k, FromDhall k, FromDhall v) => FromDhall (HashMap k v) where + autoWith inputNormalizer = Dhall.Marshal.Decode.hashMap (autoWith inputNormalizer) (autoWith inputNormalizer) + +instance (ToDhall a, FromDhall b) => FromDhall (a -> b) where + autoWith inputNormalizer = + functionWith inputNormalizer (injectWith inputNormalizer) (autoWith inputNormalizer) + +instance (FromDhall a, FromDhall b) => FromDhall (a, b) + +instance FromDhall (f (Result f)) => FromDhall (Result f) where + autoWith inputNormalizer = Decoder {..} + where + extract (App _ expr) = + fmap Result (Dhall.Marshal.Decode.extract (autoWith inputNormalizer) expr) + extract expr = typeError expected expr + + expected = pure "result" + +-- | You can use this instance to marshal recursive types from Dhall to Haskell. +-- +-- Here is an example use of this instance: +-- +-- > {-# LANGUAGE DeriveAnyClass #-} +-- > {-# LANGUAGE DeriveFoldable #-} +-- > {-# LANGUAGE DeriveFunctor #-} +-- > {-# LANGUAGE DeriveTraversable #-} +-- > {-# LANGUAGE DeriveGeneric #-} +-- > {-# LANGUAGE KindSignatures #-} +-- > {-# LANGUAGE QuasiQuotes #-} +-- > {-# LANGUAGE StandaloneDeriving #-} +-- > {-# LANGUAGE TypeFamilies #-} +-- > {-# LANGUAGE TemplateHaskell #-} +-- > +-- > import Data.Fix (Fix(..)) +-- > import Data.Text (Text) +-- > import Dhall (FromDhall) +-- > import GHC.Generics (Generic) +-- > import Numeric.Natural (Natural) +-- > +-- > import qualified Data.Fix as Fix +-- > import qualified Data.Functor.Foldable as Foldable +-- > import qualified Data.Functor.Foldable.TH as TH +-- > import qualified Dhall +-- > import qualified NeatInterpolation +-- > +-- > data Expr +-- > = Lit Natural +-- > | Add Expr Expr +-- > | Mul Expr Expr +-- > deriving (Show) +-- > +-- > TH.makeBaseFunctor ''Expr +-- > +-- > deriving instance Generic (ExprF a) +-- > deriving instance FromDhall a => FromDhall (ExprF a) +-- > +-- > example :: Text +-- > example = [NeatInterpolation.text| +-- > \(Expr : Type) +-- > -> let ExprF = +-- > < LitF : +-- > Natural +-- > | AddF : +-- > { _1 : Expr, _2 : Expr } +-- > | MulF : +-- > { _1 : Expr, _2 : Expr } +-- > > +-- > +-- > in \(Fix : ExprF -> Expr) +-- > -> let Lit = \(x : Natural) -> Fix (ExprF.LitF x) +-- > +-- > let Add = +-- > \(x : Expr) +-- > -> \(y : Expr) +-- > -> Fix (ExprF.AddF { _1 = x, _2 = y }) +-- > +-- > let Mul = +-- > \(x : Expr) +-- > -> \(y : Expr) +-- > -> Fix (ExprF.MulF { _1 = x, _2 = y }) +-- > +-- > in Add (Mul (Lit 3) (Lit 7)) (Add (Lit 1) (Lit 2)) +-- > |] +-- > +-- > convert :: Fix ExprF -> Expr +-- > convert = Fix.foldFix Foldable.embed +-- > +-- > main :: IO () +-- > main = do +-- > x <- Dhall.input Dhall.auto example :: IO (Fix ExprF) +-- > +-- > print (convert x :: Expr) +instance (Functor f, FromDhall (f (Result f))) => FromDhall (Fix f) where + autoWith inputNormalizer = Decoder {..} + where + extract expr0 = extract0 expr0 + where + die = typeError expected expr0 + + extract0 (Lam _ (FunctionBinding { functionBindingVariable = x }) expr) = + extract1 (rename x "result" expr) + extract0 _ = die + + extract1 (Lam _ (FunctionBinding { functionBindingVariable = y }) expr) = + extract2 (rename y "Make" expr) + extract1 _ = die + + extract2 expr = fmap resultToFix (Dhall.Marshal.Decode.extract (autoWith inputNormalizer) expr) + + rename a b expr + | a /= b = Core.subst (V a 0) (Var (V b 0)) (Core.shift 1 (V b 0) expr) + | otherwise = expr + + expected = (\x -> Pi mempty "result" (Const Core.Type) (Pi mempty "Make" (Pi mempty "_" x "result") "result")) + <$> Dhall.Marshal.Decode.expected (autoWith inputNormalizer :: Decoder (f (Result f))) + +resultToFix :: Functor f => Result f -> Fix f +resultToFix (Result x) = Fix (fmap resultToFix x) + + + +{-| This is the underlying class that powers the `FromDhall` class's support + for automatically deriving a generic implementation. +-} +class GenericFromDhall t f where + genericAutoWithNormalizer :: Proxy t -> InputNormalizer -> InterpretOptions -> State Int (Decoder (f a)) + +instance GenericFromDhall t f => GenericFromDhall t (M1 D d f) where + genericAutoWithNormalizer p inputNormalizer options = do + res <- genericAutoWithNormalizer p inputNormalizer options + pure (fmap M1 res) + +instance GenericFromDhall t V1 where + genericAutoWithNormalizer _ _ _ = pure Decoder {..} + where + extract expr = typeError expected expr + + expected = pure $ Union mempty + +instance GenericFromDhallUnion t (f :+: g) => GenericFromDhall t (f :+: g) where + genericAutoWithNormalizer p inputNormalizer options = + pure (union (genericUnionAutoWithNormalizer p inputNormalizer options)) + +instance GenericFromDhall t f => GenericFromDhall t (M1 C c f) where + genericAutoWithNormalizer p inputNormalizer options = do + res <- genericAutoWithNormalizer p inputNormalizer options + pure (fmap M1 res) + +instance GenericFromDhall t U1 where + genericAutoWithNormalizer _ _ _ = pure (Decoder {..}) + where + extract _ = pure U1 + + expected = pure expected' + + expected' = Record (Dhall.Map.fromList []) + +instance (GenericFromDhall t (f :*: g), GenericFromDhall t (h :*: i)) => GenericFromDhall t ((f :*: g) :*: (h :*: i)) where + genericAutoWithNormalizer p inputNormalizer options = do + Decoder extractL expectedL <- genericAutoWithNormalizer p inputNormalizer options + Decoder extractR expectedR <- genericAutoWithNormalizer p inputNormalizer options + + let ktsL = unsafeExpectRecord "genericAutoWithNormalizer (:*:)" <$> expectedL + let ktsR = unsafeExpectRecord "genericAutoWithNormalizer (:*:)" <$> expectedR + + let expected = Record <$> (Dhall.Map.union <$> ktsL <*> ktsR) + + let extract expression = + liftA2 (:*:) (extractL expression) (extractR expression) + + return (Decoder {..}) + +instance (GenericFromDhall t (f :*: g), Selector s, FromDhall a) => GenericFromDhall t ((f :*: g) :*: M1 S s (K1 i a)) where + genericAutoWithNormalizer p inputNormalizer options@InterpretOptions{..} = do + let nR :: M1 S s (K1 i a) r + nR = undefined + + nameR <- fmap fieldModifier (getSelName nR) + + Decoder extractL expectedL <- genericAutoWithNormalizer p inputNormalizer options + + let Decoder extractR expectedR = autoWith inputNormalizer + + let ktsL = unsafeExpectRecord "genericAutoWithNormalizer (:*:)" <$> expectedL + + let expected = Record <$> (Dhall.Map.insert nameR . Core.makeRecordField <$> expectedR <*> ktsL) + + let extract expression = do + let die = typeError expected expression + + case expression of + RecordLit kvs -> + case Core.recordFieldValue <$> Dhall.Map.lookup nameR kvs of + Just expressionR -> + liftA2 (:*:) + (extractL expression) + (fmap (M1 . K1) (extractR expressionR)) + _ -> die + _ -> die + + return (Decoder {..}) + +instance (Selector s, FromDhall a, GenericFromDhall t (f :*: g)) => GenericFromDhall t (M1 S s (K1 i a) :*: (f :*: g)) where + genericAutoWithNormalizer p inputNormalizer options@InterpretOptions{..} = do + let nL :: M1 S s (K1 i a) r + nL = undefined + + nameL <- fmap fieldModifier (getSelName nL) + + let Decoder extractL expectedL = autoWith inputNormalizer + + Decoder extractR expectedR <- genericAutoWithNormalizer p inputNormalizer options + + let ktsR = unsafeExpectRecord "genericAutoWithNormalizer (:*:)" <$> expectedR + + let expected = Record <$> (Dhall.Map.insert nameL . Core.makeRecordField <$> expectedL <*> ktsR) + + let extract expression = do + let die = typeError expected expression + + case expression of + RecordLit kvs -> + case Core.recordFieldValue <$> Dhall.Map.lookup nameL kvs of + Just expressionL -> + liftA2 (:*:) + (fmap (M1 . K1) (extractL expressionL)) + (extractR expression) + _ -> die + _ -> die + + return (Decoder {..}) + +instance {-# OVERLAPPING #-} GenericFromDhall a1 (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where + genericAutoWithNormalizer _ _ _ = pure $ Decoder + { extract = \_ -> Failure $ DhallErrors $ pure $ ExpectedTypeError RecursiveTypeError + , expected = Failure $ DhallErrors $ pure RecursiveTypeError + } + +instance {-# OVERLAPPING #-} GenericFromDhall a2 (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where + genericAutoWithNormalizer _ _ _ = pure $ Decoder + { extract = \_ -> Failure $ DhallErrors $ pure $ ExpectedTypeError RecursiveTypeError + , expected = Failure $ DhallErrors $ pure RecursiveTypeError + } + +instance {-# OVERLAPPABLE #-} (Selector s1, Selector s2, FromDhall a1, FromDhall a2) => GenericFromDhall t (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where + genericAutoWithNormalizer _ inputNormalizer InterpretOptions{..} = do + let nL :: M1 S s1 (K1 i1 a1) r + nL = undefined + + let nR :: M1 S s2 (K1 i2 a2) r + nR = undefined + + nameL <- fmap fieldModifier (getSelName nL) + nameR <- fmap fieldModifier (getSelName nR) + + let Decoder extractL expectedL = autoWith inputNormalizer + let Decoder extractR expectedR = autoWith inputNormalizer + + let expected = do + l <- Core.makeRecordField <$> expectedL + r <- Core.makeRecordField <$> expectedR + pure $ Record + (Dhall.Map.fromList + [ (nameL, l) + , (nameR, r) + ] + ) + + let extract expression = do + let die = typeError expected expression + + case expression of + RecordLit kvs -> + case liftA2 (,) (Dhall.Map.lookup nameL kvs) (Dhall.Map.lookup nameR kvs) of + Just (expressionL, expressionR) -> + liftA2 (:*:) + (fmap (M1 . K1) (extractL $ Core.recordFieldValue expressionL)) + (fmap (M1 . K1) (extractR $ Core.recordFieldValue expressionR)) + Nothing -> die + _ -> die + + return (Decoder {..}) + +instance {-# OVERLAPPING #-} GenericFromDhall a (M1 S s (K1 i a)) where + genericAutoWithNormalizer _ _ _ = pure $ Decoder + { extract = \_ -> Failure $ DhallErrors $ pure $ ExpectedTypeError RecursiveTypeError + , expected = Failure $ DhallErrors $ pure RecursiveTypeError + } + +instance {-# OVERLAPPABLE #-} (Selector s, FromDhall a) => GenericFromDhall t (M1 S s (K1 i a)) where + genericAutoWithNormalizer _ inputNormalizer InterpretOptions{..} = do + let n :: M1 S s (K1 i a) r + n = undefined + + name <- fmap fieldModifier (getSelName n) + + let Decoder { extract = extract', expected = expected'} = autoWith inputNormalizer + + let expected = + case singletonConstructors of + Bare -> + expected' + Smart | selName n == "" -> + expected' + _ -> + Record . Dhall.Map.singleton name . Core.makeRecordField <$> expected' + + let extract0 expression = fmap (M1 . K1) (extract' expression) + + let extract1 expression = do + let die = typeError expected expression + + case expression of + RecordLit kvs -> + case Core.recordFieldValue <$> Dhall.Map.lookup name kvs of + Just subExpression -> + fmap (M1 . K1) (extract' subExpression) + Nothing -> + die + _ -> die + + let extract = + case singletonConstructors of + Bare -> extract0 + Smart | selName n == "" -> extract0 + _ -> extract1 + + return (Decoder {..}) + +{-| `genericAuto` is the default implementation for `auto` if you derive + `FromDhall`. The difference is that you can use `genericAuto` without + having to explicitly provide a `FromDhall` instance for a type as long as + the type derives `Generic`. +-} +genericAuto :: (Generic a, GenericFromDhall a (Rep a)) => Decoder a +genericAuto = genericAutoWith defaultInterpretOptions + +{-| `genericAutoWith` is a configurable version of `genericAuto`. +-} +genericAutoWith :: (Generic a, GenericFromDhall a (Rep a)) => InterpretOptions -> Decoder a +genericAutoWith options = withProxy (\p -> fmap to (evalState (genericAutoWithNormalizer p defaultInputNormalizer options) 1)) + where + withProxy :: (Proxy a -> Decoder a) -> Decoder a + withProxy f = f Proxy + +extractUnionConstructor + :: Expr s a -> Maybe (Text, Expr s a, Dhall.Map.Map Text (Maybe (Expr s a))) +extractUnionConstructor (App (Field (Union kts) (Core.fieldSelectionLabel -> fld)) e) = + return (fld, e, Dhall.Map.delete fld kts) +extractUnionConstructor (Field (Union kts) (Core.fieldSelectionLabel -> fld)) = + return (fld, RecordLit mempty, Dhall.Map.delete fld kts) +extractUnionConstructor _ = + empty + +{-| This is the underlying class that powers the `FromDhall` class's support + for automatically deriving a generic implementation for a union type. +-} +class GenericFromDhallUnion t f where + genericUnionAutoWithNormalizer :: Proxy t -> InputNormalizer -> InterpretOptions -> UnionDecoder (f a) + +instance (GenericFromDhallUnion t f1, GenericFromDhallUnion t f2) => GenericFromDhallUnion t (f1 :+: f2) where + genericUnionAutoWithNormalizer p inputNormalizer options = + (<>) + (L1 <$> genericUnionAutoWithNormalizer p inputNormalizer options) + (R1 <$> genericUnionAutoWithNormalizer p inputNormalizer options) + +instance (Constructor c1, GenericFromDhall t f1) => GenericFromDhallUnion t (M1 C c1 f1) where + genericUnionAutoWithNormalizer p inputNormalizer options@(InterpretOptions {..}) = + constructor name (evalState (genericAutoWithNormalizer p inputNormalizer options) 1) + where + n :: M1 C c1 f1 a + n = undefined + + name = constructorModifier (Data.Text.pack (conName n)) + + + +{-| Decode a `Prelude.Bool`. + +>>> input bool "True" +True +-} +bool :: Decoder Bool +bool = Decoder {..} + where + extract (BoolLit b) = pure b + extract expr = typeError expected expr + + expected = pure Bool + +{-| Decode a `Prelude.Natural`. + +>>> input natural "42" +42 +-} +natural :: Decoder Natural +natural = Decoder {..} + where + extract (NaturalLit n) = pure n + extract expr = typeError expected expr + + expected = pure Natural + +{-| Decode an `Prelude.Integer`. + +>>> input integer "+42" +42 +-} +integer :: Decoder Integer +integer = Decoder {..} + where + extract (IntegerLit n) = pure n + extract expr = typeError expected expr + + expected = pure Integer + +wordHelper :: forall a . (Bounded a, Integral a) => Text -> Decoder a +wordHelper name = Decoder {..} + where + extract (NaturalLit n) + | toInteger n <= toInteger (maxBound @a) = + pure (fromIntegral n) + | otherwise = + extractError ("Decoded " <> name <> " is out of bounds: " <> Data.Text.pack (show n)) + extract expr = + typeError expected expr + + expected = pure Natural + +{-| Decode a `Word` from a Dhall @Natural@. + +>>> input word "42" +42 +-} +word :: Decoder Word +word = wordHelper "Word" + +{-| Decode a `Word8` from a Dhall @Natural@. + +>>> input word8 "42" +42 +-} +word8 :: Decoder Word8 +word8 = wordHelper "Word8" + +{-| Decode a `Word16` from a Dhall @Natural@. + +>>> input word16 "42" +42 +-} +word16 :: Decoder Word16 +word16 = wordHelper "Word16" + +{-| Decode a `Word32` from a Dhall @Natural@. + +>>> input word32 "42" +42 +-} +word32 :: Decoder Word32 +word32 = wordHelper "Word32" + +{-| Decode a `Word64` from a Dhall @Natural@. + +>>> input word64 "42" +42 +-} +word64 :: Decoder Word64 +word64 = wordHelper "Word64" + +intHelper :: forall a . (Bounded a, Integral a) => Text -> Decoder a +intHelper name = Decoder {..} + where + extract (IntegerLit n) + | toInteger (minBound @a) <= n && n <= toInteger (maxBound @a) = + pure (fromIntegral n) + | otherwise = + extractError ("Decoded " <> name <> " is out of bounds: " <> Data.Text.pack (show n)) + extract expr = + typeError expected expr + + expected = pure Integer + +{-| Decode an `Int` from a Dhall @Integer@. + +>>> input int "-42" +-42 +-} +int :: Decoder Int +int = intHelper "Int" + +{-| Decode an `Int8` from a Dhall @Integer@. + +>>> input int8 "-42" +-42 +-} +int8 :: Decoder Int8 +int8 = intHelper "Int8" + +{-| Decode an `Int16` from a Dhall @Integer@. + +>>> input int16 "-42" +-42 +-} +int16 :: Decoder Int16 +int16 = intHelper "Int16" + +{-| Decode an `Int32` from a Dhall @Integer@. + +>>> input int32 "-42" +-42 +-} +int32 :: Decoder Int32 +int32 = intHelper "Int32" + +{-| Decode an `Int64` from a Dhall @Integer@. + +>>> input int64 "-42" +-42 +-} +int64 :: Decoder Int64 +int64 = intHelper "Int64" + +{-| Decode a `Scientific`. + +>>> input scientific "1e100" +1.0e100 +-} +scientific :: Decoder Scientific +scientific = fmap Data.Scientific.fromFloatDigits double + +{-| Decode a `Prelude.Double`. + +>>> input double "42.0" +42.0 +-} +double :: Decoder Double +double = Decoder {..} + where + extract (DoubleLit (DhallDouble n)) = pure n + extract expr = typeError expected expr + + expected = pure Double + +{-| Decode lazy `Data.Text.Text`. + +>>> input lazyText "\"Test\"" +"Test" +-} +lazyText :: Decoder Data.Text.Lazy.Text +lazyText = fmap Data.Text.Lazy.fromStrict strictText + +{-| Decode strict `Data.Text.Text`. + +>>> input strictText "\"Test\"" +"Test" +-} +strictText :: Decoder Text +strictText = Decoder {..} + where + extract (TextLit (Chunks [] t)) = pure t + extract expr = typeError expected expr + + expected = pure Text + +{-| Decode a `Maybe`. + +>>> input (maybe natural) "Some 1" +Just 1 +-} +maybe :: Decoder a -> Decoder (Maybe a) +maybe (Decoder extractIn expectedIn) = Decoder extractOut expectedOut + where + extractOut (Some e ) = fmap Just (extractIn e) + extractOut (App None _) = pure Nothing + extractOut expr = typeError expectedOut expr + + expectedOut = App Optional <$> expectedIn + +{-| Decode a `Seq`. + +>>> input (sequence natural) "[1, 2, 3]" +fromList [1,2,3] +-} +sequence :: Decoder a -> Decoder (Seq a) +sequence (Decoder extractIn expectedIn) = Decoder extractOut expectedOut + where + extractOut (ListLit _ es) = traverse extractIn es + extractOut expr = typeError expectedOut expr + + expectedOut = App List <$> expectedIn + +{-| Decode a list. + +>>> input (list natural) "[1, 2, 3]" +[1,2,3] +-} +list :: Decoder a -> Decoder [a] +list = fmap Data.Foldable.toList . sequence + +{-| Decode a `Vector`. + +>>> input (vector natural) "[1, 2, 3]" +[1,2,3] +-} +vector :: Decoder a -> Decoder (Vector a) +vector = fmap Data.Vector.fromList . list + +{-| Decode a Dhall function into a Haskell function. + +>>> f <- input (function inject bool) "Natural/even" :: IO (Natural -> Bool) +>>> f 0 +True +>>> f 1 +False +-} +function + :: Encoder a + -> Decoder b + -> Decoder (a -> b) +function = functionWith defaultInputNormalizer + +{-| Decode a Dhall function into a Haskell function using the specified normalizer. + +>>> f <- input (functionWith defaultInputNormalizer inject bool) "Natural/even" :: IO (Natural -> Bool) +>>> f 0 +True +>>> f 1 +False +-} +functionWith + :: InputNormalizer + -> Encoder a + -> Decoder b + -> Decoder (a -> b) +functionWith inputNormalizer (Encoder {..}) (Decoder extractIn expectedIn) = + Decoder extractOut expectedOut + where + normalizer_ = Just (getInputNormalizer inputNormalizer) + + extractOut e = pure (\i -> case extractIn (Core.normalizeWith normalizer_ (App e (embed i))) of + Success o -> o + Failure _e -> error "FromDhall: You cannot decode a function if it does not have the correct type" ) + + expectedOut = Pi mempty "_" declared <$> expectedIn + +{-| Decode a `Data.Set.Set` from a `List`. + +>>> input (setIgnoringDuplicates natural) "[1, 2, 3]" +fromList [1,2,3] + +Duplicate elements are ignored. + +>>> input (setIgnoringDuplicates natural) "[1, 1, 3]" +fromList [1,3] + +-} +setIgnoringDuplicates :: (Ord a) => Decoder a -> Decoder (Data.Set.Set a) +setIgnoringDuplicates = fmap Data.Set.fromList . list + +{-| Decode a `Data.HashSet.HashSet` from a `List`. + +>>> input (hashSetIgnoringDuplicates natural) "[1, 2, 3]" +fromList [1,2,3] + +Duplicate elements are ignored. + +>>> input (hashSetIgnoringDuplicates natural) "[1, 1, 3]" +fromList [1,3] + +-} +hashSetIgnoringDuplicates :: (Hashable a, Ord a) + => Decoder a + -> Decoder (Data.HashSet.HashSet a) +hashSetIgnoringDuplicates = fmap Data.HashSet.fromList . list + +{-| Decode a `Data.Set.Set` from a `List` with distinct elements. + +>>> input (setFromDistinctList natural) "[1, 2, 3]" +fromList [1,2,3] + +An error is thrown if the list contains duplicates. + +> >>> input (setFromDistinctList natural) "[1, 1, 3]" +> *** Exception: Error: Failed extraction +> +> The expression type-checked successfully but the transformation to the target +> type failed with the following error: +> +> One duplicate element in the list: 1 +> + +> >>> input (setFromDistinctList natural) "[1, 1, 3, 3]" +> *** Exception: Error: Failed extraction +> +> The expression type-checked successfully but the transformation to the target +> type failed with the following error: +> +> 2 duplicates were found in the list, including 1 +> + +-} +setFromDistinctList :: (Ord a, Show a) => Decoder a -> Decoder (Data.Set.Set a) +setFromDistinctList = setHelper Data.Set.size Data.Set.fromList + +{-| Decode a `Data.HashSet.HashSet` from a `List` with distinct elements. + +>>> input (hashSetFromDistinctList natural) "[1, 2, 3]" +fromList [1,2,3] + +An error is thrown if the list contains duplicates. + +> >>> input (hashSetFromDistinctList natural) "[1, 1, 3]" +> *** Exception: Error: Failed extraction +> +> The expression type-checked successfully but the transformation to the target +> type failed with the following error: +> +> One duplicate element in the list: 1 +> + +> >>> input (hashSetFromDistinctList natural) "[1, 1, 3, 3]" +> *** Exception: Error: Failed extraction +> +> The expression type-checked successfully but the transformation to the target +> type failed with the following error: +> +> 2 duplicates were found in the list, including 1 +> + +-} +hashSetFromDistinctList :: (Hashable a, Ord a, Show a) + => Decoder a + -> Decoder (Data.HashSet.HashSet a) +hashSetFromDistinctList = setHelper Data.HashSet.size Data.HashSet.fromList + + +setHelper :: (Eq a, Foldable t, Show a) + => (t a -> Int) + -> ([a] -> t a) + -> Decoder a + -> Decoder (t a) +setHelper size toSet (Decoder extractIn expectedIn) = Decoder extractOut expectedOut + where + extractOut (ListLit _ es) = case traverse extractIn es of + Success vSeq + | sameSize -> Success vSet + | otherwise -> extractError err + where + vList = Data.Foldable.toList vSeq + vSet = toSet vList + sameSize = size vSet == Data.Sequence.length vSeq + duplicates = vList List.\\ Data.Foldable.toList vSet + err | length duplicates == 1 = + "One duplicate element in the list: " + <> (Data.Text.pack $ show $ head duplicates) + | otherwise = Data.Text.pack $ unwords + [ show $ length duplicates + , "duplicates were found in the list, including" + , show $ head duplicates + ] + Failure f -> Failure f + extractOut expr = typeError expectedOut expr + + expectedOut = App List <$> expectedIn + +{-| Decode a `Map` from a @toMap@ expression or generally a @Prelude.Map.Type@. + +>>> input (Dhall.map strictText bool) "toMap { a = True, b = False }" +fromList [("a",True),("b",False)] +>>> input (Dhall.map strictText bool) "[ { mapKey = \"foo\", mapValue = True } ]" +fromList [("foo",True)] + +If there are duplicate @mapKey@s, later @mapValue@s take precedence: + +>>> let expr = "[ { mapKey = 1, mapValue = True }, { mapKey = 1, mapValue = False } ]" +>>> input (Dhall.map natural bool) expr +fromList [(1,False)] + +-} +map :: Ord k => Decoder k -> Decoder v -> Decoder (Map k v) +map k v = fmap Data.Map.fromList (list (pairFromMapEntry k v)) + +{-| Decode a `HashMap` from a @toMap@ expression or generally a @Prelude.Map.Type@. + +>>> fmap (List.sort . HashMap.toList) (input (Dhall.hashMap strictText bool) "toMap { a = True, b = False }") +[("a",True),("b",False)] +>>> fmap (List.sort . HashMap.toList) (input (Dhall.hashMap strictText bool) "[ { mapKey = \"foo\", mapValue = True } ]") +[("foo",True)] + +If there are duplicate @mapKey@s, later @mapValue@s take precedence: + +>>> let expr = "[ { mapKey = 1, mapValue = True }, { mapKey = 1, mapValue = False } ]" +>>> input (Dhall.hashMap natural bool) expr +fromList [(1,False)] + +-} +hashMap :: (Eq k, Hashable k) => Decoder k -> Decoder v -> Decoder (HashMap k v) +hashMap k v = fmap HashMap.fromList (list (pairFromMapEntry k v)) + +{-| Decode a tuple from a @Prelude.Map.Entry@ record. + +>>> input (pairFromMapEntry strictText natural) "{ mapKey = \"foo\", mapValue = 3 }" +("foo",3) +-} +pairFromMapEntry :: Decoder k -> Decoder v -> Decoder (k, v) +pairFromMapEntry k v = Decoder extractOut expectedOut + where + extractOut (RecordLit kvs) + | Just key <- Core.recordFieldValue <$> Dhall.Map.lookup "mapKey" kvs + , Just value <- Core.recordFieldValue <$> Dhall.Map.lookup "mapValue" kvs + = liftA2 (,) (extract k key) (extract v value) + extractOut expr = typeError expectedOut expr + + expectedOut = do + k' <- Core.makeRecordField <$> expected k + v' <- Core.makeRecordField <$> expected v + pure $ Record $ Dhall.Map.fromList + [ ("mapKey", k') + , ("mapValue", v')] + +{-| Decode @()@ from an empty record. + +>>> input unit "{=}" -- GHC doesn't print the result if it is () + +-} +unit :: Decoder () +unit = Decoder {..} + where + extract (RecordLit fields) + | Data.Foldable.null fields = pure () + extract expr = typeError expected expr + + expected = pure $ Record mempty + +{-| Decode 'Void' from an empty union. + +Since @<>@ is uninhabited, @'Dhall.input' 'void'@ will always fail. +-} +void :: Decoder Void +void = union mempty + +{-| Decode a `String` + +>>> input string "\"ABC\"" +"ABC" + +-} +string :: Decoder String +string = Data.Text.Lazy.unpack <$> lazyText + +{-| Given a pair of `Decoder`s, decode a tuple-record into their pairing. + +>>> input (pair natural bool) "{ _1 = 42, _2 = False }" +(42,False) +-} +pair :: Decoder a -> Decoder b -> Decoder (a, b) +pair l r = Decoder extractOut expectedOut + where + extractOut expr@(RecordLit fields) = + (,) <$> Data.Maybe.maybe (typeError expectedOut expr) (extract l) + (Core.recordFieldValue <$> Dhall.Map.lookup "_1" fields) + <*> Data.Maybe.maybe (typeError expectedOut expr) (extract r) + (Core.recordFieldValue <$> Dhall.Map.lookup "_2" fields) + extractOut expr = typeError expectedOut expr + + expectedOut = do + l' <- Core.makeRecordField <$> expected l + r' <- Core.makeRecordField <$> expected r + pure $ Record $ Dhall.Map.fromList + [ ("_1", l') + , ("_2", r')] + + + +{-| The 'RecordDecoder' applicative functor allows you to build a 'Decoder' + from a Dhall record. + + For example, let's take the following Haskell data type: + +>>> :{ +data Project = Project + { projectName :: Text + , projectDescription :: Text + , projectStars :: Natural + } +:} + + And assume that we have the following Dhall record that we would like to + parse as a @Project@: + +> { name = +> "dhall-haskell" +> , description = +> "A configuration language guaranteed to terminate" +> , stars = +> 289 +> } + + Our decoder has type 'Decoder' @Project@, but we can't build that out of any + smaller decoders, as 'Decoder's cannot be combined (they are only 'Functor's). + However, we can use a 'RecordDecoder' to build a 'Decoder' for @Project@: + +>>> :{ +project :: Decoder Project +project = + record + ( Project <$> field "name" strictText + <*> field "description" strictText + <*> field "stars" natural + ) +:} +-} +newtype RecordDecoder a = + RecordDecoder + ( Data.Functor.Product.Product + ( Control.Applicative.Const + (Dhall.Map.Map Text (Expector (Expr Src Void))) + ) + ( Data.Functor.Compose.Compose ((->) (Expr Src Void)) (Extractor Src Void) + ) + a + ) + deriving (Functor, Applicative) + +-- | Run a 'RecordDecoder' to build a 'Decoder'. +record :: RecordDecoder a -> Dhall.Marshal.Decode.Decoder a +record + (RecordDecoder + (Data.Functor.Product.Pair + (Control.Applicative.Const fields) + (Data.Functor.Compose.Compose extract) + ) + ) = Decoder {..} + where + expected = Record <$> traverse (fmap Core.makeRecordField) fields + +-- | Parse a single field of a record. +field :: Text -> Decoder a -> RecordDecoder a +field key (Decoder {..}) = + RecordDecoder + ( Data.Functor.Product.Pair + ( Control.Applicative.Const + (Dhall.Map.singleton key expected) + ) + ( Data.Functor.Compose.Compose extractBody ) + ) + where + extractBody expr@(RecordLit fields) = case Core.recordFieldValue <$> Dhall.Map.lookup key fields of + Just v -> extract v + _ -> typeError expected expr + extractBody expr = typeError expected expr + + + +{-| The 'UnionDecoder' monoid allows you to build a 'Decoder' from a Dhall union. + + For example, let's take the following Haskell data type: + +>>> :{ +data Status = Queued Natural + | Result Text + | Errored Text +:} + + And assume that we have the following Dhall union that we would like to + parse as a @Status@: + +> < Result : Text +> | Queued : Natural +> | Errored : Text +> >.Result "Finish successfully" + + Our decoder has type 'Decoder' @Status@, but we can't build that out of any + smaller decoders, as 'Decoder's cannot be combined (they are only 'Functor's). + However, we can use a 'UnionDecoder' to build a 'Decoder' for @Status@: + +>>> :{ +status :: Decoder Status +status = union + ( ( Queued <$> constructor "Queued" natural ) + <> ( Result <$> constructor "Result" strictText ) + <> ( Errored <$> constructor "Errored" strictText ) + ) +:} + +-} +newtype UnionDecoder a = + UnionDecoder + ( Data.Functor.Compose.Compose (Dhall.Map.Map Text) Decoder a ) + deriving (Functor) + +instance Semigroup (UnionDecoder a) where + (<>) = coerce ((<>) :: Dhall.Map.Map Text (Decoder a) -> Dhall.Map.Map Text (Decoder a) -> Dhall.Map.Map Text (Decoder a)) + +instance Monoid (UnionDecoder a) where + mempty = coerce (mempty :: Dhall.Map.Map Text (Decoder a)) + +-- | Run a 'UnionDecoder' to build a 'Decoder'. +union :: UnionDecoder a -> Decoder a +union (UnionDecoder (Data.Functor.Compose.Compose mp)) = Decoder {..} + where + extract expr = case expected' of + Failure e -> Failure $ fmap ExpectedTypeError e + Success x -> extract' expr x + + extract' e0 mp' = Data.Maybe.maybe (typeError expected e0) (uncurry Dhall.Marshal.Decode.extract) $ do + (fld, e1, rest) <- extractUnionConstructor e0 + + t <- Dhall.Map.lookup fld mp + + guard $ + Core.Union rest `Core.judgmentallyEqual` Core.Union (Dhall.Map.delete fld mp') + + pure (t, e1) + + expected = Union <$> expected' + + expected' = traverse (fmap notEmptyRecord . Dhall.Marshal.Decode.expected) mp + +-- | Parse a single constructor of a union. +constructor :: Text -> Decoder a -> UnionDecoder a +constructor key valueDecoder = UnionDecoder + ( Data.Functor.Compose.Compose (Dhall.Map.singleton key valueDecoder) ) + + + +{-| A newtype suitable for collecting one or more errors. +-} +newtype DhallErrors e = DhallErrors + { getErrors :: NonEmpty e + } deriving (Eq, Functor, Semigroup) + +instance (Show (DhallErrors e), Typeable e) => Exception (DhallErrors e) + +{-| Render a given prefix and some errors to a string. +-} +showDhallErrors :: Show e => String -> DhallErrors e -> String +showDhallErrors _ (DhallErrors (e :| [])) = show e +showDhallErrors ctx (DhallErrors es) = prefix <> (unlines . Data.List.NonEmpty.toList . fmap show $ es) + where + prefix = + "Multiple errors were encountered" ++ ctx ++ ": \n\ + \ \n" + +{-| One or more errors returned from extracting a Dhall expression to a + Haskell expression. +-} +type ExtractErrors s a = DhallErrors (ExtractError s a) + +instance (Pretty s, Pretty a, Typeable s, Typeable a) => Show (ExtractErrors s a) where + show = showDhallErrors " during extraction" + +{-| Extraction of a value can fail for two reasons, either a type mismatch (which should not happen, + as expressions are type-checked against the expected type before being passed to @extract@), or + a term-level error, described with a freeform text value. +-} +data ExtractError s a = + TypeMismatch (InvalidDecoder s a) + | ExpectedTypeError ExpectedTypeError + | ExtractError Text + +instance (Pretty s, Pretty a, Typeable s, Typeable a) => Show (ExtractError s a) where + show (TypeMismatch e) = show e + show (ExpectedTypeError e) = show e + show (ExtractError es) = + _ERROR <> ": Failed extraction \n\ + \ \n\ + \The expression type-checked successfully but the transformation to the target \n\ + \type failed with the following error: \n\ + \ \n\ + \" <> Data.Text.unpack es <> "\n\ + \ \n" + +instance (Pretty s, Pretty a, Typeable s, Typeable a) => Exception (ExtractError s a) + +{-| Useful synonym for the `Validation` type used when marshalling Dhall + expressions. +-} +type Extractor s a = Validation (ExtractErrors s a) + +{-| Generate a type error during extraction by specifying the expected type + and the actual type. + The expected type is not yet determined. +-} +typeError :: Expector (Expr s a) -> Expr s a -> Extractor s a b +typeError expected actual = Failure $ case expected of + Failure e -> fmap ExpectedTypeError e + Success expected' -> DhallErrors $ pure $ TypeMismatch $ InvalidDecoder expected' actual + +-- | Turn a `Data.Text.Text` message into an extraction failure. +extractError :: Text -> Extractor s a b +extractError = Failure . DhallErrors . pure . ExtractError + +{-| Useful synonym for the equivalent `Either` type used when marshalling Dhall + code. +-} +type MonadicExtractor s a = Either (ExtractErrors s a) + +-- | Switches from an @Applicative@ extraction result, able to accumulate errors, +-- to a @Monad@ extraction result, able to chain sequential operations. +toMonadic :: Extractor s a b -> MonadicExtractor s a b +toMonadic = validationToEither + +-- | Switches from a @Monad@ extraction result, able to chain sequential errors, +-- to an @Applicative@ extraction result, able to accumulate errors. +fromMonadic :: MonadicExtractor s a b -> Extractor s a b +fromMonadic = eitherToValidation + +{-| Every `Decoder` must obey the contract that if an expression's type matches + the `expected` type then the `extract` function must not fail with a type + error. However, decoding may still fail for other reasons (such as the + decoder for `Data.Map.Set`s rejecting a Dhall @List@ with duplicate + elements). + + This error type is used to indicate an internal error in the implementation + of a `Decoder` where the expected type matched the Dhall expression, but the + expression supplied to the extraction function did not match the expected + type. If this happens that means that the `Decoder` itself needs to be + fixed. +-} +data InvalidDecoder s a = InvalidDecoder + { invalidDecoderExpected :: Expr s a + , invalidDecoderExpression :: Expr s a + } + deriving (Typeable) + +instance (Pretty s, Typeable s, Pretty a, Typeable a) => Exception (InvalidDecoder s a) + +instance (Pretty s, Pretty a, Typeable s, Typeable a) => Show (InvalidDecoder s a) where + show InvalidDecoder { .. } = + _ERROR <> ": Invalid Dhall.Decoder \n\ + \ \n\ + \Every Decoder must provide an extract function that does not fail with a type \n\ + \error if an expression matches the expected type. You provided a Decoder that \n\ + \disobeys this contract \n\ + \ \n\ + \The Decoder provided has the expected dhall type: \n\ + \ \n\ + \" <> show txt0 <> "\n\ + \ \n\ + \and it threw a type error during extraction from the well-typed expression: \n\ + \ \n\ + \" <> show txt1 <> "\n\ + \ \n" + where + txt0 = Dhall.Util.insert invalidDecoderExpected + txt1 = Dhall.Util.insert invalidDecoderExpression + +{-| Useful synonym for the `Validation` type used when marshalling Dhall + expressions. +-} +type Expector = Validation ExpectedTypeErrors + +{-| One or more errors returned when determining the Dhall type of a + Haskell expression. +-} +type ExpectedTypeErrors = DhallErrors ExpectedTypeError + +{-| Error type used when determining the Dhall type of a Haskell expression. +-} +data ExpectedTypeError = RecursiveTypeError + deriving (Eq, Show) + +instance Exception ExpectedTypeError + +instance Show ExpectedTypeErrors where + show = showDhallErrors " while determining the expected type" + +_ERROR :: String +_ERROR = "\ESC[1;31mError\ESC[0m" diff --git a/src/Dhall/Marshal/Encode.hs b/src/Dhall/Marshal/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Marshal/Encode.hs @@ -0,0 +1,931 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| Please read the "Dhall.Tutorial" module, which contains a tutorial explaining + how to use the language, the compiler, and this library +-} + +module Dhall.Marshal.Encode + ( -- * General + Encoder(..) + , ToDhall(..) + , Inject + , inject + + -- * Building encoders + + -- ** Records + , RecordEncoder(..) + , recordEncoder + , encodeField + , encodeFieldWith + -- ** Unions + , UnionEncoder(..) + , unionEncoder + , encodeConstructor + , encodeConstructorWith + , (>|<) + + -- * Generic encoding + , GenericToDhall(..) + , genericToDhall + , genericToDhallWith + , InterpretOptions(..) + , SingletonConstructors(..) + , defaultInterpretOptions + + -- * Miscellaneous + , InputNormalizer(..) + , defaultInputNormalizer + , Result + , (>$<) + , (>*<) + + -- * Re-exports + , Natural + , Seq + , Text + , Vector + , Generic + ) where + +import Control.Monad.Trans.State.Strict +import Data.Functor.Contravariant (Contravariant (..), Op (..), (>$<)) +import Data.Functor.Contravariant.Divisible (Divisible (..), divided) +import Dhall.Parser (Src (..)) +import Dhall.Syntax + ( Chunks (..) + , DhallDouble (..) + , Expr (..) + ) +import GHC.Generics +import Prelude hiding (maybe, sequence) + +import qualified Control.Applicative +import qualified Data.Functor.Product +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet +import qualified Data.Map +import qualified Data.Scientific +import qualified Data.Sequence +import qualified Data.Set +import qualified Data.Text +import qualified Data.Text.Lazy +import qualified Data.Vector +import qualified Data.Void +import qualified Dhall.Core as Core +import qualified Dhall.Map + +import Dhall.Marshal.Internal + +-- $setup +-- >>> :set -XRecordWildCards +-- >>> import Dhall.Pretty.Internal (prettyExpr) + +{-| An @(Encoder a)@ represents a way to marshal a value of type @\'a\'@ from + Haskell into Dhall. +-} +data Encoder a = Encoder + { embed :: a -> Expr Src Void + -- ^ Embeds a Haskell value as a Dhall expression + , declared :: Expr Src Void + -- ^ Dhall type of the Haskell value + } + +instance Contravariant Encoder where + contramap f (Encoder embed declared) = Encoder embed' declared + where + embed' x = embed (f x) + +{-| This class is used by `Dhall.Marshal.Decode.FromDhall` instance for functions: + +> instance (ToDhall a, FromDhall b) => FromDhall (a -> b) + + You can convert Dhall functions with "simple" inputs (i.e. instances of this + class) into Haskell functions. This works by: + + * Marshaling the input to the Haskell function into a Dhall expression (i.e. + @x :: Expr Src Void@) + * Applying the Dhall function (i.e. @f :: Expr Src Void@) to the Dhall input + (i.e. @App f x@) + * Normalizing the syntax tree (i.e. @normalize (App f x)@) + * Marshaling the resulting Dhall expression back into a Haskell value + + This class auto-generates a default implementation for types that + implement `Generic`. This does not auto-generate an instance for recursive + types. + + The default instance can be tweaked using 'genericToDhallWith' and custom + 'InterpretOptions', or using + [DerivingVia](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-DerivingVia) + and 'Dhall.Deriving.Codec' from "Dhall.Deriving". +-} +class ToDhall a where + injectWith :: InputNormalizer -> Encoder a + default injectWith + :: (Generic a, GenericToDhall (Rep a)) => InputNormalizer -> Encoder a + injectWith _ = genericToDhall + +-- | A compatibility alias for `ToDhall` +type Inject = ToDhall +{-# DEPRECATED Inject "Use ToDhall instead" #-} + +{-| Use the default input normalizer for injecting a value. + +> inject = injectWith defaultInputNormalizer +-} +inject :: ToDhall a => Encoder a +inject = injectWith defaultInputNormalizer + + + +instance ToDhall Void where + injectWith _ = Encoder {..} + where + embed = Data.Void.absurd + + declared = Union mempty + +instance ToDhall Bool where + injectWith _ = Encoder {..} + where + embed = BoolLit + + declared = Bool + +instance ToDhall Data.Text.Lazy.Text where + injectWith _ = Encoder {..} + where + embed text = + TextLit (Chunks [] (Data.Text.Lazy.toStrict text)) + + declared = Text + +instance ToDhall Text where + injectWith _ = Encoder {..} + where + embed text = TextLit (Chunks [] text) + + declared = Text + +instance {-# OVERLAPS #-} ToDhall String where + injectWith inputNormalizer = + contramap Data.Text.pack (injectWith inputNormalizer :: Encoder Text) + +instance ToDhall Natural where + injectWith _ = Encoder {..} + where + embed = NaturalLit + + declared = Natural + +instance ToDhall Integer where + injectWith _ = Encoder {..} + where + embed = IntegerLit + + declared = Integer + +instance ToDhall Int where + injectWith _ = Encoder {..} + where + embed = IntegerLit . toInteger + + declared = Integer + +{-| Encode a 'Word' to a Dhall @Natural@. + +>>> embed inject (12 :: Word) +NaturalLit 12 +-} +instance ToDhall Word where + injectWith _ = Encoder {..} + where + embed = NaturalLit . fromIntegral + + declared = Natural + +{-| Encode a 'Word8' to a Dhall @Natural@. + +>>> embed inject (12 :: Word8) +NaturalLit 12 +-} +instance ToDhall Word8 where + injectWith _ = Encoder {..} + where + embed = NaturalLit . fromIntegral + + declared = Natural + +{-| Encode a 'Word16' to a Dhall @Natural@. + +>>> embed inject (12 :: Word16) +NaturalLit 12 +-} +instance ToDhall Word16 where + injectWith _ = Encoder {..} + where + embed = NaturalLit . fromIntegral + + declared = Natural + +{-| Encode a 'Word32' to a Dhall @Natural@. + +>>> embed inject (12 :: Word32) +NaturalLit 12 +-} +instance ToDhall Word32 where + injectWith _ = Encoder {..} + where + embed = NaturalLit . fromIntegral + + declared = Natural + +{-| Encode a 'Word64' to a Dhall @Natural@. + +>>> embed inject (12 :: Word64) +NaturalLit 12 +-} +instance ToDhall Word64 where + injectWith _ = Encoder {..} + where + embed = NaturalLit . fromIntegral + + declared = Natural + +instance ToDhall Double where + injectWith _ = Encoder {..} + where + embed = DoubleLit . DhallDouble + + declared = Double + +instance ToDhall Scientific where + injectWith inputNormalizer = + contramap Data.Scientific.toRealFloat (injectWith inputNormalizer :: Encoder Double) + +instance ToDhall () where + injectWith _ = Encoder {..} + where + embed = const (RecordLit mempty) + + declared = Record mempty + +instance ToDhall a => ToDhall (Maybe a) where + injectWith inputNormalizer = Encoder embedOut declaredOut + where + embedOut (Just x ) = Some (embedIn x) + embedOut Nothing = App None declaredIn + + Encoder embedIn declaredIn = injectWith inputNormalizer + + declaredOut = App Optional declaredIn + +instance ToDhall a => ToDhall (Seq a) where + injectWith inputNormalizer = Encoder embedOut declaredOut + where + embedOut xs = ListLit listType (fmap embedIn xs) + where + listType + | null xs = Just (App List declaredIn) + | otherwise = Nothing + + declaredOut = App List declaredIn + + Encoder embedIn declaredIn = injectWith inputNormalizer + +instance ToDhall a => ToDhall [a] where + injectWith = fmap (contramap Data.Sequence.fromList) injectWith + +instance ToDhall a => ToDhall (Vector a) where + injectWith = fmap (contramap Data.Vector.toList) injectWith + +{-| Note that the output list will be sorted. + +>>> let x = Data.Set.fromList ["mom", "hi" :: Text] +>>> prettyExpr $ embed inject x +[ "hi", "mom" ] + +-} +instance ToDhall a => ToDhall (Data.Set.Set a) where + injectWith = fmap (contramap Data.Set.toAscList) injectWith + +-- | Note that the output list may not be sorted +instance ToDhall a => ToDhall (Data.HashSet.HashSet a) where + injectWith = fmap (contramap Data.HashSet.toList) injectWith + +instance (ToDhall a, ToDhall b) => ToDhall (a, b) + +{-| Embed a `Data.Map` as a @Prelude.Map.Type@. + +>>> prettyExpr $ embed inject (Data.Map.fromList [(1 :: Natural, True)]) +[ { mapKey = 1, mapValue = True } ] + +>>> prettyExpr $ embed inject (Data.Map.fromList [] :: Data.Map.Map Natural Bool) +[] : List { mapKey : Natural, mapValue : Bool } + +-} +instance (ToDhall k, ToDhall v) => ToDhall (Data.Map.Map k v) where + injectWith inputNormalizer = Encoder embedOut declaredOut + where + embedOut m = ListLit listType (mapEntries m) + where + listType + | Data.Map.null m = Just declaredOut + | otherwise = Nothing + + declaredOut = App List (Record $ Dhall.Map.fromList + [ ("mapKey", Core.makeRecordField declaredK) + , ("mapValue", Core.makeRecordField declaredV) + ]) + + mapEntries = Data.Sequence.fromList . fmap recordPair . Data.Map.toList + recordPair (k, v) = RecordLit $ Dhall.Map.fromList + [ ("mapKey", Core.makeRecordField $ embedK k) + , ("mapValue", Core.makeRecordField $ embedV v) + ] + + Encoder embedK declaredK = injectWith inputNormalizer + Encoder embedV declaredV = injectWith inputNormalizer + +{-| Embed a `Data.HashMap` as a @Prelude.Map.Type@. + +>>> prettyExpr $ embed inject (HashMap.fromList [(1 :: Natural, True)]) +[ { mapKey = 1, mapValue = True } ] + +>>> prettyExpr $ embed inject (HashMap.fromList [] :: HashMap Natural Bool) +[] : List { mapKey : Natural, mapValue : Bool } + +-} +instance (ToDhall k, ToDhall v) => ToDhall (HashMap k v) where + injectWith inputNormalizer = Encoder embedOut declaredOut + where + embedOut m = ListLit listType (mapEntries m) + where + listType + | HashMap.null m = Just declaredOut + | otherwise = Nothing + + declaredOut = App List (Record $ Dhall.Map.fromList + [ ("mapKey", Core.makeRecordField declaredK) + , ("mapValue", Core.makeRecordField declaredV) + ]) + + mapEntries = Data.Sequence.fromList . fmap recordPair . HashMap.toList + recordPair (k, v) = RecordLit $ Dhall.Map.fromList + [ ("mapKey", Core.makeRecordField $ embedK k) + , ("mapValue", Core.makeRecordField $ embedV v) + ] + + Encoder embedK declaredK = injectWith inputNormalizer + Encoder embedV declaredV = injectWith inputNormalizer + +instance ToDhall (f (Result f)) => ToDhall (Result f) where + injectWith inputNormalizer = Encoder {..} + where + embed = App "Make" . Dhall.Marshal.Encode.embed (injectWith inputNormalizer) . _unResult + declared = "result" + +instance forall f. (Functor f, ToDhall (f (Result f))) => ToDhall (Fix f) where + injectWith inputNormalizer = Encoder {..} + where + embed fixf = + Lam Nothing (Core.makeFunctionBinding "result" (Const Core.Type)) $ + Lam Nothing (Core.makeFunctionBinding "Make" makeType) $ + embed' . fixToResult $ fixf + + declared = Pi Nothing "result" (Const Core.Type) $ Pi Nothing "_" makeType "result" + + makeType = Pi Nothing "_" declared' "result" + Encoder embed' _ = injectWith @(Dhall.Marshal.Internal.Result f) inputNormalizer + Encoder _ declared' = injectWith @(f (Dhall.Marshal.Internal.Result f)) inputNormalizer + +fixToResult :: Functor f => Fix f -> Result f +fixToResult (Fix x) = Result (fmap fixToResult x) + + + +{-| This is the underlying class that powers the `Dhall.Marshal.Decode.FromDhall` class's support + for automatically deriving a generic implementation. +-} +class GenericToDhall f where + genericToDhallWithNormalizer :: InputNormalizer -> InterpretOptions -> State Int (Encoder (f a)) + +instance GenericToDhall f => GenericToDhall (M1 D d f) where + genericToDhallWithNormalizer inputNormalizer options = do + res <- genericToDhallWithNormalizer inputNormalizer options + pure (contramap unM1 res) + +instance GenericToDhall f => GenericToDhall (M1 C c f) where + genericToDhallWithNormalizer inputNormalizer options = do + res <- genericToDhallWithNormalizer inputNormalizer options + pure (contramap unM1 res) + +instance (Selector s, ToDhall a) => GenericToDhall (M1 S s (K1 i a)) where + genericToDhallWithNormalizer inputNormalizer InterpretOptions{..} = do + let Encoder { embed = embed', declared = declared' } = + injectWith inputNormalizer + + let n :: M1 S s (K1 i a) r + n = undefined + + name <- fieldModifier <$> getSelName n + + let embed0 (M1 (K1 x)) = embed' x + + let embed1 (M1 (K1 x)) = + RecordLit (Dhall.Map.singleton name (Core.makeRecordField $ embed' x)) + + let embed = + case singletonConstructors of + Bare -> embed0 + Smart | selName n == "" -> embed0 + _ -> embed1 + + let declared = + case singletonConstructors of + Bare -> + declared' + Smart | selName n == "" -> + declared' + _ -> + Record (Dhall.Map.singleton name $ Core.makeRecordField declared') + + return (Encoder {..}) + +instance (Constructor c1, Constructor c2, GenericToDhall f1, GenericToDhall f2) => GenericToDhall (M1 C c1 f1 :+: M1 C c2 f2) where + genericToDhallWithNormalizer inputNormalizer options@(InterpretOptions {..}) = pure (Encoder {..}) + where + embed (L1 (M1 l)) = + case notEmptyRecordLit (embedL l) of + Nothing -> + Field declared $ Core.makeFieldSelection keyL + Just valL -> + App (Field declared $ Core.makeFieldSelection keyL) valL + + embed (R1 (M1 r)) = + case notEmptyRecordLit (embedR r) of + Nothing -> + Field declared $ Core.makeFieldSelection keyR + Just valR -> + App (Field declared $ Core.makeFieldSelection keyR) valR + + declared = + Union + (Dhall.Map.fromList + [ (keyL, notEmptyRecord declaredL) + , (keyR, notEmptyRecord declaredR) + ] + ) + + nL :: M1 i c1 f1 a + nL = undefined + + nR :: M1 i c2 f2 a + nR = undefined + + keyL = constructorModifier (Data.Text.pack (conName nL)) + keyR = constructorModifier (Data.Text.pack (conName nR)) + + Encoder embedL declaredL = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 + Encoder embedR declaredR = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 + +instance (Constructor c, GenericToDhall (f :+: g), GenericToDhall h) => GenericToDhall ((f :+: g) :+: M1 C c h) where + genericToDhallWithNormalizer inputNormalizer options@(InterpretOptions {..}) = pure (Encoder {..}) + where + embed (L1 l) = + case maybeValL of + Nothing -> Field declared $ Core.makeFieldSelection keyL + Just valL -> App (Field declared $ Core.makeFieldSelection keyL) valL + where + (keyL, maybeValL) = + unsafeExpectUnionLit "genericToDhallWithNormalizer (:+:)" (embedL l) + embed (R1 (M1 r)) = + case notEmptyRecordLit (embedR r) of + Nothing -> Field declared $ Core.makeFieldSelection keyR + Just valR -> App (Field declared $ Core.makeFieldSelection keyR) valR + + nR :: M1 i c h a + nR = undefined + + keyR = constructorModifier (Data.Text.pack (conName nR)) + + declared = Union (Dhall.Map.insert keyR (notEmptyRecord declaredR) ktsL) + + Encoder embedL declaredL = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 + Encoder embedR declaredR = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 + + ktsL = unsafeExpectUnion "genericToDhallWithNormalizer (:+:)" declaredL + +instance (Constructor c, GenericToDhall f, GenericToDhall (g :+: h)) => GenericToDhall (M1 C c f :+: (g :+: h)) where + genericToDhallWithNormalizer inputNormalizer options@(InterpretOptions {..}) = pure (Encoder {..}) + where + embed (L1 (M1 l)) = + case notEmptyRecordLit (embedL l) of + Nothing -> Field declared $ Core.makeFieldSelection keyL + Just valL -> App (Field declared $ Core.makeFieldSelection keyL) valL + embed (R1 r) = + case maybeValR of + Nothing -> Field declared $ Core.makeFieldSelection keyR + Just valR -> App (Field declared $ Core.makeFieldSelection keyR) valR + where + (keyR, maybeValR) = + unsafeExpectUnionLit "genericToDhallWithNormalizer (:+:)" (embedR r) + + nL :: M1 i c f a + nL = undefined + + keyL = constructorModifier (Data.Text.pack (conName nL)) + + declared = Union (Dhall.Map.insert keyL (notEmptyRecord declaredL) ktsR) + + Encoder embedL declaredL = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 + Encoder embedR declaredR = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 + + ktsR = unsafeExpectUnion "genericToDhallWithNormalizer (:+:)" declaredR + +instance (GenericToDhall (f :+: g), GenericToDhall (h :+: i)) => GenericToDhall ((f :+: g) :+: (h :+: i)) where + genericToDhallWithNormalizer inputNormalizer options = pure (Encoder {..}) + where + embed (L1 l) = + case maybeValL of + Nothing -> Field declared $ Core.makeFieldSelection keyL + Just valL -> App (Field declared $ Core.makeFieldSelection keyL) valL + where + (keyL, maybeValL) = + unsafeExpectUnionLit "genericToDhallWithNormalizer (:+:)" (embedL l) + embed (R1 r) = + case maybeValR of + Nothing -> Field declared $ Core.makeFieldSelection keyR + Just valR -> App (Field declared $ Core.makeFieldSelection keyR) valR + where + (keyR, maybeValR) = + unsafeExpectUnionLit "genericToDhallWithNormalizer (:+:)" (embedR r) + + declared = Union (Dhall.Map.union ktsL ktsR) + + Encoder embedL declaredL = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 + Encoder embedR declaredR = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 + + ktsL = unsafeExpectUnion "genericToDhallWithNormalizer (:+:)" declaredL + ktsR = unsafeExpectUnion "genericToDhallWithNormalizer (:+:)" declaredR + +instance (GenericToDhall (f :*: g), GenericToDhall (h :*: i)) => GenericToDhall ((f :*: g) :*: (h :*: i)) where + genericToDhallWithNormalizer inputNormalizer options = do + Encoder embedL declaredL <- genericToDhallWithNormalizer inputNormalizer options + Encoder embedR declaredR <- genericToDhallWithNormalizer inputNormalizer options + + let embed (l :*: r) = + RecordLit (Dhall.Map.union mapL mapR) + where + mapL = + unsafeExpectRecordLit "genericToDhallWithNormalizer (:*:)" (embedL l) + + mapR = + unsafeExpectRecordLit "genericToDhallWithNormalizer (:*:)" (embedR r) + + let declared = Record (Dhall.Map.union mapL mapR) + where + mapL = unsafeExpectRecord "genericToDhallWithNormalizer (:*:)" declaredL + mapR = unsafeExpectRecord "genericToDhallWithNormalizer (:*:)" declaredR + + pure (Encoder {..}) + +instance (GenericToDhall (f :*: g), Selector s, ToDhall a) => GenericToDhall ((f :*: g) :*: M1 S s (K1 i a)) where + genericToDhallWithNormalizer inputNormalizer options@InterpretOptions{..} = do + let nR :: M1 S s (K1 i a) r + nR = undefined + + nameR <- fmap fieldModifier (getSelName nR) + + Encoder embedL declaredL <- genericToDhallWithNormalizer inputNormalizer options + + let Encoder embedR declaredR = injectWith inputNormalizer + + let embed (l :*: M1 (K1 r)) = + RecordLit (Dhall.Map.insert nameR (Core.makeRecordField $ embedR r) mapL) + where + mapL = + unsafeExpectRecordLit "genericToDhallWithNormalizer (:*:)" (embedL l) + + let declared = Record (Dhall.Map.insert nameR (Core.makeRecordField declaredR) mapL) + where + mapL = unsafeExpectRecord "genericToDhallWithNormalizer (:*:)" declaredL + + return (Encoder {..}) + +instance (Selector s, ToDhall a, GenericToDhall (f :*: g)) => GenericToDhall (M1 S s (K1 i a) :*: (f :*: g)) where + genericToDhallWithNormalizer inputNormalizer options@InterpretOptions{..} = do + let nL :: M1 S s (K1 i a) r + nL = undefined + + nameL <- fmap fieldModifier (getSelName nL) + + let Encoder embedL declaredL = injectWith inputNormalizer + + Encoder embedR declaredR <- genericToDhallWithNormalizer inputNormalizer options + + let embed (M1 (K1 l) :*: r) = + RecordLit (Dhall.Map.insert nameL (Core.makeRecordField $ embedL l) mapR) + where + mapR = + unsafeExpectRecordLit "genericToDhallWithNormalizer (:*:)" (embedR r) + + let declared = Record (Dhall.Map.insert nameL (Core.makeRecordField declaredL) mapR) + where + mapR = unsafeExpectRecord "genericToDhallWithNormalizer (:*:)" declaredR + + return (Encoder {..}) + +instance (Selector s1, Selector s2, ToDhall a1, ToDhall a2) => GenericToDhall (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where + genericToDhallWithNormalizer inputNormalizer InterpretOptions{..} = do + let nL :: M1 S s1 (K1 i1 a1) r + nL = undefined + + let nR :: M1 S s2 (K1 i2 a2) r + nR = undefined + + nameL <- fmap fieldModifier (getSelName nL) + nameR <- fmap fieldModifier (getSelName nR) + + let Encoder embedL declaredL = injectWith inputNormalizer + let Encoder embedR declaredR = injectWith inputNormalizer + + let embed (M1 (K1 l) :*: M1 (K1 r)) = + RecordLit $ + Dhall.Map.fromList + [ (nameL, Core.makeRecordField $ embedL l) + , (nameR, Core.makeRecordField $ embedR r) ] + + + let declared = + Record $ Dhall.Map.fromList + [ (nameL, Core.makeRecordField declaredL) + , (nameR, Core.makeRecordField declaredR) ] + + + return (Encoder {..}) + +instance GenericToDhall U1 where + genericToDhallWithNormalizer _ _ = pure (Encoder {..}) + where + embed _ = RecordLit mempty + + declared = Record mempty + +{-| Use the default options for injecting a value, whose structure is +determined generically. + +This can be used when you want to use 'ToDhall' on types that you don't +want to define orphan instances for. +-} +genericToDhall + :: (Generic a, GenericToDhall (Rep a)) => Encoder a +genericToDhall + = genericToDhallWith defaultInterpretOptions + +{-| Use custom options for injecting a value, whose structure is +determined generically. + +This can be used when you want to use 'ToDhall' on types that you don't +want to define orphan instances for. +-} +genericToDhallWith + :: (Generic a, GenericToDhall (Rep a)) => InterpretOptions -> Encoder a +genericToDhallWith options + = contramap GHC.Generics.from (evalState (genericToDhallWithNormalizer defaultInputNormalizer options) 1) + + + +{-| The 'RecordEncoder' divisible (contravariant) functor allows you to build + an 'Encoder' for a Dhall record. + + For example, let's take the following Haskell data type: + +>>> :{ +data Project = Project + { projectName :: Text + , projectDescription :: Text + , projectStars :: Natural + } +:} + + And assume that we have the following Dhall record that we would like to + parse as a @Project@: + +> { name = +> "dhall-haskell" +> , description = +> "A configuration language guaranteed to terminate" +> , stars = +> 289 +> } + + Our encoder has type 'Encoder' @Project@, but we can't build that out of any + smaller encoders, as 'Encoder's cannot be combined (they are only 'Contravariant's). + However, we can use an 'RecordEncoder' to build an 'Encoder' for @Project@: + +>>> :{ +injectProject :: Encoder Project +injectProject = + recordEncoder + ( adapt >$< encodeFieldWith "name" inject + >*< encodeFieldWith "description" inject + >*< encodeFieldWith "stars" inject + ) + where + adapt (Project{..}) = (projectName, (projectDescription, projectStars)) +:} + + Or, since we are simply using the `ToDhall` instance to inject each field, we could write + +>>> :{ +injectProject :: Encoder Project +injectProject = + recordEncoder + ( adapt >$< encodeField "name" + >*< encodeField "description" + >*< encodeField "stars" + ) + where + adapt (Project{..}) = (projectName, (projectDescription, projectStars)) +:} + +-} +newtype RecordEncoder a + = RecordEncoder (Dhall.Map.Map Text (Encoder a)) + +instance Contravariant RecordEncoder where + contramap f (RecordEncoder encodeTypeRecord) = RecordEncoder $ contramap f <$> encodeTypeRecord + +instance Divisible RecordEncoder where + divide f (RecordEncoder bEncoderRecord) (RecordEncoder cEncoderRecord) = + RecordEncoder + $ Dhall.Map.union + ((contramap $ fst . f) <$> bEncoderRecord) + ((contramap $ snd . f) <$> cEncoderRecord) + conquer = RecordEncoder mempty + +-- | Convert a `RecordEncoder` into the equivalent `Encoder`. +recordEncoder :: RecordEncoder a -> Encoder a +recordEncoder (RecordEncoder encodeTypeRecord) = Encoder makeRecordLit recordType + where + recordType = Record $ (Core.makeRecordField . declared) <$> encodeTypeRecord + makeRecordLit x = RecordLit $ (Core.makeRecordField . ($ x) . embed) <$> encodeTypeRecord + +{-| Specify how to encode one field of a record using the default `ToDhall` + instance for that type. +-} +encodeField :: ToDhall a => Text -> RecordEncoder a +encodeField name = encodeFieldWith name inject + +{-| Specify how to encode one field of a record by supplying an explicit + `Encoder` for that field. +-} +encodeFieldWith :: Text -> Encoder a -> RecordEncoder a +encodeFieldWith name encodeType = RecordEncoder $ Dhall.Map.singleton name encodeType + + + +{-| 'UnionEncoder' allows you to build an 'Encoder' for a Dhall record. + + For example, let's take the following Haskell data type: + +>>> :{ +data Status = Queued Natural + | Result Text + | Errored Text +:} + + And assume that we have the following Dhall union that we would like to + parse as a @Status@: + +> < Result : Text +> | Queued : Natural +> | Errored : Text +> >.Result "Finish successfully" + + Our encoder has type 'Encoder' @Status@, but we can't build that out of any + smaller encoders, as 'Encoder's cannot be combined. + However, we can use an 'UnionEncoder' to build an 'Encoder' for @Status@: + +>>> :{ +injectStatus :: Encoder Status +injectStatus = adapt >$< unionEncoder + ( encodeConstructorWith "Queued" inject + >|< encodeConstructorWith "Result" inject + >|< encodeConstructorWith "Errored" inject + ) + where + adapt (Queued n) = Left n + adapt (Result t) = Right (Left t) + adapt (Errored e) = Right (Right e) +:} + + Or, since we are simply using the `ToDhall` instance to inject each branch, we could write + +>>> :{ +injectStatus :: Encoder Status +injectStatus = adapt >$< unionEncoder + ( encodeConstructor "Queued" + >|< encodeConstructor "Result" + >|< encodeConstructor "Errored" + ) + where + adapt (Queued n) = Left n + adapt (Result t) = Right (Left t) + adapt (Errored e) = Right (Right e) +:} + +-} +newtype UnionEncoder a = + UnionEncoder + ( Data.Functor.Product.Product + ( Control.Applicative.Const + ( Dhall.Map.Map + Text + ( Expr Src Void ) + ) + ) + ( Op (Text, Expr Src Void) ) + a + ) + deriving (Contravariant) + +-- | Convert a `UnionEncoder` into the equivalent `Encoder`. +unionEncoder :: UnionEncoder a -> Encoder a +unionEncoder ( UnionEncoder ( Data.Functor.Product.Pair ( Control.Applicative.Const fields ) ( Op embedF ) ) ) = + Encoder + { embed = \x -> + let (name, y) = embedF x + in case notEmptyRecordLit y of + Nothing -> Field (Union fields') $ Core.makeFieldSelection name + Just val -> App (Field (Union fields') $ Core.makeFieldSelection name) val + , declared = + Union fields' + } + where + fields' = fmap notEmptyRecord fields + +{-| Specify how to encode an alternative by using the default `ToDhall` instance + for that type. +-} +encodeConstructor + :: ToDhall a + => Text + -> UnionEncoder a +encodeConstructor name = encodeConstructorWith name inject + +{-| Specify how to encode an alternative by providing an explicit `Encoder` + for that alternative. +-} +encodeConstructorWith + :: Text + -> Encoder a + -> UnionEncoder a +encodeConstructorWith name encodeType = UnionEncoder $ + Data.Functor.Product.Pair + ( Control.Applicative.Const + ( Dhall.Map.singleton + name + ( declared encodeType ) + ) + ) + ( Op ( (name,) . embed encodeType ) + ) + +-- | Combines two 'UnionEncoder' values. See 'UnionEncoder' for usage +-- notes. +-- +-- Ideally, this matches 'Data.Functor.Contravariant.Divisible.chosen'; +-- however, this allows 'UnionEncoder' to not need a 'Divisible' instance +-- itself (since no instance is possible). +(>|<) :: UnionEncoder a -> UnionEncoder b -> UnionEncoder (Either a b) +UnionEncoder (Data.Functor.Product.Pair (Control.Applicative.Const mx) (Op fx)) + >|< UnionEncoder (Data.Functor.Product.Pair (Control.Applicative.Const my) (Op fy)) = + UnionEncoder + ( Data.Functor.Product.Pair + ( Control.Applicative.Const (mx <> my) ) + ( Op (either fx fy) ) + ) + +infixr 5 >|< + + + +-- | Infix 'divided' +(>*<) :: Divisible f => f a -> f b -> f (a, b) +(>*<) = divided + +infixr 5 >*< diff --git a/src/Dhall/Marshal/Internal.hs b/src/Dhall/Marshal/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Marshal/Internal.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +{-| Please read the "Dhall.Tutorial" module, which contains a tutorial explaining + how to use the language, the compiler, and this library +-} + +module Dhall.Marshal.Internal + ( InputNormalizer(..) + , defaultInputNormalizer + , InterpretOptions(..) + , SingletonConstructors(..) + , defaultInterpretOptions + + -- * Miscellaneous + , Result(..) + + -- * Helpers for the generic deriving machinery + , getSelName + , notEmptyRecord + , notEmptyRecordLit + , unsafeExpectRecord + , unsafeExpectRecordLit + , unsafeExpectUnion + , unsafeExpectUnionLit + + -- * Re-exports + , Fix(..) + , HashMap + , Map + , Natural + , Scientific + , Seq + , Text + , Vector + , Void + , Word8 + , Word16 + , Word32 + , Word64 + , Generic + ) where + +import Control.Monad.Trans.State.Strict +import Data.Fix (Fix (..)) +import Data.HashMap.Strict (HashMap) +import Data.Map (Map) +import Data.Scientific (Scientific) +import Data.Sequence (Seq) +import Data.Text (Text) +import Data.Vector (Vector) +import Data.Void (Void) +import Data.Word (Word16, Word32, Word64, Word8) +import Dhall.Parser (Src (..)) +import Dhall.Syntax (Expr (..), RecordField (..)) +import GHC.Generics +import Numeric.Natural (Natural) +import Prelude hiding (maybe, sequence) + +import qualified Data.Text +import qualified Dhall.Core as Core +import qualified Dhall.Map + +{-| This type is exactly the same as `Data.Fix.Fix` except with a different + `Dhall.Marshal.Decode.FromDhall` instance. This intermediate type + simplifies the implementation of the inner loop for the + `Dhall.Marshal.Decode.FromDhall` instance for `Fix`. +-} +newtype Result f = Result { _unResult :: f (Result f) } + +{-| Use these options to tweak how Dhall derives a generic implementation of + `Dhall.Marshal.Decode.FromDhall`. +-} +data InterpretOptions = InterpretOptions + { fieldModifier :: Text -> Text + -- ^ Function used to transform Haskell field names into their corresponding + -- Dhall field names + , constructorModifier :: Text -> Text + -- ^ Function used to transform Haskell constructor names into their + -- corresponding Dhall alternative names + , singletonConstructors :: SingletonConstructors + -- ^ Specify how to handle constructors with only one field. The default is + -- `Smart` + } + +{-| This is only used by the `Dhall.Marshal.Decode.FromDhall` instance for + functions in order to normalize the function input before marshaling the + input into a Dhall expression. +-} +newtype InputNormalizer = InputNormalizer + { getInputNormalizer :: Core.ReifiedNormalizer Void } + +-- | Default normalization-related settings (no custom normalization) +defaultInputNormalizer :: InputNormalizer +defaultInputNormalizer = InputNormalizer + { getInputNormalizer = Core.ReifiedNormalizer (const (pure Nothing)) } + +{-| This type specifies how to model a Haskell constructor with 1 field in + Dhall + + For example, consider the following Haskell datatype definition: + + > data Example = Foo { x :: Double } | Bar Double + + Depending on which option you pick, the corresponding Dhall type could be: + + > < Foo : Double | Bar : Double > -- Bare + + > < Foo : { x : Double } | Bar : { _1 : Double } > -- Wrapped + + > < Foo : { x : Double } | Bar : Double > -- Smart +-} +data SingletonConstructors + = Bare + -- ^ Never wrap the field in a record + | Wrapped + -- ^ Always wrap the field in a record + | Smart + -- ^ Only fields in a record if they are named + +{-| Default interpret options for generics-based instances, + which you can tweak or override, like this: + +> genericAutoWith +> (defaultInterpretOptions { fieldModifier = Data.Text.Lazy.dropWhile (== '_') }) +-} +defaultInterpretOptions :: InterpretOptions +defaultInterpretOptions = InterpretOptions + { fieldModifier = + id + , constructorModifier = + id + , singletonConstructors = + Smart + } + +unsafeExpectUnion + :: Text -> Expr Src Void -> Dhall.Map.Map Text (Maybe (Expr Src Void)) +unsafeExpectUnion _ (Union kts) = + kts +unsafeExpectUnion name expression = + Core.internalError + (name <> ": Unexpected constructor: " <> Core.pretty expression) + +unsafeExpectRecord + :: Text -> Expr Src Void -> Dhall.Map.Map Text (RecordField Src Void) +unsafeExpectRecord _ (Record kts) = + kts +unsafeExpectRecord name expression = + Core.internalError + (name <> ": Unexpected constructor: " <> Core.pretty expression) + +unsafeExpectUnionLit + :: Text + -> Expr Src Void + -> (Text, Maybe (Expr Src Void)) +unsafeExpectUnionLit _ (Field (Union _) (Core.fieldSelectionLabel -> k)) = + (k, Nothing) +unsafeExpectUnionLit _ (App (Field (Union _) (Core.fieldSelectionLabel -> k)) v) = + (k, Just v) +unsafeExpectUnionLit name expression = + Core.internalError + (name <> ": Unexpected constructor: " <> Core.pretty expression) + +unsafeExpectRecordLit + :: Text -> Expr Src Void -> Dhall.Map.Map Text (RecordField Src Void) +unsafeExpectRecordLit _ (RecordLit kvs) = + kvs +unsafeExpectRecordLit name expression = + Core.internalError + (name <> ": Unexpected constructor: " <> Core.pretty expression) + +notEmptyRecordLit :: Expr s a -> Maybe (Expr s a) +notEmptyRecordLit e = case e of + RecordLit m | null m -> Nothing + _ -> Just e + +notEmptyRecord :: Expr s a -> Maybe (Expr s a) +notEmptyRecord e = case e of + Record m | null m -> Nothing + _ -> Just e + +getSelName :: Selector s => M1 i s f a -> State Int Text +getSelName n = case selName n of + "" -> do i <- get + put (i + 1) + pure (Data.Text.pack ("_" ++ show i)) + nn -> pure (Data.Text.pack nn) diff --git a/src/Dhall/Normalize.hs b/src/Dhall/Normalize.hs --- a/src/Dhall/Normalize.hs +++ b/src/Dhall/Normalize.hs @@ -668,11 +668,11 @@ t' <- loop t pure (Assert t') - Equivalent l r -> do + Equivalent cs l r -> do l' <- loop l r' <- loop r - pure (Equivalent l' r') + pure (Equivalent cs l' r') With e ks v -> do e' <- loop e v' <- loop v @@ -917,7 +917,7 @@ Record _ -> False _ -> loop e' Assert t -> loop t - Equivalent l r -> loop l && loop r + Equivalent _ l r -> loop l && loop r With{} -> False Note _ e' -> loop e' ImportAlt _ _ -> False diff --git a/src/Dhall/Parser/Expression.hs b/src/Dhall/Parser/Expression.hs --- a/src/Dhall/Parser/Expression.hs +++ b/src/Dhall/Parser/Expression.hs @@ -10,7 +10,6 @@ import Control.Applicative (Alternative (..), liftA2, optional) import Data.ByteArray.Encoding (Base (..)) import Data.Foldable (foldl') -import Data.Functor (void) import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) import Dhall.Src (Src (..)) @@ -113,8 +112,18 @@ parsers :: forall a. Parser a -> Parsers a parsers embedded = Parsers {..} where - completeExpression_ = whitespace *> expression <* whitespace + completeExpression_ = + many shebang *> whitespace *> expression <* whitespace + shebang = do + _ <- text "#!" + + let predicate c = ('\x20' <= c && c <= '\x10FFFF') || c == '\t' + + _ <- Dhall.Parser.Combinators.takeWhile predicate + + endOfLine + expression = noted ( choice @@ -341,7 +350,7 @@ operatorParsers :: [Parser (Expr s a -> Expr s a -> Expr s a)] operatorParsers = - [ Equivalent <$ _equivalent <* whitespace + [ Equivalent . Just <$> _equivalent <* whitespace , ImportAlt <$ _importAlt <* nonemptyWhitespace , BoolOr <$ _or <* whitespace , NaturalPlus <$ _plus <* nonemptyWhitespace @@ -350,7 +359,7 @@ , BoolAnd <$ _and <* whitespace , (\cs -> Combine (Just cs) Nothing) <$> _combine <* whitespace , (\cs -> Prefer (Just cs) PreferFromSource) <$> _prefer <* whitespace - , (CombineTypes . Just) <$> _combineTypes <* whitespace + , CombineTypes . Just <$> _combineTypes <* whitespace , NaturalTimes <$ _times <* whitespace -- Make sure that `==` is not actually the prefix of `===` , BoolEQ <$ try (_doubleEqual <* Text.Megaparsec.notFollowedBy (char '=')) <* whitespace @@ -718,7 +727,7 @@ , unescapedCharacterFast , unescapedCharacterSlow , tab - , endOfLine + , endOfLine_ ] where escapeSingleQuotes = do @@ -757,7 +766,7 @@ where predicate c = c == '$' || c == '\'' - endOfLine = do + endOfLine_ = do a <- "\n" <|> "\r\n" b <- singleQuoteContinue return (Chunks [] a <> b) @@ -769,12 +778,12 @@ singleQuoteLiteral = do _ <- text "''" + _ <- endOfLine + a <- singleQuoteContinue return (Dhall.Syntax.toDoubleQuoted a) - where - endOfLine = (void (char '\n') <|> void (text "\r\n")) "newline" textLiteral = (do literal <- doubleQuotedLiteral <|> singleQuoteLiteral diff --git a/src/Dhall/Parser/Token.hs b/src/Dhall/Parser/Token.hs --- a/src/Dhall/Parser/Token.hs +++ b/src/Dhall/Parser/Token.hs @@ -4,6 +4,7 @@ -- | Parse Dhall tokens. Even though we don't have a tokenizer per-se this --- module is useful for keeping some small parsing utilities. module Dhall.Parser.Token ( + endOfLine, validCodepoint, whitespace, lineComment, @@ -135,6 +136,12 @@ import Numeric.Natural (Natural) +-- | Match an end-of-line character sequence +endOfLine :: Parser Text +endOfLine = + ( Text.Parser.Char.text "\n" + <|> Text.Parser.Char.text "\r\n" + ) "newline" -- | Returns `True` if the given `Int` is a valid Unicode codepoint validCodepoint :: Int -> Bool @@ -360,14 +367,9 @@ commentText <- Dhall.Parser.Combinators.takeWhile predicate - endOfLine + _ <- endOfLine return ("--" <> commentText) - where - endOfLine = - ( void (Text.Parser.Char.char '\n' ) - <|> void (Text.Parser.Char.text "\r\n") - ) "newline" -- | Parsed text doesn't include opening braces blockComment :: Parser Text @@ -396,8 +398,6 @@ where predicate c = '\x20' <= c && c <= '\x10FFFF' || c == '\n' || c == '\t' - endOfLine = (Text.Parser.Char.text "\r\n" "newline") - blockCommentContinue :: Parser Text blockCommentContinue = endOfComment <|> continue where @@ -1207,8 +1207,10 @@ _at = reservedChar '@' "\"@\"" -- | Parse the equivalence symbol (@===@ or @≡@) -_equivalent :: Parser () -_equivalent = (void (char '≡' "\"≡\"") <|> void (text "===")) "operator" +_equivalent :: Parser CharacterSet +_equivalent = + (Unicode <$ char '≡' "\"≡\"") + <|> (ASCII <$ text "===" "===") -- | Parse the @missing@ keyword _missing :: Parser () diff --git a/src/Dhall/Pretty/Internal.hs b/src/Dhall/Pretty/Internal.hs --- a/src/Dhall/Pretty/Internal.hs +++ b/src/Dhall/Pretty/Internal.hs @@ -153,6 +153,7 @@ Combine (Just Unicode) _ _ _ -> Unicode CombineTypes (Just Unicode) _ _ -> Unicode Prefer (Just Unicode) _ _ _ -> Unicode + Equivalent (Just Unicode) _ _ -> Unicode _ -> mempty -- | Pretty print an expression @@ -927,10 +928,10 @@ spacer = if Text.length op == 1 then " " else " " prettyEquivalentExpression :: Pretty a => Expr Src a -> Doc Ann - prettyEquivalentExpression a0@(Equivalent _ _) = + prettyEquivalentExpression a0@(Equivalent _ _ _) = prettyOperator (equivalent characterSet) (docs a0) where - docs (Equivalent a b) = prettyImportAltExpression b : docs a + docs (Equivalent _ a b) = prettyImportAltExpression b : docs a docs a | Just doc <- preserveSource a = [ doc ] diff --git a/src/Dhall/Schemas.hs b/src/Dhall/Schemas.hs --- a/src/Dhall/Schemas.hs +++ b/src/Dhall/Schemas.hs @@ -27,7 +27,7 @@ import Dhall.Syntax (Expr (..), Import, Var (..)) import Dhall.Util ( Censor (..) - , CheckFailed (..) + , MultipleCheckFailed (..) , Header (..) , Input (..) , OutputMode (..) @@ -68,11 +68,11 @@ -- | Implementation of the @dhall rewrite-with-schemas@ subcommand schemasCommand :: Schemas -> IO () schemasCommand Schemas{..} = do - originalText <- case input of - InputFile file -> Text.IO.readFile file - StandardInput -> Text.IO.getContents + (inputName, originalText) <- case input of + InputFile file -> (,) file <$> Text.IO.readFile file + StandardInput -> (,) "(input)" <$> Text.IO.getContents - (Header header, expression) <- Util.getExpressionAndHeaderFromStdinText censor originalText + (Header header, expression) <- Util.getExpressionAndHeaderFromStdinText censor inputName originalText let characterSet = fromMaybe (detectCharacterSet expression) chosenCharacterSet @@ -115,7 +115,9 @@ let modified = "rewritten" - Exception.throwIO CheckFailed{..} + let inputs = pure input + + Exception.throwIO MultipleCheckFailed{..} decodeSchema :: Expr s Void -> Maybe (Expr s Void, Map Text (Expr s Void)) decodeSchema (RecordLit m) diff --git a/src/Dhall/Syntax.hs b/src/Dhall/Syntax.hs --- a/src/Dhall/Syntax.hs +++ b/src/Dhall/Syntax.hs @@ -440,10 +440,10 @@ -- | > Var (V x 0) ~ x -- > Var (V x n) ~ x@n | Var Var - -- | > Lam (FunctionBinding _ "x" _ _ A) b ~ λ(x : A) -> b + -- | > Lam _ (FunctionBinding _ "x" _ _ A) b ~ λ(x : A) -> b | Lam (Maybe CharacterSet) (FunctionBinding s a) (Expr s a) - -- | > Pi "_" A B ~ A -> B - -- > Pi x A B ~ ∀(x : A) -> B + -- | > Pi _ "_" A B ~ A -> B + -- > Pi _ x A B ~ ∀(x : A) -> B | Pi (Maybe CharacterSet) Text (Expr s a) (Expr s a) -- | > App f a ~ f a | App (Expr s a) (Expr s a) @@ -581,7 +581,7 @@ | RecordLit (Map Text (RecordField s a)) -- | > Union [(k1, Just t1), (k2, Nothing)] ~ < k1 : t1 | k2 > | Union (Map Text (Maybe (Expr s a))) - -- | > Combine Nothing x y ~ x ∧ y + -- | > Combine _ Nothing x y ~ x ∧ y -- -- The first field is a `Just` when the `Combine` operator is introduced -- as a result of desugaring duplicate record fields: @@ -592,9 +592,9 @@ -- > (Combine (Just k) x y) -- > )] | Combine (Maybe CharacterSet) (Maybe Text) (Expr s a) (Expr s a) - -- | > CombineTypes x y ~ x ⩓ y + -- | > CombineTypes _ x y ~ x ⩓ y | CombineTypes (Maybe CharacterSet) (Expr s a) (Expr s a) - -- | > Prefer False x y ~ x ⫽ y + -- | > Prefer _ False x y ~ x ⫽ y -- -- The first field is a `True` when the `Prefer` operator is introduced as a -- result of desugaring a @with@ expression @@ -614,8 +614,8 @@ | Project (Expr s a) (Either [Text] (Expr s a)) -- | > Assert e ~ assert : e | Assert (Expr s a) - -- | > Equivalent x y ~ x ≡ y - | Equivalent (Expr s a) (Expr s a) + -- | > Equivalent _ x y ~ x ≡ y + | Equivalent (Maybe CharacterSet) (Expr s a) (Expr s a) -- | > With x y e ~ x with y = e | With (Expr s a) (NonEmpty Text) (Expr s a) -- | > Note s x ~ e @@ -842,7 +842,7 @@ unsafeSubExpressions f (ToMap a t) = ToMap <$> f a <*> traverse f t unsafeSubExpressions f (Project a b) = Project <$> f a <*> traverse f b unsafeSubExpressions f (Assert a) = Assert <$> f a -unsafeSubExpressions f (Equivalent a b) = Equivalent <$> f a <*> f b +unsafeSubExpressions f (Equivalent cs a b) = Equivalent cs <$> f a <*> f b unsafeSubExpressions f (With a b c) = With <$> f a <*> pure b <*> f c unsafeSubExpressions f (ImportAlt l r) = ImportAlt <$> f l <*> f r unsafeSubExpressions _ (Let {}) = unhandledConstructor "Let" @@ -1083,8 +1083,16 @@ pretty (ImportHashed Nothing p) = Pretty.pretty p pretty (ImportHashed (Just h) p) = - Pretty.pretty p <> " sha256:" <> Pretty.pretty (show h) + Pretty.group (Pretty.flatAlt long short) + where + long = + Pretty.align + ( Pretty.pretty p <> Pretty.hardline + <> " sha256:" <> Pretty.pretty (show h) + ) + short = Pretty.pretty p <> " sha256:" <> Pretty.pretty (show h) + -- | Reference to an external resource data Import = Import { importHashed :: ImportHashed @@ -1138,6 +1146,7 @@ Lam _ a b -> Lam Nothing (denoteFunctionBinding a) (denote b) Pi _ t a b -> Pi Nothing t (denote a) (denote b) Field a (FieldSelection _ b _) -> Field (denote a) (FieldSelection Nothing b Nothing) + Equivalent _ a b -> Equivalent Nothing (denote a) (denote b) expression -> Lens.over unsafeSubExpressions denote expression where denoteRecordField (RecordField _ e _ _) = RecordField Nothing (denote e) Nothing Nothing diff --git a/src/Dhall/TH.hs b/src/Dhall/TH.hs --- a/src/Dhall/TH.hs +++ b/src/Dhall/TH.hs @@ -8,6 +8,7 @@ module Dhall.TH ( -- * Template Haskell staticDhallExpression + , dhall , makeHaskellTypeFromUnion , makeHaskellTypes , HaskellType(..) @@ -18,7 +19,7 @@ import Dhall (FromDhall, ToDhall) import Dhall.Syntax (Expr (..)) import GHC.Generics (Generic) -import Language.Haskell.TH.Quote (dataToExpQ) +import Language.Haskell.TH.Quote (QuasiQuoter (..), dataToExpQ) import Language.Haskell.TH.Syntax ( Bang (..) @@ -82,6 +83,23 @@ -- A workaround for a problem in TemplateHaskell (see -- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable) liftText = fmap (AppE (VarE 'Text.pack)) . Syntax.lift . Text.unpack + +{-| A quasi-quoter for Dhall expressions. + + This quoter is build on top of 'staticDhallExpression'. Therefore consult the + documentation of that function for further information. + + This quoter is meant to be used in expression context only; Other contexts + like pattern contexts or declaration contexts are not supported and will + result in an error. +-} +dhall :: QuasiQuoter +dhall = QuasiQuoter + { quoteExp = staticDhallExpression . Text.pack + , quotePat = const $ error "dhall quasi-quoter: Quoting patterns is not supported!" + , quoteType = const $ error "dhall quasi-quoter: Quoting types is not supported!" + , quoteDec = const $ error "dhall quasi-quoter: Quoting declarations is not supported!" + } {-| Convert a Dhall type to a Haskell type that does not require any new data declarations beyond the data declarations supplied as the first diff --git a/src/Dhall/Tutorial.hs b/src/Dhall/Tutorial.hs --- a/src/Dhall/Tutorial.hs +++ b/src/Dhall/Tutorial.hs @@ -1619,7 +1619,7 @@ -- > let replicate = https://prelude.dhall-lang.org/List/replicate -- > in replicate 5 -- > $ --- > $ dhall freeze --inplace ./foo.dhall +-- > $ dhall freeze ./foo.dhall -- > $ cat ./foo.dhall -- > let replicate = -- > https://prelude.dhall-lang.org/List/replicate sha256:d4250b45278f2d692302489ac3e78280acb238d27541c837ce46911ff3baa347 @@ -1744,10 +1744,9 @@ -- > (List (List Natural)) -- > (replicate 5 (List Natural) (replicate 5 Natural 1)) -- --- You can also use the formatter to modify files in place using the --- @--inplace@ flag (i.e. for formatting source code): +-- You can also use the formatter to modify files in place: -- --- > $ dhall format --inplace ./unformatted +-- > $ dhall format ./unformatted -- -- Carefully note that the code formatter does not preserve all comments. -- Currently, the formatter only preserves two types of comments: diff --git a/src/Dhall/TypeCheck.hs b/src/Dhall/TypeCheck.hs --- a/src/Dhall/TypeCheck.hs +++ b/src/Dhall/TypeCheck.hs @@ -1225,7 +1225,7 @@ _ -> die (NotAnEquivalence _T) - Equivalent x y -> do + Equivalent _ x y -> do _A₀' <- loop ctx x let _A₀'' = quote names _A₀' diff --git a/src/Dhall/Util.hs b/src/Dhall/Util.hs --- a/src/Dhall/Util.hs +++ b/src/Dhall/Util.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} -- | Shared utility functions @@ -10,7 +12,6 @@ , _ERROR , Censor(..) , Input(..) - , PossiblyTransitiveInput(..) , Transitivity(..) , OutputMode(..) , Output(..) @@ -19,11 +20,16 @@ , getExpressionAndHeaderFromStdinText , Header(..) , CheckFailed(..) + , MultipleCheckFailed(..) + , handleMultipleChecksFailed ) where import Control.Exception (Exception (..)) import Control.Monad.IO.Class (MonadIO (..)) import Data.Bifunctor (first) +import Data.Either (lefts) +import Data.Foldable (toList) +import Data.List.NonEmpty (NonEmpty (..)) import Data.String (IsString) import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty) @@ -112,13 +118,13 @@ case input of Input_ (InputFile file) -> Data.Text.IO.readFile file Input_ StandardInput -> Data.Text.IO.getContents - StdinText text -> pure text + StdinText _ text -> pure text let name = case input of Input_ (InputFile file) -> file Input_ StandardInput -> "(input)" - StdinText _ -> "(input)" + StdinText inputName _ -> inputName let result = parser name inText @@ -140,17 +146,14 @@ data Censor = NoCensor | Censor -- | Path to input -data Input = StandardInput | InputFile FilePath +data Input = StandardInput | InputFile FilePath deriving (Eq) -- | Path to input or raw input text, necessary since we can't read STDIN twice -data InputOrTextFromStdin = Input_ Input | StdinText Text - -{-| For utilities that may want to process transitive dependencies, like - @dhall freeze@ --} -data PossiblyTransitiveInput - = NonTransitiveStandardInput - | PossiblyTransitiveInputFile FilePath Transitivity +data InputOrTextFromStdin + = Input_ Input + | StdinText String Text + -- ^ @StdinText name text@ where name is a user-friendly name describing the + -- input expression, used in parsing error messages {-| Specifies whether or not an input's transitive dependencies should also be processed. Transitive dependencies are restricted to relative file imports. @@ -170,15 +173,25 @@ -} data OutputMode = Write | Check +-- | A check failure corresponding to a single input. +-- This type is intended to be used with 'MultipleCheckFailed' for error +-- reporting. +newtype CheckFailed = CheckFailed { input :: Input } + -- | Exception thrown when the @--check@ flag to a command-line subcommand fails -data CheckFailed = CheckFailed { command :: Text, modified :: Text } +data MultipleCheckFailed = MultipleCheckFailed + { command :: Text + , modified :: Text + , inputs :: NonEmpty Input + } -instance Exception CheckFailed +instance Exception MultipleCheckFailed -instance Show CheckFailed where - show CheckFailed{..} = - _ERROR <> ": ❰dhall " <> command_ <> " --check❱ failed\n\ - \\n\ +instance Show MultipleCheckFailed where + show MultipleCheckFailed{..} = + _ERROR <> ": ❰dhall " <> command_ <> " --check❱ failed on:\n\ + \\n" <> files <> + "\n\ \You ran ❰dhall " <> command_ <> " --check❱, but the input appears to have not\n\ \been " <> modified_ <> " before, or was changed since the last time the input\n\ \was " <> modified_ <> ".\n" @@ -187,6 +200,32 @@ command_ = Data.Text.unpack command + files = unlines . map format $ toList inputs + + format input = case input of + StandardInput -> "↳ (stdin)" + InputFile file -> "↳ " <> file + +-- | Run IO for multiple inputs, then collate all the check failures before +-- throwing if there was any failure +handleMultipleChecksFailed + :: (Foldable t, Traversable t) + => Text + -> Text + -> (a -> IO (Either CheckFailed ())) + -> t a + -> IO () +handleMultipleChecksFailed command modified f xs = post =<< mapM f xs + where + post results = + case lefts (toList results) of + [] -> pure () + cf:cfs -> Control.Exception.throwIO $ MultipleCheckFailed + { command + , modified + , inputs = fmap input (cf:|cfs) + } + -- | Convenient utility for retrieving an expression getExpression :: Censor -> Input -> IO (Expr Src Import) getExpression censor = get Dhall.Parser.exprFromText censor . Input_ @@ -199,6 +238,6 @@ -- | Convenient utility for retrieving an expression along with its header from -- | text already read from STDIN (so it's not re-read) getExpressionAndHeaderFromStdinText - :: Censor -> Text -> IO (Header, Expr Src Import) -getExpressionAndHeaderFromStdinText censor = - get Dhall.Parser.exprAndHeaderFromText censor . StdinText + :: Censor -> String -> Text -> IO (Header, Expr Src Import) +getExpressionAndHeaderFromStdinText censor inputName = + get Dhall.Parser.exprAndHeaderFromText censor . StdinText inputName diff --git a/tests/Dhall/Test/Import.hs b/tests/Dhall/Test/Import.hs --- a/tests/Dhall/Test/Import.hs +++ b/tests/Dhall/Test/Import.hs @@ -1,11 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module Dhall.Test.Import where import Control.Exception (SomeException) import Data.Text (Text) -import Dhall.Import (MissingImports (..)) -import Dhall.Parser (SourcedException (..)) import Prelude hiding (FilePath) import Test.Tasty (TestTree) import Turtle (FilePath, ()) @@ -53,8 +52,17 @@ return path ) - failureTests <- Test.Util.discover (Turtle.chars <> ".dhall") failureTest (Turtle.lstree (importDirectory "failure")) + failureTests <- Test.Util.discover (Turtle.chars <> ".dhall") failureTest (do + path <- Turtle.lstree (importDirectory "failure") + let expectedSuccesses = + [ importDirectory "failure/unit/DontRecoverCycle.dhall" + , importDirectory "failure/unit/DontRecoverTypeError.dhall" + ] + + Monad.guard (path `notElem` expectedSuccesses) + return path ) + let testTree = Tasty.testGroup "import tests" [ successTests @@ -69,7 +77,13 @@ let directoryString = FilePath.takeDirectory pathString - let expectedFailures = [] + let expectedFailures = + [ importDirectory "success/unit/cors/TwoHopsA.dhall" + , importDirectory "success/unit/cors/SelfImportAbsoluteA.dhall" + , importDirectory "success/unit/cors/AllowedAllA.dhall" + , importDirectory "success/unit/cors/SelfImportRelativeA.dhall" + , importDirectory "success/unit/cors/OnlyGithubA.dhall" + ] Test.Util.testCase path expectedFailures (do @@ -79,10 +93,6 @@ let originalCache = "dhall-lang/tests/import/cache" - let setCache = Turtle.export "XDG_CACHE_HOME" - - let unsetCache = Turtle.unset "XDG_CACHE_HOME" - let httpManager = HTTP.newManager HTTP.tlsManagerSettings @@ -94,24 +104,43 @@ let usesCache = [ "hashFromCacheA.dhall" , "unit/asLocation/HashA.dhall" - , "unit/IgnorePoisonedCacheA.dhall"] + , "unit/IgnorePoisonedCacheA.dhall" + , "unit/DontCacheIfHashA.dhall" + ] - let endsIn path' = not $ null $ Turtle.match (Turtle.ends path') path + let endsIn path' = + not (null (Turtle.match (Turtle.ends path') (Test.Util.toDhallPath path))) let buildNewCache = do - tempdir <- Turtle.mktempdir "/tmp" "dhall-cache" - Turtle.liftIO $ Turtle.cptree originalCache tempdir - return tempdir + tempdir <- Turtle.mktempdir "/tmp" "dhall-cache" + Turtle.liftIO (Turtle.cptree originalCache tempdir) + return tempdir let runTest = if any endsIn usesCache then Turtle.runManaged $ do cacheDir <- buildNewCache - setCache $ Turtle.format Turtle.fp cacheDir + + let set = do + m <- Turtle.need "XDG_CACHE_HOME" + + Turtle.export "XDG_CACHE_HOME" (Turtle.format Turtle.fp cacheDir) + + return m + + let reset Nothing = do + Turtle.unset "XDG_CACHE_HOME" + reset (Just x) = do + Turtle.export "XDG_CACHE_HOME" x + + _ <- Turtle.managed (Exception.bracket set reset) + _ <- Turtle.liftIO load - unsetCache + + return () else do _ <- load + return () let handler :: SomeException -> IO () @@ -130,8 +159,12 @@ actualExpr <- Core.throws (Parser.exprFromText mempty text) - Exception.catch + succeeded <- Exception.catch @SomeException (do _ <- Test.Util.load actualExpr + return True + ) + (\_ -> return False) - fail "Import should have failed, but it succeeds") - (\(SourcedException _ (MissingImports _)) -> pure ()) ) + if succeeded + then fail "Import should have failed, but it succeeds" + else return () ) diff --git a/tests/format/ipfsB.dhall b/tests/format/ipfsB.dhall --- a/tests/format/ipfsB.dhall +++ b/tests/format/ipfsB.dhall @@ -11,7 +11,8 @@ labels.{ `app.kubernetes.io/name`, `app.kubernetes.io/instance` } let k8s = - https://raw.githubusercontent.com/dhall-lang/dhall-kubernetes/4ab28225a150498aef67c226d3c5f026c95b5a1e/package.dhall sha256:2c7ac35494f16b1f39afcf3467b2f3b0ab579edb0c711cddd2c93f1cbed358bd + https://raw.githubusercontent.com/dhall-lang/dhall-kubernetes/4ab28225a150498aef67c226d3c5f026c95b5a1e/package.dhall + sha256:2c7ac35494f16b1f39afcf3467b2f3b0ab579edb0c711cddd2c93f1cbed358bd let serviceName = "ipfs" diff --git a/tests/format/issue1400-2B.dhall b/tests/format/issue1400-2B.dhall --- a/tests/format/issue1400-2B.dhall +++ b/tests/format/issue1400-2B.dhall @@ -3,7 +3,8 @@ = λ(a : Type) → { field : Text , nesting : - ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335 + ./Nesting + sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335 ? ./Nesting , contents : a } diff --git a/tests/format/sha256PrintingB.dhall b/tests/format/sha256PrintingB.dhall --- a/tests/format/sha256PrintingB.dhall +++ b/tests/format/sha256PrintingB.dhall @@ -1,4 +1,5 @@ let replicate = - https://raw.githubusercontent.com/dhall-lang/Prelude/c79c2bc3c46f129cc5b6d594ce298a381bcae92c/List/replicate sha256:cc856d59b63f7699881bdb8e4b1036ca4c0013827268040a50c1e1405f646a2c + https://raw.githubusercontent.com/dhall-lang/Prelude/c79c2bc3c46f129cc5b6d594ce298a381bcae92c/List/replicate + sha256:cc856d59b63f7699881bdb8e4b1036ca4c0013827268040a50c1e1405f646a2c in replicate 5 diff --git a/tests/freeze/cachedB.dhall b/tests/freeze/cachedB.dhall --- a/tests/freeze/cachedB.dhall +++ b/tests/freeze/cachedB.dhall @@ -1,2 +1,3 @@ - ./True.dhall sha256:27abdeddfe8503496adeb623466caa47da5f63abd2bc6fa19f6cfcb73ecfed70 + ./True.dhall + sha256:27abdeddfe8503496adeb623466caa47da5f63abd2bc6fa19f6cfcb73ecfed70 ? ./True.dhall diff --git a/tests/freeze/incorrectHashB.dhall b/tests/freeze/incorrectHashB.dhall --- a/tests/freeze/incorrectHashB.dhall +++ b/tests/freeze/incorrectHashB.dhall @@ -1,2 +1,3 @@ - ./True.dhall sha256:27abdeddfe8503496adeb623466caa47da5f63abd2bc6fa19f6cfcb73ecfed70 + ./True.dhall + sha256:27abdeddfe8503496adeb623466caa47da5f63abd2bc6fa19f6cfcb73ecfed70 ? ./True.dhall diff --git a/tests/freeze/protectedB.dhall b/tests/freeze/protectedB.dhall --- a/tests/freeze/protectedB.dhall +++ b/tests/freeze/protectedB.dhall @@ -1,2 +1,3 @@ - ./True.dhall sha256:27abdeddfe8503496adeb623466caa47da5f63abd2bc6fa19f6cfcb73ecfed70 + ./True.dhall + sha256:27abdeddfe8503496adeb623466caa47da5f63abd2bc6fa19f6cfcb73ecfed70 ? ./True.dhall diff --git a/tests/freeze/unprotectedB.dhall b/tests/freeze/unprotectedB.dhall --- a/tests/freeze/unprotectedB.dhall +++ b/tests/freeze/unprotectedB.dhall @@ -1,2 +1,3 @@ - ./True.dhall sha256:27abdeddfe8503496adeb623466caa47da5f63abd2bc6fa19f6cfcb73ecfed70 + ./True.dhall + sha256:27abdeddfe8503496adeb623466caa47da5f63abd2bc6fa19f6cfcb73ecfed70 ? ./True.dhall