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

Support standard version 3.0.0 and drop support for older versions (#634)

Browse Source 
See the discussion in https://github.com/dhall-lang/dhall-lang/issues/242
and the corresponding change the standard in
https://github.com/dhall-lang/dhall-lang/pull/243 for more context.

At some point we want to extend support for older versions of the standard
as far back as possible, but in order to do this correctly we need to
provide a way to systematically thread the standard version to everything
that we standardize, including:

* type-checking
* β-normalization
* α-normalization
* import resolution
* binary encoding/decoding

... and that entails a significant refactor to the API.

Given that we need to cut a new release soon, I've decided to drop support for
older releases for now.  We may eventually add them back as a matter of
principle to exercise backwards compatibility, albeit I expect that people are
unlikely to use them again once we drop support for them once.

This also changes `ProtocolVersion` to `StandardVersion` everywhere in the API
and the command line for consistency with the change to the standard, since
there is no longer a protocol version now that we use the standard version to
version everything.
This commit is contained in:
Gabriel Gonzalez 2018-10-12 14:00:10 -07:00 committed by GitHub
parent afffa17be4
commit d9713ca54c
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
13 changed files with 368 additions and 368 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
benchmark/dhall-command/Main.hs
View File

@ -4,7 +4,7 @@
module Main where
import qualified Dhall.Main as Main
import Dhall.Binary (defaultProtocolVersion)
import Dhall.Binary (defaultStandardVersion)
options :: Main.Options
options = Main.Options
@ -12,7 +12,7 @@ options = Main.Options
, Main.explain = False
, Main.plain = False
, Main.ascii = False
, Main.protocolVersion = defaultProtocolVersion
, Main.standardVersion = defaultStandardVersion
}
main :: IO ()

2
benchmark/parser/Main.hs
View File

@ -72,7 +72,7 @@ benchExprFromBytes name bytes = bench name (whnf f bytes)
term <- case Codec.Serialise.deserialiseOrFail bytes of
Left _ -> Nothing
Right term -> return term
case Dhall.Binary.decode term of
case Dhall.Binary.decodeWithVersion term of
Left _ -> Nothing
Right expression -> return expression

24
src/Dhall.hs
View File

@ -28,7 +28,7 @@ module Dhall
, sourceName
, startingContext
, normalizer
, protocolVersion
, standardVersion
, defaultInputSettings
, InputSettings
, defaultEvaluateSettings
@ -97,7 +97,7 @@ import Data.Text (Text)
import Data.Typeable (Typeable)
import Data.Vector (Vector)
import Data.Word (Word8, Word16, Word32, Word64)
import Dhall.Binary (ProtocolVersion(..))
import Dhall.Binary (StandardVersion(..))
import Dhall.Core (Expr(..), Chunks(..))
import Dhall.Import (Imported(..))
import Dhall.Parser (Src(..))
@ -201,7 +201,7 @@ sourceName k s =
data EvaluateSettings = EvaluateSettings
{ _startingContext :: Dhall.Context.Context (Expr Src X)
, _normalizer :: Dhall.Core.ReifiedNormalizer X
, _protocolVersion :: ProtocolVersion
, _standardVersion :: StandardVersion
}
-- | Default evaluation settings: no extra entries in the initial
@ -212,7 +212,7 @@ defaultEvaluateSettings :: EvaluateSettings
defaultEvaluateSettings = EvaluateSettings
{ _startingContext = Dhall.Context.empty
, _normalizer = Dhall.Core.ReifiedNormalizer (const Nothing)
, _protocolVersion = Dhall.Binary.defaultProtocolVersion
, _standardVersion = Dhall.Binary.defaultStandardVersion
}
-- | Access the starting context used for evaluation and type-checking.
@ -239,16 +239,16 @@ normalizer = evaluateSettings . l
=> LensLike' f EvaluateSettings (Dhall.Core.ReifiedNormalizer X)
l k s = fmap (\x -> s { _normalizer = x }) (k (_normalizer s))
-- | Access the protocol version used when encoding or decoding Dhall
-- expressions to and from a binary representation
-- | Access the standard version (used primarily when encoding or decoding
-- Dhall expressions to and from a binary representation)
--
-- @since 1.17
protocolVersion
standardVersion
:: (Functor f, HasEvaluateSettings s)
=> LensLike' f s ProtocolVersion
protocolVersion = evaluateSettings . l
=> LensLike' f s StandardVersion
standardVersion = evaluateSettings . l
where
l k s = fmap (\x -> s { _protocolVersion = x}) (k (_protocolVersion s))
l k s = fmap (\x -> s { _standardVersion = x}) (k (_standardVersion s))
-- | @since 1.16
class HasEvaluateSettings s where
@ -312,7 +312,7 @@ inputWithSettings settings (Type {..}) txt = do
let EvaluateSettings {..} = _evaluateSettings
let transform =
set Dhall.Import.protocolVersion _protocolVersion
set Dhall.Import.standardVersion _standardVersion
. set Dhall.Import.normalizer _normalizer
. set Dhall.Import.startingContext _startingContext
@ -405,7 +405,7 @@ inputExprWithSettings settings txt = do
let EvaluateSettings {..} = _evaluateSettings
let transform =
set Dhall.Import.protocolVersion _protocolVersion
set Dhall.Import.standardVersion _standardVersion
. set Dhall.Import.normalizer _normalizer
. set Dhall.Import.startingContext _startingContext

586
src/Dhall/Binary.hs
View File

@ -7,14 +7,14 @@
-}
module Dhall.Binary
( -- * Protocol versions
ProtocolVersion(..)
, defaultProtocolVersion
, parseProtocolVersion
( -- * Standard versions
StandardVersion(..)
, defaultStandardVersion
, parseStandardVersion
-- * Encoding and decoding
, encode
, decode
, encodeWithVersion
, decodeWithVersion
-- * Exceptions
, DecodingFailure(..)
@ -51,30 +51,28 @@ import qualified Data.Text
import qualified Dhall.Map
import qualified Options.Applicative
-- | Supported protocol version strings
data ProtocolVersion
= V_1_0
-- ^ Protocol version string "1.0"
| V_1_1
-- ^ Protocol version string "1.1"
-- | Supported version strings
data StandardVersion
= V_3_0_0
-- ^ Version "3.0.0"
defaultProtocolVersion :: ProtocolVersion
defaultProtocolVersion = V_1_1
defaultStandardVersion :: StandardVersion
defaultStandardVersion = V_3_0_0
parseProtocolVersion :: Parser ProtocolVersion
parseProtocolVersion =
Options.Applicative.option readProtocolVersion
( Options.Applicative.long "protocol-version"
<> Options.Applicative.metavar "X.Y"
<> Options.Applicative.value defaultProtocolVersion
parseStandardVersion :: Parser StandardVersion
parseStandardVersion =
Options.Applicative.option readVersion
( Options.Applicative.long "standard-version"
<> Options.Applicative.metavar "X.Y.Z"
<> Options.Applicative.help "The standard version to use"
<> Options.Applicative.value defaultStandardVersion
)
where
readProtocolVersion = do
readVersion = do
string <- Options.Applicative.str
case string :: Text of
"1.0" -> return V_1_0
"1.1" -> return V_1_1
_ -> fail "Unsupported protocol version"
"3.0.0" -> return V_3_0_0
_ -> fail "Unsupported version"
{-| Convert a function applied to multiple arguments to the base function and
the list of arguments
@ -89,250 +87,250 @@ unApply e = (baseFunction₀, diffArguments₀ [])
~(baseFunction, diffArguments) = go f
go baseFunction = (baseFunction, id)
encode_1_1 :: Expr s Import -> Term
encode_1_1 (Var (V "_" n)) =
encode :: Expr s Import -> Term
encode (Var (V "_" n)) =
TInteger n
encode_1_1 (Var (V x 0)) =
encode (Var (V x 0)) =
TString x
encode_1_1 (Var (V x n)) =
encode (Var (V x n)) =
TList [ TString x, TInteger n ]
encode_1_1 NaturalBuild =
encode NaturalBuild =
TString "Natural/build"
encode_1_1 NaturalFold =
encode NaturalFold =
TString "Natural/fold"
encode_1_1 NaturalIsZero =
encode NaturalIsZero =
TString "Natural/isZero"
encode_1_1 NaturalEven =
encode NaturalEven =
TString "Natural/even"
encode_1_1 NaturalOdd =
encode NaturalOdd =
TString "Natural/odd"
encode_1_1 NaturalToInteger =
encode NaturalToInteger =
TString "Natural/toInteger"
encode_1_1 NaturalShow =
encode NaturalShow =
TString "Natural/show"
encode_1_1 IntegerToDouble =
encode IntegerToDouble =
TString "Integer/toDouble"
encode_1_1 IntegerShow =
encode IntegerShow =
TString "Integer/show"
encode_1_1 DoubleShow =
encode DoubleShow =
TString "Double/show"
encode_1_1 ListBuild =
encode ListBuild =
TString "List/build"
encode_1_1 ListFold =
encode ListFold =
TString "List/fold"
encode_1_1 ListLength =
encode ListLength =
TString "List/length"
encode_1_1 ListHead =
encode ListHead =
TString "List/head"
encode_1_1 ListLast =
encode ListLast =
TString "List/last"
encode_1_1 ListIndexed =
encode ListIndexed =
TString "List/indexed"
encode_1_1 ListReverse =
encode ListReverse =
TString "List/reverse"
encode_1_1 OptionalFold =
encode OptionalFold =
TString "Optional/fold"
encode_1_1 OptionalBuild =
encode OptionalBuild =
TString "Optional/build"
encode_1_1 Bool =
encode Bool =
TString "Bool"
encode_1_1 Optional =
encode Optional =
TString "Optional"
encode_1_1 None =
encode None =
TString "None"
encode_1_1 Natural =
encode Natural =
TString "Natural"
encode_1_1 Integer =
encode Integer =
TString "Integer"
encode_1_1 Double =
encode Double =
TString "Double"
encode_1_1 Text =
encode Text =
TString "Text"
encode_1_1 List =
encode List =
TString "List"
encode_1_1 (Const Type) =
encode (Const Type) =
TString "Type"
encode_1_1 (Const Kind) =
encode (Const Kind) =
TString "Kind"
encode_1_1 e@(App _ _) =
TList ([ TInt 0, f₁ ] ++ map encode_1_1 arguments)
encode e@(App _ _) =
TList ([ TInt 0, f₁ ] ++ map encode arguments)
where
(f₀, arguments) = unApply e
f₁ = encode_1_1 f₀
encode_1_1 (Lam "_" _A₀ b₀) =
f₁ = encode f₀
encode (Lam "_" _A₀ b₀) =
TList [ TInt 1, _A₁, b₁ ]
where
_A₁ = encode_1_1 _A₀
b₁ = encode_1_1 b₀
encode_1_1 (Lam x _A₀ b₀) =
_A₁ = encode _A₀
b₁ = encode b₀
encode (Lam x _A₀ b₀) =
TList [ TInt 1, TString x, _A₁, b₁ ]
where
_A₁ = encode_1_1 _A₀
b₁ = encode_1_1 b₀
encode_1_1 (Pi "_" _A₀ _B₀) =
_A₁ = encode _A₀
b₁ = encode b₀
encode (Pi "_" _A₀ _B₀) =
TList [ TInt 2, _A₁, _B₁ ]
where
_A₁ = encode_1_1 _A₀
_B₁ = encode_1_1 _B₀
encode_1_1 (Pi x _A₀ _B₀) =
_A₁ = encode _A₀
_B₁ = encode _B₀
encode (Pi x _A₀ _B₀) =
TList [ TInt 2, TString x, _A₁, _B₁ ]
where
_A₁ = encode_1_1 _A₀
_B₁ = encode_1_1 _B₀
encode_1_1 (BoolOr l₀ r₀) =
_A₁ = encode _A₀
_B₁ = encode _B₀
encode (BoolOr l₀ r₀) =
TList [ TInt 3, TInt 0, l₁, r₁ ]
where
l₁ = encode_1_1 l₀
r₁ = encode_1_1 r₀
encode_1_1 (BoolAnd l₀ r₀) =
l₁ = encode l₀
r₁ = encode r₀
encode (BoolAnd l₀ r₀) =
TList [ TInt 3, TInt 1, l₁, r₁ ]
where
l₁ = encode_1_1 l₀
r₁ = encode_1_1 r₀
encode_1_1 (BoolEQ l₀ r₀) =
l₁ = encode l₀
r₁ = encode r₀
encode (BoolEQ l₀ r₀) =
TList [ TInt 3, TInt 2, l₁, r₁ ]
where
l₁ = encode_1_1 l₀
r₁ = encode_1_1 r₀
encode_1_1 (BoolNE l₀ r₀) =
l₁ = encode l₀
r₁ = encode r₀
encode (BoolNE l₀ r₀) =
TList [ TInt 3, TInt 3, l₁, r₁ ]
where
l₁ = encode_1_1 l₀
r₁ = encode_1_1 r₀
encode_1_1 (NaturalPlus l₀ r₀) =
l₁ = encode l₀
r₁ = encode r₀
encode (NaturalPlus l₀ r₀) =
TList [ TInt 3, TInt 4, l₁, r₁ ]
where
l₁ = encode_1_1 l₀
r₁ = encode_1_1 r₀
encode_1_1 (NaturalTimes l₀ r₀) =
l₁ = encode l₀
r₁ = encode r₀
encode (NaturalTimes l₀ r₀) =
TList [ TInt 3, TInt 5, l₁, r₁ ]
where
l₁ = encode_1_1 l₀
r₁ = encode_1_1 r₀
encode_1_1 (TextAppend l₀ r₀) =
l₁ = encode l₀
r₁ = encode r₀
encode (TextAppend l₀ r₀) =
TList [ TInt 3, TInt 6, l₁, r₁ ]
where
l₁ = encode_1_1 l₀
r₁ = encode_1_1 r₀
encode_1_1 (ListAppend l₀ r₀) =
l₁ = encode l₀
r₁ = encode r₀
encode (ListAppend l₀ r₀) =
TList [ TInt 3, TInt 7, l₁, r₁ ]
where
l₁ = encode_1_1 l₀
r₁ = encode_1_1 r₀
encode_1_1 (Combine l₀ r₀) =
l₁ = encode l₀
r₁ = encode r₀
encode (Combine l₀ r₀) =
TList [ TInt 3, TInt 8, l₁, r₁ ]
where
l₁ = encode_1_1 l₀
r₁ = encode_1_1 r₀
encode_1_1 (Prefer l₀ r₀) =
l₁ = encode l₀
r₁ = encode r₀
encode (Prefer l₀ r₀) =
TList [ TInt 3, TInt 9, l₁, r₁ ]
where
l₁ = encode_1_1 l₀
r₁ = encode_1_1 r₀
encode_1_1 (CombineTypes l₀ r₀) =
l₁ = encode l₀
r₁ = encode r₀
encode (CombineTypes l₀ r₀) =
TList [ TInt 3, TInt 10, l₁, r₁ ]
where
l₁ = encode_1_1 l₀
r₁ = encode_1_1 r₀
encode_1_1 (ImportAlt l₀ r₀) =
l₁ = encode l₀
r₁ = encode r₀
encode (ImportAlt l₀ r₀) =
TList [ TInt 3, TInt 11, l₁, r₁ ]
where
l₁ = encode_1_1 l₀
r₁ = encode_1_1 r₀
encode_1_1 (ListLit _T₀ xs₀)
l₁ = encode l₀
r₁ = encode r₀
encode (ListLit _T₀ xs₀)
| null xs₀ = TList [ TInt 4, _T₁ ]
| otherwise = TList ([ TInt 4, TNull ] ++ xs₁)
where
_T₁ = case _T₀ of
Nothing -> TNull
Just t -> encode_1_1 t
Just t -> encode t
xs₁ = map encode_1_1 (Data.Foldable.toList xs₀)
encode_1_1 (OptionalLit _T₀ Nothing) =
xs₁ = map encode (Data.Foldable.toList xs₀)
encode (OptionalLit _T₀ Nothing) =
TList [ TInt 5, _T₁ ]
where
_T₁ = encode_1_1 _T₀
encode_1_1 (OptionalLit _T₀ (Just t₀)) =
_T₁ = encode _T₀
encode (OptionalLit _T₀ (Just t₀)) =
TList [ TInt 5, _T₁, t₁ ]
where
_T₁ = encode_1_1 _T₀
t₁ = encode_1_1 t₀
encode_1_1 (Some t₀) =
_T₁ = encode _T₀
t₁ = encode t₀
encode (Some t₀) =
TList [ TInt 5, TNull, t₁ ]
where
t₁ = encode_1_1 t₀
encode_1_1 (Merge t₀ u₀ Nothing) =
t₁ = encode t₀
encode (Merge t₀ u₀ Nothing) =
TList [ TInt 6, t₁, u₁ ]
where
t₁ = encode_1_1 t₀
u₁ = encode_1_1 u₀
encode_1_1 (Merge t₀ u₀ (Just _T₀)) =
t₁ = encode t₀
u₁ = encode u₀
encode (Merge t₀ u₀ (Just _T₀)) =
TList [ TInt 6, t₁, u₁, _T₁ ]
where
t₁ = encode_1_1 t₀
u₁ = encode_1_1 u₀
_T₁ = encode_1_1 _T₀
encode_1_1 (Record xTs₀) =
t₁ = encode t₀
u₁ = encode u₀
_T₁ = encode _T₀
encode (Record xTs₀) =
TList [ TInt 7, TMap xTs₁ ]
where
xTs₁ = do
(x₀, _T₀) <- Dhall.Map.toList xTs₀
let x₁ = TString x₀
let _T₁ = encode_1_1 _T₀
let _T₁ = encode _T₀
return (x₁, _T₁)
encode_1_1 (RecordLit xts₀) =
encode (RecordLit xts₀) =
TList [ TInt 8, TMap xts₁ ]
where
xts₁ = do
(x₀, t₀) <- Dhall.Map.toList xts₀
let x₁ = TString x₀
let t₁ = encode_1_1 t₀
let t₁ = encode t₀
return (x₁, t₁)
encode_1_1 (Field t₀ x) =
encode (Field t₀ x) =
TList [ TInt 9, t₁, TString x ]
where
t₁ = encode_1_1 t₀
encode_1_1 (Project t₀ xs₀) =
t₁ = encode t₀
encode (Project t₀ xs₀) =
TList ([ TInt 10, t₁ ] ++ xs₁)
where
t₁ = encode_1_1 t₀
t₁ = encode t₀
xs₁ = map TString (Data.Foldable.toList xs₀)
encode_1_1 (Union xTs₀) =
encode (Union xTs₀) =
TList [ TInt 11, TMap xTs₁ ]
where
xTs₁ = do
(x₀, _T₀) <- Dhall.Map.toList xTs₀
let x₁ = TString x₀
let _T₁ = encode_1_1 _T₀
let _T₁ = encode _T₀
return (x₁, _T₁)
encode_1_1 (UnionLit x t₀ yTs₀) =
encode (UnionLit x t₀ yTs₀) =
TList [ TInt 12, TString x, t₁, TMap yTs₁ ]
where
t₁ = encode_1_1 t₀
t₁ = encode t₀
yTs₁ = do
(y₀, _T₀) <- Dhall.Map.toList yTs₀
let y₁ = TString y₀
let _T₁ = encode_1_1 _T₀
let _T₁ = encode _T₀
return (y₁, _T₁)
encode_1_1 (Constructors u₀) =
encode (Constructors u₀) =
TList [ TInt 13, u₁ ]
where
u₁ = encode_1_1 u₀
encode_1_1 (BoolLit b) =
u₁ = encode u₀
encode (BoolLit b) =
TBool b
encode_1_1 (BoolIf t₀ l₀ r₀) =
encode (BoolIf t₀ l₀ r₀) =
TList [ TInt 14, t₁, l₁, r₁ ]
where
t₁ = encode_1_1 t₀
l₁ = encode_1_1 l₀
r₁ = encode_1_1 r₀
encode_1_1 (NaturalLit n) =
t₁ = encode t₀
l₁ = encode l₀
r₁ = encode r₀
encode (NaturalLit n) =
TList [ TInt 15, TInteger (fromIntegral n) ]
encode_1_1 (IntegerLit n) =
encode (IntegerLit n) =
TList [ TInt 16, TInteger n ]
encode_1_1 (DoubleLit n) =
encode (DoubleLit n) =
TList [ TInt 17, TTagged 4 (TList [ TInt exponent, TInteger mantissa ]) ]
where
normalized = Data.Scientific.normalize n
@ -340,36 +338,36 @@ encode_1_1 (DoubleLit n) =
exponent = Data.Scientific.base10Exponent normalized
mantissa = Data.Scientific.coefficient normalized
encode_1_1 (TextLit (Chunks xys₀ z₀)) =
encode (TextLit (Chunks xys₀ z₀)) =
TList ([ TInt 18 ] ++ xys₁ ++ [ z₁ ])
where
xys₁ = do
(x₀, y₀) <- xys₀
let x₁ = TString x₀
let y₁ = encode_1_1 y₀
let y₁ = encode y₀
[ x₁, y₁ ]
z₁ = TString z₀
encode_1_1 (Embed x) =
encode (Embed x) =
importToTerm x
encode_1_1 (Let x Nothing a₀ b₀) =
encode (Let x Nothing a₀ b₀) =
TList [ TInt 25, TString x, a₁, b₁ ]
where
a₁ = encode_1_1 a₀
b₁ = encode_1_1 b₀
encode_1_1 (Let x (Just _A₀) a₀ b₀) =
a₁ = encode a₀
b₁ = encode b₀
encode (Let x (Just _A₀) a₀ b₀) =
TList [ TInt 25, TString x, _A₁, a₁, b₁ ]
where
a₁ = encode_1_1 a₀
_A₁ = encode_1_1 _A₀
b₁ = encode_1_1 b₀
encode_1_1 (Annot t₀ _T₀) =
a₁ = encode a₀
_A₁ = encode _A₀
b₁ = encode b₀
encode (Annot t₀ _T₀) =
TList [ TInt 26, t₁, _T₁ ]
where
t₁ = encode_1_1 t₀
_T₁ = encode_1_1 _T₀
encode_1_1 (Note _ e) =
encode_1_1 e
t₁ = encode t₀
_T₁ = encode _T₀
encode (Note _ e) =
encode e
importToTerm :: Import -> Term
importToTerm import_ =
@ -417,98 +415,98 @@ importToTerm import_ =
ImportHashed {..} = importHashed
decode_1_1 :: Term -> Maybe (Expr s Import)
decode_1_1 (TInt n) =
decode :: Term -> Maybe (Expr s Import)
decode (TInt n) =
return (Var (V "_" (fromIntegral n)))
decode_1_1 (TInteger n) =
decode (TInteger n) =
return (Var (V "_" n))
decode_1_1 (TString "Natural/build") =
decode (TString "Natural/build") =
return NaturalBuild
decode_1_1 (TString "Natural/fold") =
decode (TString "Natural/fold") =
return NaturalFold
decode_1_1 (TString "Natural/isZero") =
decode (TString "Natural/isZero") =
return NaturalIsZero
decode_1_1 (TString "Natural/even") =
decode (TString "Natural/even") =
return NaturalEven
decode_1_1 (TString "Natural/odd") =
decode (TString "Natural/odd") =
return NaturalOdd
decode_1_1 (TString "Natural/toInteger") =
decode (TString "Natural/toInteger") =
return NaturalToInteger
decode_1_1 (TString "Natural/show") =
decode (TString "Natural/show") =
return NaturalShow
decode_1_1 (TString "Integer/toDouble") =
decode (TString "Integer/toDouble") =
return IntegerToDouble
decode_1_1 (TString "Integer/show") =
decode (TString "Integer/show") =
return IntegerShow
decode_1_1 (TString "Double/show") =
decode (TString "Double/show") =
return DoubleShow
decode_1_1 (TString "List/build") =
decode (TString "List/build") =
return ListBuild
decode_1_1 (TString "List/fold") =
decode (TString "List/fold") =
return ListFold
decode_1_1 (TString "List/length") =
decode (TString "List/length") =
return ListLength
decode_1_1 (TString "List/head") =
decode (TString "List/head") =
return ListHead
decode_1_1 (TString "List/last") =
decode (TString "List/last") =
return ListLast
decode_1_1 (TString "List/indexed") =
decode (TString "List/indexed") =
return ListIndexed
decode_1_1 (TString "List/reverse") =
decode (TString "List/reverse") =
return ListReverse
decode_1_1 (TString "Optional/fold") =
decode (TString "Optional/fold") =
return OptionalFold
decode_1_1 (TString "Optional/build") =
decode (TString "Optional/build") =
return OptionalBuild
decode_1_1 (TString "Bool") =
decode (TString "Bool") =
return Bool
decode_1_1 (TString "Optional") =
decode (TString "Optional") =
return Optional
decode_1_1 (TString "None") =
decode (TString "None") =
return None
decode_1_1 (TString "Natural") =
decode (TString "Natural") =
return Natural
decode_1_1 (TString "Integer") =
decode (TString "Integer") =
return Integer
decode_1_1 (TString "Double") =
decode (TString "Double") =
return Double
decode_1_1 (TString "Text") =
decode (TString "Text") =
return Text
decode_1_1 (TString "List") =
decode (TString "List") =
return List
decode_1_1 (TString "Type") =
decode (TString "Type") =
return (Const Type)
decode_1_1 (TString "Kind") =
decode (TString "Kind") =
return (Const Kind)
decode_1_1 (TString x) =
decode (TString x) =
return (Var (V x 0))
decode_1_1 (TList [ TString x, TInt n ]) =
decode (TList [ TString x, TInt n ]) =
return (Var (V x (fromIntegral n)))
decode_1_1 (TList [ TString x, TInteger n ]) =
decode (TList [ TString x, TInteger n ]) =
return (Var (V x n))
decode_1_1 (TList (TInt 0 : f₁ : xs₁)) = do
f₀ <- decode_1_1 f₁
xs₀ <- traverse decode_1_1 xs₁
decode (TList (TInt 0 : f₁ : xs₁)) = do
f₀ <- decode f₁
xs₀ <- traverse decode xs₁
return (foldl App f₀ xs₀)
decode_1_1 (TList [ TInt 1, _A₁, b₁ ]) = do
_A₀ <- decode_1_1 _A₁
b₀ <- decode_1_1 b₁
decode (TList [ TInt 1, _A₁, b₁ ]) = do
_A₀ <- decode _A₁
b₀ <- decode b₁
return (Lam "_" _A₀ b₀)
decode_1_1 (TList [ TInt 1, TString x, _A₁, b₁ ]) = do
_A₀ <- decode_1_1 _A₁
b₀ <- decode_1_1 b₁
decode (TList [ TInt 1, TString x, _A₁, b₁ ]) = do
_A₀ <- decode _A₁
b₀ <- decode b₁
return (Lam x _A₀ b₀)
decode_1_1 (TList [ TInt 2, _A₁, _B₁ ]) = do
_A₀ <- decode_1_1 _A₁
_B₀ <- decode_1_1 _B₁
decode (TList [ TInt 2, _A₁, _B₁ ]) = do
_A₀ <- decode _A₁
_B₀ <- decode _B₁
return (Pi "_" _A₀ _B₀)
decode_1_1 (TList [ TInt 2, TString x, _A₁, _B₁ ]) = do
_A₀ <- decode_1_1 _A₁
_B₀ <- decode_1_1 _B₁
decode (TList [ TInt 2, TString x, _A₁, _B₁ ]) = do
_A₀ <- decode _A₁
_B₀ <- decode _B₁
return (Pi x _A₀ _B₀)
decode_1_1 (TList [ TInt 3, TInt n, l₁, r₁ ]) = do
l₀ <- decode_1_1 l₁
r₀ <- decode_1_1 r₁
decode (TList [ TInt 3, TInt n, l₁, r₁ ]) = do
l₀ <- decode l₁
r₀ <- decode r₁
op <- case n of
0 -> return BoolOr
1 -> return BoolAnd
@ -524,34 +522,34 @@ decode_1_1 (TList [ TInt 3, TInt n, l₁, r₁ ]) = do
11 -> return ImportAlt
_ -> empty
return (op l₀ r₀)
decode_1_1 (TList [ TInt 4, _T₁ ]) = do
_T₀ <- decode_1_1 _T₁
decode (TList [ TInt 4, _T₁ ]) = do
_T₀ <- decode _T₁
return (ListLit (Just _T₀) empty)
decode_1_1 (TList (TInt 4 : TNull : xs₁ )) = do
xs₀ <- traverse decode_1_1 xs₁
decode (TList (TInt 4 : TNull : xs₁ )) = do
xs₀ <- traverse decode xs₁
return (ListLit Nothing (Data.Sequence.fromList xs₀))
decode_1_1 (TList [ TInt 5, _T₁ ]) = do
_T₀ <- decode_1_1 _T₁
decode (TList [ TInt 5, _T₁ ]) = do
_T₀ <- decode _T₁
return (OptionalLit _T₀ Nothing)
decode_1_1 (TList [ TInt 5, TNull, t₁ ]) = do
t₀ <- decode_1_1 t₁
decode (TList [ TInt 5, TNull, t₁ ]) = do
t₀ <- decode t₁
return (Some t₀)
decode_1_1 (TList [ TInt 5, _T₁, t₁ ]) = do
_T₀ <- decode_1_1 _T₁
t₀ <- decode_1_1 t₁
decode (TList [ TInt 5, _T₁, t₁ ]) = do
_T₀ <- decode _T₁
t₀ <- decode t₁
return (OptionalLit _T₀ (Just t₀))
decode_1_1 (TList [ TInt 6, t₁, u₁ ]) = do
t₀ <- decode_1_1 t₁
u₀ <- decode_1_1 u₁
decode (TList [ TInt 6, t₁, u₁ ]) = do
t₀ <- decode t₁
u₀ <- decode u₁
return (Merge t₀ u₀ Nothing)
decode_1_1 (TList [ TInt 6, t₁, u₁, _T₁ ]) = do
t₀ <- decode_1_1 t₁
u₀ <- decode_1_1 u₁
_T₀ <- decode_1_1 _T₁
decode (TList [ TInt 6, t₁, u₁, _T₁ ]) = do
t₀ <- decode t₁
u₀ <- decode u₁
_T₀ <- decode _T₁
return (Merge t₀ u₀ (Just _T₀))
decode_1_1 (TList [ TInt 7, TMap xTs₁ ]) = do
decode (TList [ TInt 7, TMap xTs₁ ]) = do
let process (TString x, _T₁) = do
_T₀ <- decode_1_1 _T₁
_T₀ <- decode _T₁
return (x, _T₀)
process _ =
@ -560,9 +558,9 @@ decode_1_1 (TList [ TInt 7, TMap xTs₁ ]) = do
xTs₀ <- traverse process xTs₁
return (Record (Dhall.Map.fromList xTs₀))
decode_1_1 (TList [ TInt 8, TMap xts₁ ]) = do
decode (TList [ TInt 8, TMap xts₁ ]) = do
let process (TString x, t₁) = do
t₀ <- decode_1_1 t₁
t₀ <- decode t₁
return (x, t₀)
process _ =
@ -571,12 +569,12 @@ decode_1_1 (TList [ TInt 8, TMap xts₁ ]) = do
xts₀ <- traverse process xts₁
return (RecordLit (Dhall.Map.fromList xts₀))
decode_1_1 (TList [ TInt 9, t₁, TString x ]) = do
t₀ <- decode_1_1 t₁
decode (TList [ TInt 9, t₁, TString x ]) = do
t₀ <- decode t₁
return (Field t₀ x)
decode_1_1 (TList (TInt 10 : t₁ : xs₁)) = do
t₀ <- decode_1_1 t₁
decode (TList (TInt 10 : t₁ : xs₁)) = do
t₀ <- decode t₁
let process (TString x) = return x
process _ = empty
@ -584,9 +582,9 @@ decode_1_1 (TList (TInt 10 : t₁ : xs₁)) = do
xs₀ <- traverse process xs₁
return (Project t₀ (Data.Set.fromList xs₀))
decode_1_1 (TList [ TInt 11, TMap xTs₁ ]) = do
decode (TList [ TInt 11, TMap xTs₁ ]) = do
let process (TString x, _T₁) = do
_T₀ <- decode_1_1 _T₁
_T₀ <- decode _T₁
return (x, _T₀)
process _ =
@ -595,11 +593,11 @@ decode_1_1 (TList [ TInt 11, TMap xTs₁ ]) = do
xTs₀ <- traverse process xTs₁
return (Union (Dhall.Map.fromList xTs₀))
decode_1_1 (TList [ TInt 12, TString x, t₁, TMap yTs₁ ]) = do
t₀ <- decode_1_1 t₁
decode (TList [ TInt 12, TString x, t₁, TMap yTs₁ ]) = do
t₀ <- decode t₁
let process (TString y, _T₁) = do
_T₀ <- decode_1_1 _T₁
_T₀ <- decode _T₁
return (y, _T₀)
process _ =
@ -608,33 +606,33 @@ decode_1_1 (TList [ TInt 12, TString x, t₁, TMap yTs₁ ]) = do
yTs₀ <- traverse process yTs₁
return (UnionLit x t₀ (Dhall.Map.fromList yTs₀))
decode_1_1 (TList [ TInt 13, u₁ ]) = do
u₀ <- decode_1_1 u₁
decode (TList [ TInt 13, u₁ ]) = do
u₀ <- decode u₁
return (Constructors u₀)
decode_1_1 (TBool b) = do
decode (TBool b) = do
return (BoolLit b)
decode_1_1 (TList [ TInt 14, t₁, l₁, r₁ ]) = do
t₀ <- decode_1_1 t₁
l₀ <- decode_1_1 l₁
r₀ <- decode_1_1 r₁
decode (TList [ TInt 14, t₁, l₁, r₁ ]) = do
t₀ <- decode t₁
l₀ <- decode l₁
r₀ <- decode r₁
return (BoolIf t₀ l₀ r₀)
decode_1_1 (TList [ TInt 15, TInt n ]) = do
decode (TList [ TInt 15, TInt n ]) = do
return (NaturalLit (fromIntegral n))
decode_1_1 (TList [ TInt 15, TInteger n ]) = do
decode (TList [ TInt 15, TInteger n ]) = do
return (NaturalLit (fromInteger n))
decode_1_1 (TList [ TInt 16, TInt n ]) = do
decode (TList [ TInt 16, TInt n ]) = do
return (IntegerLit (fromIntegral n))
decode_1_1 (TList [ TInt 16, TInteger n ]) = do
decode (TList [ TInt 16, TInteger n ]) = do
return (IntegerLit n)
decode_1_1 (TList [ TInt 17, TTagged 4 (TList [ TInt exponent, TInteger mantissa ]) ]) = do
decode (TList [ TInt 17, TTagged 4 (TList [ TInt exponent, TInteger mantissa ]) ]) = do
return (DoubleLit (Data.Scientific.scientific mantissa exponent))
decode_1_1 (TList [ TInt 17, TTagged 4 (TList [ TInt exponent, TInt mantissa ]) ]) = do
decode (TList [ TInt 17, TTagged 4 (TList [ TInt exponent, TInt mantissa ]) ]) = do
return (DoubleLit (Data.Scientific.scientific (fromIntegral mantissa) exponent))
decode_1_1 (TList (TInt 18 : xs)) = do
decode (TList (TInt 18 : xs)) = do
let process (TString x : y₁ : zs) = do
y₀ <- decode_1_1 y₁
y₀ <- decode y₁
~(xys, z) <- process zs
@ -647,7 +645,7 @@ decode_1_1 (TList (TInt 18 : xs)) = do
(xys, z) <- process xs
return (TextLit (Chunks xys z))
decode_1_1 (TList (TInt 24 : TInt n : xs)) = do
decode (TList (TInt 24 : TInt n : xs)) = do
let remote scheme = do
let process [ TString file, q, f ] = do
query <- case q of
@ -720,57 +718,55 @@ decode_1_1 (TList (TInt 24 : TInt n : xs)) = do
let importHashed = ImportHashed {..}
let importMode = Code
return (Embed (Import {..}))
decode_1_1 (TList [ TInt 25, TString x, a₁, b₁ ]) = do
a₀ <- decode_1_1 a₁
b₀ <- decode_1_1 b₁
decode (TList [ TInt 25, TString x, a₁, b₁ ]) = do
a₀ <- decode a₁
b₀ <- decode b₁
return (Let x Nothing a₀ b₀)
decode_1_1 (TList [ TInt 25, TString x, _A₁, a₁, b₁ ]) = do
_A₀ <- decode_1_1 _A₁
a₀ <- decode_1_1 a₁
b₀ <- decode_1_1 b₁
decode (TList [ TInt 25, TString x, _A₁, a₁, b₁ ]) = do
_A₀ <- decode _A₁
a₀ <- decode a₁
b₀ <- decode b₁
return (Let x (Just _A₀) a₀ b₀)
decode_1_1 (TList [ TInt 26, t₁, _T₁ ]) = do
t₀ <- decode_1_1 t₁
_T₀ <- decode_1_1 _T₁
decode (TList [ TInt 26, t₁, _T₁ ]) = do
t₀ <- decode t₁
_T₀ <- decode _T₁
return (Annot t₀ _T₀)
decode_1_1 _ =
decode _ =
empty
{-| Decode a Dhall expression
This auto-detects whiich protocol version to decode based on the included
protocol version string in the decoded expression
This auto-detects which standard version to decode based on the included
standard version string in the decoded expression
-}
decode :: Term -> Either DecodingFailure (Expr s Import)
decode term = do
decodeWithVersion :: Term -> Either DecodingFailure (Expr s Import)
decodeWithVersion term = do
(version, subTerm) <- case term of
TList [ TString version, subTerm ] ->
return (version, subTerm)
_ ->
fail ("Cannot decode the version from this decoded CBOR expression: " <> show term)
maybeExpression <- case version of
"1.0" -> do
return (decode_1_1 subTerm)
"1.1" -> do
return (decode_1_1 subTerm)
case version of
"3.0.0" -> do
return ()
_ -> do
fail ("This decoded version is not supported: " <> Data.Text.unpack version)
case maybeExpression of
case decode subTerm of
Nothing ->
fail ("This decoded CBOR expression does not represent a valid Dhall expression: " <> show subTerm)
Just expression ->
return expression
-- | Encode a Dhall expression using the specified `ProtocolVersion`
encode :: ProtocolVersion -> Expr s Import -> Term
encode V_1_0 expression = TList [ TString "1.0", encode_1_1 expression ]
encode V_1_1 expression = TList [ TString "1.1", encode_1_1 expression ]
-- | Encode a Dhall expression using the specified `Version`
encodeWithVersion :: StandardVersion -> Expr s Import -> Term
encodeWithVersion V_3_0_0 expression =
TList [ TString "3.0.0", encode expression ]
data DecodingFailure
= CannotDecodeProtocolVersionString Term
| UnsupportedProtocolVersionString Text
= CannotDecodeVersionString Term
| UnsupportedVersionString Text
| CBORIsNotDhall Term
deriving (Eq)
@ -780,21 +776,21 @@ _ERROR :: String
_ERROR = "\ESC[1;31mError\ESC[0m"
instance Show DecodingFailure where
show (CannotDecodeProtocolVersionString term) =
show (CannotDecodeVersionString term) =
_ERROR <> ": Cannot decode version string\n"
<> "\n"
<> "This CBOR expression does not contain a protocol version string in any\n"
<> "This CBOR expression does not contain a version string in any\n"
<> "recognizable format\n"
<> "\n"
<> "↳ " <> show term <> "\n"
show (UnsupportedProtocolVersionString version) =
show (UnsupportedVersionString version) =
_ERROR <> ": Unsupported version string\n"
<> "\n"
<> "The encoded Dhall expression was tagged with a protocol version string of:\n"
<> "The encoded Dhall expression was tagged with a version string of:\n"
<> "\n"
<> "↳ " <> show version <> "\n"
<> "\n"
<> "... but this implementation cannot decode that protocol version\n"
<> "... but this implementation cannot decode that version\n"
<> "\n"
<> "Some common reasons why you might get this error:\n"
<> "\n"

18
src/Dhall/Freeze.hs
View File

@ -11,9 +11,9 @@ module Dhall.Freeze
import Data.Monoid ((<>))
import Data.Maybe (fromMaybe)
import Data.Text
import Dhall.Binary (ProtocolVersion(..))
import Dhall.Binary (StandardVersion(..))
import Dhall.Core (Expr(..), Import(..), ImportHashed(..))
import Dhall.Import (protocolVersion)
import Dhall.Import (standardVersion)
import Dhall.Parser (exprAndHeaderFromText, Src)
import Dhall.Pretty (annToAnsiStyle, layoutOpts)
import Lens.Family (set)
@ -34,11 +34,11 @@ import qualified System.IO
hashImport
:: FilePath
-- ^ Current working directory
-> ProtocolVersion
-> StandardVersion
-> Import
-> IO Import
hashImport directory _protocolVersion import_ = do
let status = set protocolVersion _protocolVersion (Dhall.Import.emptyStatus directory)
hashImport directory _standardVersion import_ = do
let status = set standardVersion _standardVersion (Dhall.Import.emptyStatus directory)
expression <- State.evalStateT (Dhall.Import.loadWith (Embed import_)) status
@ -50,7 +50,7 @@ hashImport directory _protocolVersion import_ = do
Dhall.Core.alphaNormalize (Dhall.Core.normalize expression)
let expressionHash =
Just (Dhall.Import.hashExpression _protocolVersion normalizedExpression)
Just (Dhall.Import.hashExpression _standardVersion normalizedExpression)
let newImportHashed = (importHashed import_) { hash = expressionHash }
@ -90,9 +90,9 @@ freeze
:: Maybe FilePath
-- ^ Modify file in-place if present, otherwise read from @stdin@ and write
-- to @stdout@
-> ProtocolVersion
-> StandardVersion
-> IO ()
freeze inplace _protocolVersion = do
freeze inplace _standardVersion = do
(text, directory) <- case inplace of
Nothing -> do
text <- Data.Text.IO.getContents
@ -105,7 +105,7 @@ freeze inplace _protocolVersion = do
return (text, System.FilePath.takeDirectory file)
(header, parsedExpression) <- parseExpr srcInfo text
frozenExpression <- traverse (hashImport directory _protocolVersion) parsedExpression
frozenExpression <- traverse (hashImport directory _standardVersion) parsedExpression
writeExpr inplace (header, frozenExpression)
where
srcInfo = fromMaybe "(stdin)" inplace

12
src/Dhall/Hash.hs
View File

@ -7,9 +7,9 @@ module Dhall.Hash
hash
) where
import Dhall.Binary (ProtocolVersion)
import Dhall.Binary (StandardVersion)
import Dhall.Parser (exprFromText)
import Dhall.Import (hashExpressionToCode, protocolVersion)
import Dhall.Import (hashExpressionToCode, standardVersion)
import Lens.Family (set)
import qualified Control.Monad.Trans.State.Strict as State
@ -20,8 +20,8 @@ import qualified Dhall.TypeCheck
import qualified Data.Text.IO
-- | Implementation of the @dhall hash@ subcommand
hash :: ProtocolVersion -> IO ()
hash _protocolVersion = do
hash :: StandardVersion -> IO ()
hash _standardVersion = do
inText <- Data.Text.IO.getContents
parsedExpression <- case exprFromText "(stdin)" inText of
@ -29,7 +29,7 @@ hash _protocolVersion = do
Right parsedExpression -> return parsedExpression
let status =
set protocolVersion _protocolVersion (Dhall.Import.emptyStatus ".")
set standardVersion _standardVersion (Dhall.Import.emptyStatus ".")
resolvedExpression <- State.evalStateT (Dhall.Import.loadWith parsedExpression) status
@ -41,4 +41,4 @@ hash _protocolVersion = do
Dhall.Core.alphaNormalize (Dhall.Core.normalize resolvedExpression)
Data.Text.IO.putStrLn
(hashExpressionToCode _protocolVersion normalizedExpression)
(hashExpressionToCode _standardVersion normalizedExpression)

31
src/Dhall/Import.hs
View File

@ -112,7 +112,7 @@ module Dhall.Import (
, stack
, cache
, manager
, protocolVersion
, standardVersion
, normalizer
, startingContext
, resolver
@ -145,7 +145,7 @@ import Data.Traversable (traverse)
#endif
import Data.Typeable (Typeable)
import System.FilePath ((</>))
import Dhall.Binary (ProtocolVersion(..))
import Dhall.Binary (StandardVersion(..))
import Dhall.Core
( Expr(..)
, Chunks(..)
@ -483,7 +483,7 @@ exprFromImport here@(Import {..}) = do
term <- throws (Codec.Serialise.deserialiseOrFail bytesLazy)
throws (Dhall.Binary.decode term)
throws (Dhall.Binary.decodeWithVersion term)
case result of
Just expression -> return expression
@ -520,7 +520,7 @@ exprToImport here expression = do
expression
)
let bytes = encodeExpression _protocolVersion normalizedExpression
let bytes = encodeExpression _standardVersion normalizedExpression
let actualHash = Crypto.Hash.hash bytes
@ -782,7 +782,7 @@ loadWith expr₀ = case expr₀ of
return ()
Just expectedHash -> do
let actualHash =
hashExpression _protocolVersion (Dhall.Core.alphaNormalize expr)
hashExpression _standardVersion (Dhall.Core.alphaNormalize expr)
if expectedHash == actualHash
then return ()
@ -865,23 +865,26 @@ load :: Expr Src Import -> IO (Expr Src X)
load expression = State.evalStateT (loadWith expression) (emptyStatus ".")
encodeExpression
:: forall s . ProtocolVersion -> Expr s X -> Data.ByteString.ByteString
encodeExpression _protocolVersion expression = bytesStrict
:: forall s . StandardVersion -> Expr s X -> Data.ByteString.ByteString
encodeExpression _standardVersion expression = bytesStrict
where
intermediateExpression :: Expr s Import
intermediateExpression = fmap absurd expression
term :: Term
term = Dhall.Binary.encode _protocolVersion intermediateExpression
term =
Dhall.Binary.encodeWithVersion
_standardVersion
intermediateExpression
bytesLazy = Codec.Serialise.serialise term
bytesStrict = Data.ByteString.Lazy.toStrict bytesLazy
-- | Hash a fully resolved expression
hashExpression :: ProtocolVersion -> Expr s X -> (Crypto.Hash.Digest SHA256)
hashExpression _protocolVersion expression =
Crypto.Hash.hash (encodeExpression _protocolVersion expression)
hashExpression :: StandardVersion -> Expr s X -> (Crypto.Hash.Digest SHA256)
hashExpression _standardVersion expression =
Crypto.Hash.hash (encodeExpression _standardVersion expression)
{-| Convenience utility to hash a fully resolved expression and return the
base-16 encoded hash with the @sha256:@ prefix
@ -889,9 +892,9 @@ hashExpression _protocolVersion expression =
In other words, the output of this function can be pasted into Dhall
source code to add an integrity check to an import
-}
hashExpressionToCode :: ProtocolVersion -> Expr s X -> Text
hashExpressionToCode _protocolVersion expr =
"sha256:" <> Text.pack (show (hashExpression _protocolVersion expr))
hashExpressionToCode :: StandardVersion -> Expr s X -> Text
hashExpressionToCode _standardVersion expr =
"sha256:" <> Text.pack (show (hashExpression _standardVersion expr))
-- | A call to `assertNoImports` failed because there was at least one import
data ImportResolutionDisabled = ImportResolutionDisabled deriving (Exception)

12
src/Dhall/Import/Types.hs
View File

@ -10,7 +10,7 @@ import Data.Dynamic
import Data.List.NonEmpty (NonEmpty)
import Data.Map (Map)
import Data.Semigroup ((<>))
import Dhall.Binary (ProtocolVersion(..))
import Dhall.Binary (StandardVersion(..))
import Dhall.Context (Context)
import Dhall.Core
( Directory (..)
@ -46,7 +46,7 @@ data Status m = Status
, _manager :: Maybe Dynamic
-- ^ Cache for the HTTP `Manager` so that we only acquire it once
, _protocolVersion :: ProtocolVersion
, _standardVersion :: StandardVersion
, _normalizer :: ReifiedNormalizer X
@ -71,7 +71,7 @@ emptyStatusWith _resolver _cacher rootDirectory = Status {..}
_manager = Nothing
_protocolVersion = Dhall.Binary.defaultProtocolVersion
_standardVersion = Dhall.Binary.defaultStandardVersion
_normalizer = ReifiedNormalizer (const Nothing)
@ -103,9 +103,9 @@ cache k s = fmap (\x -> s { _cache = x }) (k (_cache s))
manager :: Functor f => LensLike' f (Status m) (Maybe Dynamic)
manager k s = fmap (\x -> s { _manager = x }) (k (_manager s))
protocolVersion :: Functor f => LensLike' f (Status m) ProtocolVersion
protocolVersion k s =
fmap (\x -> s { _protocolVersion = x }) (k (_protocolVersion s))
standardVersion :: Functor f => LensLike' f (Status m) StandardVersion
standardVersion k s =
fmap (\x -> s { _standardVersion = x }) (k (_standardVersion s))
normalizer :: Functor f => LensLike' f (Status m) (ReifiedNormalizer X)
normalizer k s = fmap (\x -> s { _normalizer = x }) (k (_normalizer s))

19
src/Dhall/Main.hs
View File

@ -24,7 +24,7 @@ import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Doc, Pretty)
import Data.Version (showVersion)
import Dhall.Binary (ProtocolVersion)
import Dhall.Binary (StandardVersion)
import Dhall.Core (Expr(..), Import)
import Dhall.Import (Imported(..))
import Dhall.Parser (Src)
@ -68,7 +68,7 @@ data Options = Options
, explain :: Bool
, plain :: Bool
, ascii :: Bool
, protocolVersion :: ProtocolVersion
, standardVersion :: StandardVersion
}
-- | The subcommands for the @dhall@ executable
@ -95,7 +95,7 @@ parseOptions =
<*> switch "explain" "Explain error messages in more detail"
<*> switch "plain" "Disable syntax highlighting"
<*> switch "ascii" "Format code using only ASCII syntax"
<*> Dhall.Binary.parseProtocolVersion
<*> Dhall.Binary.parseStandardVersion
where
switch name description =
Options.Applicative.switch
@ -213,7 +213,7 @@ command (Options {..}) = do
GHC.IO.Encoding.setLocaleEncoding System.IO.utf8
let status =
set Dhall.Import.protocolVersion protocolVersion (Dhall.Import.emptyStatus ".")
set Dhall.Import.standardVersion standardVersion (Dhall.Import.emptyStatus ".")
let handle =
@ -309,7 +309,7 @@ command (Options {..}) = do
render System.IO.stdout (Dhall.Core.normalize inferredType)
Repl -> do
Dhall.Repl.repl characterSet explain protocolVersion
Dhall.Repl.repl characterSet explain standardVersion
Diff {..} -> do
expression1 <- Dhall.inputExpr expr1
@ -324,10 +324,10 @@ command (Options {..}) = do
Dhall.Format.format characterSet inplace
Freeze {..} -> do
Dhall.Freeze.freeze inplace protocolVersion
Dhall.Freeze.freeze inplace standardVersion
Hash -> do
Dhall.Hash.hash protocolVersion
Dhall.Hash.hash standardVersion
Lint {..} -> do
case inplace of
@ -359,7 +359,8 @@ command (Options {..}) = do
Encode -> do
expression <- getExpression
let term = Dhall.Binary.encode protocolVersion expression
let term =
Dhall.Binary.encodeWithVersion standardVersion expression
let bytes = Codec.Serialise.serialise term
@ -370,7 +371,7 @@ command (Options {..}) = do
term <- throws (Codec.Serialise.deserialiseOrFail bytes)
expression <- throws (Dhall.Binary.decode term)
expression <- throws (Dhall.Binary.decodeWithVersion term)
let doc = Dhall.Pretty.prettyCharacterSet characterSet expression

16
src/Dhall/Repl.hs
View File

@ -14,8 +14,8 @@ import Control.Monad.IO.Class ( MonadIO, liftIO )
import Control.Monad.State.Class ( MonadState, get, modify )
import Control.Monad.State.Strict ( evalStateT )
import Data.List ( foldl' )
import Dhall.Binary (ProtocolVersion(..))
import Dhall.Import (protocolVersion)
import Dhall.Binary (StandardVersion(..))
import Dhall.Import (standardVersion)
import Dhall.Pretty (CharacterSet(..))
import Lens.Family (set)
@ -38,8 +38,8 @@ import qualified System.Console.Repline as Repline
import qualified System.IO
-- | Implementation of the @dhall repl@ subcommand
repl :: CharacterSet -> Bool -> ProtocolVersion -> IO ()
repl characterSet explain _protocolVersion =
repl :: CharacterSet -> Bool -> StandardVersion -> IO ()
repl characterSet explain _standardVersion =
if explain then Dhall.detailed io else io
where
io =
@ -52,7 +52,7 @@ repl characterSet explain _protocolVersion =
( Repline.Word completer )
greeter
)
(emptyEnv { characterSet, explain, _protocolVersion })
(emptyEnv { characterSet, explain, _standardVersion })
data Env = Env
@ -60,7 +60,7 @@ data Env = Env
, envIt :: Maybe Binding
, explain :: Bool
, characterSet :: CharacterSet
, _protocolVersion :: ProtocolVersion
, _standardVersion :: StandardVersion
}
@ -70,7 +70,7 @@ emptyEnv =
{ envBindings = Dhall.Context.empty
, envIt = Nothing
, explain = False
, _protocolVersion = Dhall.Binary.defaultProtocolVersion
, _standardVersion = Dhall.Binary.defaultStandardVersion
, characterSet = Unicode
}
@ -107,7 +107,7 @@ parseAndLoad src = do
return a
let status =
set protocolVersion (_protocolVersion env) (Dhall.emptyStatus ".")
set standardVersion (_standardVersion env) (Dhall.emptyStatus ".")
liftIO ( State.evalStateT (Dhall.loadWith parsed) status )

4
tests/QuickCheck.hs
View File

@ -313,10 +313,10 @@ binaryRoundtrip :: Expr () Import -> Property
binaryRoundtrip expression =
wrap
(fmap
Dhall.Binary.decode
Dhall.Binary.decodeWithVersion
(Codec.Serialise.deserialiseOrFail
(Codec.Serialise.serialise
(Dhall.Binary.encode Dhall.Binary.defaultProtocolVersion expression)
(Dhall.Binary.encodeWithVersion Dhall.Binary.defaultStandardVersion expression)
)
)
)

6
tests/import/fieldOrderC.dhall
View File

@ -1,5 +1,5 @@
{ example0 =
./fieldOrderA.dhall sha256:61e722187593ef313ba11d64a0c4a07126bcdac8d662b3329aeeaad5f2fe223b
./fieldOrderA.dhall sha256:72791c3846cef2ec49baabe6a5d38ca25301ed30b45754dfa1c6b06bab8faaf6
, example1 =
./fieldOrderB.dhall sha256:61e722187593ef313ba11d64a0c4a07126bcdac8d662b3329aeeaad5f2fe223b
}
./fieldOrderB.dhall sha256:72791c3846cef2ec49baabe6a5d38ca25301ed30b45754dfa1c6b06bab8faaf6
}

2
tests/import/issue553B.dhall
View File

@ -1 +1 @@
./issue553A.dhall sha256:25bf5a9d0b8c7024964715e9a9b0aff666088c922b79fea95c5e2d5565d6398f
./issue553A.dhall sha256:ef4cce5b6c440b2409f9ba86e48fb788b7ccb757569a713492654f23209cb19b