dhall 1.27.0 → 1.28.0

raw patch · 163 files changed

+5900/−3533 lines, 163 filesdep +atomic-writedep +pretty-simpledep ~hashabledep ~megaparsecdep ~prettyprinterbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: atomic-write, pretty-simple

Dependency ranges changed: hashable, megaparsec, prettyprinter

API changes (from Hackage documentation)

- Dhall: InputType :: (a -> Expr Src Void) -> Expr Src Void -> InputType a

- Dhall: InvalidType :: Expr s a -> Expr s a -> InvalidType s a

- Dhall: RecordInputType :: Map Text (InputType a) -> RecordInputType a

- Dhall: RecordType :: Product (Const (Map Text (Expr Src Void))) (Compose ((->) (Expr Src Void)) (Extractor Src Void)) a -> RecordType a

- Dhall: Type :: (Expr Src Void -> Extractor Src Void a) -> Expr Src Void -> Type a

- Dhall: UnionInputType :: Product (Const (Map Text (Expr Src Void))) (Op (Text, Expr Src Void)) a -> UnionInputType a

- Dhall: UnionType :: Compose (Map Text) Type a -> UnionType a

- Dhall: [invalidTypeExpected] :: InvalidType s a -> Expr s a

- Dhall: [invalidTypeExpression] :: InvalidType s a -> Expr s a

- Dhall: data InputType a

- Dhall: data InvalidType s a

- Dhall: data Type a

- Dhall: inputConstructor :: ToDhall a => Text -> UnionInputType a

- Dhall: inputConstructorWith :: Text -> InputType a -> UnionInputType a

- Dhall: inputField :: ToDhall a => Text -> RecordInputType a

- Dhall: inputFieldWith :: Text -> InputType a -> RecordInputType a

- Dhall: inputRecord :: RecordInputType a -> InputType a

- Dhall: inputUnion :: UnionInputType a -> InputType a

- Dhall: instance (Data.Text.Prettyprint.Doc.Internal.Pretty s, Data.Text.Prettyprint.Doc.Internal.Pretty a, Data.Typeable.Internal.Typeable s, Data.Typeable.Internal.Typeable a) => GHC.Show.Show (Dhall.InvalidType s a)

- Dhall: instance (Data.Text.Prettyprint.Doc.Internal.Pretty s, Data.Typeable.Internal.Typeable s, Data.Text.Prettyprint.Doc.Internal.Pretty a, Data.Typeable.Internal.Typeable a) => GHC.Exception.Type.Exception (Dhall.InvalidType s a)

- Dhall: instance Data.Functor.Contravariant.Contravariant Dhall.InputType

- Dhall: instance Data.Functor.Contravariant.Contravariant Dhall.RecordInputType

- Dhall: instance Data.Functor.Contravariant.Contravariant Dhall.UnionInputType

- Dhall: instance Data.Functor.Contravariant.Divisible.Divisible Dhall.RecordInputType

- Dhall: instance GHC.Base.Applicative Dhall.RecordType

- Dhall: instance GHC.Base.Functor Dhall.RecordType

- Dhall: instance GHC.Base.Functor Dhall.Type

- Dhall: instance GHC.Base.Functor Dhall.UnionType

- Dhall: instance GHC.Base.Monoid (Dhall.UnionType a)

- Dhall: instance GHC.Base.Semigroup (Dhall.UnionType a)

- Dhall: newtype RecordInputType a

- Dhall: newtype RecordType a

- Dhall: newtype UnionInputType a

- Dhall: newtype UnionType a

- Dhall.Binary: class FromTerm a

- Dhall.Binary: class ToTerm a

- Dhall.Binary: data DecodingFailure

- Dhall.Binary: decode :: FromTerm a => Term -> Maybe a

- Dhall.Binary: encode :: ToTerm a => a -> Term

- Dhall.Binary: instance Dhall.Binary.FromTerm Data.Void.Void

- Dhall.Binary: instance Dhall.Binary.FromTerm Dhall.Syntax.Import

- Dhall.Binary: instance Dhall.Binary.FromTerm a => Dhall.Binary.FromTerm (Dhall.Syntax.Expr s a)

- Dhall.Binary: instance Dhall.Binary.ToTerm Data.Void.Void

- Dhall.Binary: instance Dhall.Binary.ToTerm Dhall.Syntax.DhallDouble

- Dhall.Binary: instance Dhall.Binary.ToTerm Dhall.Syntax.Import

- Dhall.Binary: instance Dhall.Binary.ToTerm a => Dhall.Binary.ToTerm (Dhall.Syntax.Expr Data.Void.Void a)

- Dhall.Parser.Token: _colonOnly :: Parser ()

- Dhall.Parser.Token: _equalOnly :: Parser ()

- Dhall.Parser.Token: _letOnly :: Parser ()

- Dhall.Parser.Token: labelOnly :: Parser Text

- Dhall.TypeCheck: instance (GHC.Classes.Eq a, Data.Text.Prettyprint.Doc.Internal.Pretty s, Data.Text.Prettyprint.Doc.Internal.Pretty a, Dhall.Binary.ToTerm a) => Data.Text.Prettyprint.Doc.Internal.Pretty (Dhall.TypeCheck.DetailedTypeError s a)

- Dhall.TypeCheck: instance (GHC.Classes.Eq a, Data.Text.Prettyprint.Doc.Internal.Pretty s, Data.Text.Prettyprint.Doc.Internal.Pretty a, Dhall.Binary.ToTerm a) => GHC.Show.Show (Dhall.TypeCheck.DetailedTypeError s a)

- Dhall.TypeCheck: instance (GHC.Classes.Eq a, Data.Text.Prettyprint.Doc.Internal.Pretty s, Data.Text.Prettyprint.Doc.Internal.Pretty a, Dhall.Binary.ToTerm a, Data.Typeable.Internal.Typeable s, Data.Typeable.Internal.Typeable a) => GHC.Exception.Type.Exception (Dhall.TypeCheck.DetailedTypeError s a)

+ Dhall: Decoder :: (Expr Src Void -> Extractor Src Void a) -> Expr Src Void -> Decoder a

+ Dhall: Encoder :: (a -> Expr Src Void) -> Expr Src Void -> Encoder a

+ Dhall: InvalidDecoder :: Expr s a -> Expr s a -> InvalidDecoder s a

+ Dhall: RecordDecoder :: Product (Const (Map Text (Expr Src Void))) (Compose ((->) (Expr Src Void)) (Extractor Src Void)) a -> RecordDecoder a

+ Dhall: RecordEncoder :: Map Text (Encoder a) -> RecordEncoder a

+ Dhall: UnionDecoder :: Compose (Map Text) Decoder a -> UnionDecoder a

+ Dhall: UnionEncoder :: Product (Const (Map Text (Expr Src Void))) (Op (Text, Expr Src Void)) a -> UnionEncoder a

+ Dhall: [invalidDecoderExpected] :: InvalidDecoder s a -> Expr s a

+ Dhall: [invalidDecoderExpression] :: InvalidDecoder s a -> Expr s a

+ Dhall: data Decoder a

+ Dhall: data Encoder a

+ Dhall: data InvalidDecoder s a

+ Dhall: encodeConstructor :: ToDhall a => Text -> UnionEncoder a

+ Dhall: encodeConstructorWith :: Text -> Encoder a -> UnionEncoder a

+ Dhall: encodeField :: ToDhall a => Text -> RecordEncoder a

+ Dhall: encodeFieldWith :: Text -> Encoder a -> RecordEncoder a

+ Dhall: function :: InterpretOptions -> Encoder a -> Decoder b -> Decoder (a -> b)

+ Dhall: instance (Data.Text.Prettyprint.Doc.Internal.Pretty s, Data.Text.Prettyprint.Doc.Internal.Pretty a, Data.Typeable.Internal.Typeable s, Data.Typeable.Internal.Typeable a) => GHC.Show.Show (Dhall.InvalidDecoder s a)

+ Dhall: instance (Data.Text.Prettyprint.Doc.Internal.Pretty s, Data.Typeable.Internal.Typeable s, Data.Text.Prettyprint.Doc.Internal.Pretty a, Data.Typeable.Internal.Typeable a) => GHC.Exception.Type.Exception (Dhall.InvalidDecoder s a)

+ Dhall: instance Data.Functor.Contravariant.Contravariant Dhall.Encoder

+ Dhall: instance Data.Functor.Contravariant.Contravariant Dhall.RecordEncoder

+ Dhall: instance Data.Functor.Contravariant.Contravariant Dhall.UnionEncoder

+ Dhall: instance Data.Functor.Contravariant.Divisible.Divisible Dhall.RecordEncoder

+ Dhall: instance GHC.Base.Applicative Dhall.RecordDecoder

+ Dhall: instance GHC.Base.Functor Dhall.Decoder

+ Dhall: instance GHC.Base.Functor Dhall.RecordDecoder

+ Dhall: instance GHC.Base.Functor Dhall.UnionDecoder

+ Dhall: instance GHC.Base.Monoid (Dhall.UnionDecoder a)

+ Dhall: instance GHC.Base.Semigroup (Dhall.UnionDecoder a)

+ Dhall: newtype RecordDecoder a

+ Dhall: newtype RecordEncoder a

+ Dhall: newtype UnionDecoder a

+ Dhall: newtype UnionEncoder a

+ Dhall: recordEncoder :: RecordEncoder a -> Encoder a

+ Dhall: unionEncoder :: UnionEncoder a -> Encoder a

+ Dhall.Binary: instance Codec.Serialise.Class.Serialise (Dhall.Syntax.Expr Data.Void.Void Data.Void.Void)

+ Dhall.Binary: instance Codec.Serialise.Class.Serialise (Dhall.Syntax.Expr Data.Void.Void Dhall.Syntax.Import)

+ Dhall.Binary: newtype DecodingFailure

+ Dhall.Core: IntegerClamp :: Expr s a

+ Dhall.Core: IntegerNegate :: Expr s a

+ Dhall.Import: [_manager] :: Status -> Maybe Manager

+ Dhall.Lint: fixAssert :: Expr s a -> Maybe (Expr s a)

+ Dhall.Lint: fixParentPath :: Expr s Import -> Maybe (Expr s Import)

+ Dhall.Main: SyntaxTree :: Input -> Mode

+ Dhall.Map: empty :: Ord k => Map k v

+ Dhall.Map: toAscList :: Map k v -> [(k, v)]

+ Dhall.Map: withoutKeys :: Ord k => Map k a -> Set k -> Map k a

+ Dhall.Parser: Header :: Text -> Header

+ Dhall.Parser: createHeader :: Text -> Header

+ Dhall.Parser: instance GHC.Show.Show Dhall.Parser.Header

+ Dhall.Parser: newtype Header

+ Dhall.Parser.Token: _IntegerClamp :: Parser ()

+ Dhall.Parser.Token: _IntegerNegate :: Parser ()

+ Dhall.Parser.Token: char :: Char -> Parser Char

+ Dhall.Parser.Token: text :: Text -> Parser Text

+ Dhall.Pretty: layout :: Doc ann -> SimpleDocStream ann

+ Dhall.Set: size :: Set a -> Int

+ Dhall.Set: toAscList :: Set a -> [a]

+ Dhall.TypeCheck: CompletionSchemaMustBeARecord :: Expr s a -> Expr s a -> TypeMessage s a

+ Dhall.TypeCheck: InvalidRecordCompletion :: Text -> Expr s a -> TypeMessage s a

+ Dhall.TypeCheck: instance (GHC.Classes.Eq a, Data.Text.Prettyprint.Doc.Internal.Pretty s, Data.Text.Prettyprint.Doc.Internal.Pretty a) => Data.Text.Prettyprint.Doc.Internal.Pretty (Dhall.TypeCheck.DetailedTypeError s a)

+ Dhall.TypeCheck: instance (GHC.Classes.Eq a, Data.Text.Prettyprint.Doc.Internal.Pretty s, Data.Text.Prettyprint.Doc.Internal.Pretty a) => GHC.Show.Show (Dhall.TypeCheck.DetailedTypeError s a)

+ Dhall.TypeCheck: instance (GHC.Classes.Eq a, Data.Text.Prettyprint.Doc.Internal.Pretty s, Data.Text.Prettyprint.Doc.Internal.Pretty a) => GHC.Show.Show (Dhall.TypeCheck.TypeError s a)

+ Dhall.TypeCheck: instance (GHC.Classes.Eq a, Data.Text.Prettyprint.Doc.Internal.Pretty s, Data.Text.Prettyprint.Doc.Internal.Pretty a, Data.Typeable.Internal.Typeable s, Data.Typeable.Internal.Typeable a) => GHC.Exception.Type.Exception (Dhall.TypeCheck.DetailedTypeError s a)

+ Dhall.Util: Header :: Text -> Header

+ Dhall.Util: getExpressionAndHeaderFromStdinText :: Censor -> Text -> IO (Header, Expr Src Import)

+ Dhall.Util: newtype Header

- Dhall: (>|<) :: UnionInputType a -> UnionInputType b -> UnionInputType (Either a b)

+ Dhall: (>|<) :: UnionEncoder a -> UnionEncoder b -> UnionEncoder (Either a b)

- Dhall: [declared] :: InputType a -> Expr Src Void

+ Dhall: [declared] :: Encoder a -> Expr Src Void

- Dhall: [embed] :: InputType a -> a -> Expr Src Void

+ Dhall: [embed] :: Encoder a -> a -> Expr Src Void

- Dhall: [expected] :: Type a -> Expr Src Void

+ Dhall: [expected] :: Decoder a -> Expr Src Void

- Dhall: [extract] :: Type a -> Expr Src Void -> Extractor Src Void a

+ Dhall: [extract] :: Decoder a -> Expr Src Void -> Extractor Src Void a

- Dhall: auto :: FromDhall a => Type a

+ Dhall: auto :: FromDhall a => Decoder a

- Dhall: autoWith :: (FromDhall a, Generic a, GenericFromDhall (Rep a)) => InterpretOptions -> Type a

+ Dhall: autoWith :: (FromDhall a, Generic a, GenericFromDhall (Rep a)) => InterpretOptions -> Decoder a

- Dhall: bool :: Type Bool

+ Dhall: bool :: Decoder Bool

- Dhall: constructor :: Text -> Type a -> UnionType a

+ Dhall: constructor :: Text -> Decoder a -> UnionDecoder a

- Dhall: double :: Type Double

+ Dhall: double :: Decoder Double

- Dhall: field :: Text -> Type a -> RecordType a

+ Dhall: field :: Text -> Decoder a -> RecordDecoder a

- Dhall: genericAuto :: (Generic a, GenericFromDhall (Rep a)) => Type a

+ Dhall: genericAuto :: (Generic a, GenericFromDhall (Rep a)) => Decoder a

- Dhall: genericAutoWith :: GenericFromDhall f => InterpretOptions -> State Int (Type (f a))

+ Dhall: genericAutoWith :: GenericFromDhall f => InterpretOptions -> State Int (Decoder (f a))

- Dhall: genericToDhall :: (Generic a, GenericToDhall (Rep a)) => InputType a

+ Dhall: genericToDhall :: (Generic a, GenericToDhall (Rep a)) => Encoder a

- Dhall: genericToDhallWith :: GenericToDhall f => InterpretOptions -> State Int (InputType (f a))

+ Dhall: genericToDhallWith :: GenericToDhall f => InterpretOptions -> State Int (Encoder (f a))

- Dhall: hashMap :: (Eq k, Hashable k) => Type k -> Type v -> Type (HashMap k v)

+ Dhall: hashMap :: (Eq k, Hashable k) => Decoder k -> Decoder v -> Decoder (HashMap k v)

- Dhall: hashSetFromDistinctList :: (Hashable a, Ord a, Show a) => Type a -> Type (HashSet a)

+ Dhall: hashSetFromDistinctList :: (Hashable a, Ord a, Show a) => Decoder a -> Decoder (HashSet a)

- Dhall: hashSetIgnoringDuplicates :: (Hashable a, Ord a) => Type a -> Type (HashSet a)

+ Dhall: hashSetIgnoringDuplicates :: (Hashable a, Ord a) => Decoder a -> Decoder (HashSet a)

- Dhall: inject :: ToDhall a => InputType a

+ Dhall: inject :: ToDhall a => Encoder a

- Dhall: injectWith :: (ToDhall a, Generic a, GenericToDhall (Rep a)) => InterpretOptions -> InputType a

+ Dhall: injectWith :: (ToDhall a, Generic a, GenericToDhall (Rep a)) => InterpretOptions -> Encoder a

- Dhall: input :: Type a -> Text -> IO a

+ Dhall: input :: Decoder a -> Text -> IO a

- Dhall: inputFile :: Type a -> FilePath -> IO a

+ Dhall: inputFile :: Decoder a -> FilePath -> IO a

- Dhall: inputFileWithSettings :: EvaluateSettings -> Type a -> FilePath -> IO a

+ Dhall: inputFileWithSettings :: EvaluateSettings -> Decoder a -> FilePath -> IO a

- Dhall: inputWithSettings :: InputSettings -> Type a -> Text -> IO a

+ Dhall: inputWithSettings :: InputSettings -> Decoder a -> Text -> IO a

- Dhall: integer :: Type Integer

+ Dhall: integer :: Decoder Integer

- Dhall: lazyText :: Type Text

+ Dhall: lazyText :: Decoder Text

- Dhall: list :: Type a -> Type [a]

+ Dhall: list :: Decoder a -> Decoder [a]

- Dhall: map :: Ord k => Type k -> Type v -> Type (Map k v)

+ Dhall: map :: Ord k => Decoder k -> Decoder v -> Decoder (Map k v)

- Dhall: maybe :: Type a -> Type (Maybe a)

+ Dhall: maybe :: Decoder a -> Decoder (Maybe a)

- Dhall: natural :: Type Natural

+ Dhall: natural :: Decoder Natural

- Dhall: pair :: Type a -> Type b -> Type (a, b)

+ Dhall: pair :: Decoder a -> Decoder b -> Decoder (a, b)

- Dhall: pairFromMapEntry :: Type k -> Type v -> Type (k, v)

+ Dhall: pairFromMapEntry :: Decoder k -> Decoder v -> Decoder (k, v)

- Dhall: rawInput :: Alternative f => Type a -> Expr s Void -> f a

+ Dhall: rawInput :: Alternative f => Decoder a -> Expr s Void -> f a

- Dhall: record :: RecordType a -> Type a

+ Dhall: record :: RecordDecoder a -> Decoder a

- Dhall: scientific :: Type Scientific

+ Dhall: scientific :: Decoder Scientific

- Dhall: sequence :: Type a -> Type (Seq a)

+ Dhall: sequence :: Decoder a -> Decoder (Seq a)

- Dhall: setFromDistinctList :: (Ord a, Show a) => Type a -> Type (Set a)

+ Dhall: setFromDistinctList :: (Ord a, Show a) => Decoder a -> Decoder (Set a)

- Dhall: setIgnoringDuplicates :: Ord a => Type a -> Type (Set a)

+ Dhall: setIgnoringDuplicates :: Ord a => Decoder a -> Decoder (Set a)

- Dhall: strictText :: Type Text

+ Dhall: strictText :: Decoder Text

- Dhall: string :: Type String

+ Dhall: string :: Decoder String

- Dhall: union :: UnionType a -> Type a

+ Dhall: union :: UnionDecoder a -> Decoder a

- Dhall: unit :: Type ()

+ Dhall: unit :: Decoder ()

- Dhall: vector :: Type a -> Type (Vector a)

+ Dhall: vector :: Decoder a -> Decoder (Vector a)

- Dhall: void :: Type Void

+ Dhall: void :: Decoder Void

- Dhall.Binary: CBORIsNotDhall :: Term -> DecodingFailure

+ Dhall.Binary: CBORIsNotDhall :: ByteString -> DecodingFailure

- Dhall.Binary: decodeExpression :: FromTerm a => Term -> Either DecodingFailure (Expr s a)

+ Dhall.Binary: decodeExpression :: Serialise (Expr s a) => ByteString -> Either DecodingFailure (Expr s a)

- Dhall.Binary: encodeExpression :: Expr s Import -> Term

+ Dhall.Binary: encodeExpression :: Expr Void Import -> ByteString

- Dhall.Diff: diffNormalized :: (Eq a, Pretty a, ToTerm a) => Expr s a -> Expr s a -> Diff

+ Dhall.Diff: diffNormalized :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff

- Dhall.Import: Status :: NonEmpty Chained -> [Depends] -> Map Chained ImportSemantics -> (URL -> StateT Status IO Text) -> Maybe (ReifiedNormalizer Void) -> Context (Expr Src Void) -> SemanticCacheMode -> Status

+ Dhall.Import: Status :: NonEmpty Chained -> [Depends] -> Map Chained ImportSemantics -> Maybe Manager -> (URL -> StateT Status IO Text) -> Maybe (ReifiedNormalizer Void) -> Context (Expr Src Void) -> SemanticCacheMode -> Status

- Dhall.Import: hashExpression :: Expr s Void -> SHA256Digest

+ Dhall.Import: hashExpression :: Expr Void Void -> SHA256Digest

- Dhall.Import: hashExpressionToCode :: Expr s Void -> Text

+ Dhall.Import: hashExpressionToCode :: Expr Void Void -> Text

- Dhall.Import: writeExpressionToSemanticCache :: Expr Src Void -> IO ()

+ Dhall.Import: writeExpressionToSemanticCache :: Expr Void Void -> IO ()

- Dhall.Parser: exprAndHeaderFromText :: String -> Text -> Either ParseError (Text, Expr Src Import)

+ Dhall.Parser: exprAndHeaderFromText :: String -> Text -> Either ParseError (Header, Expr Src Import)

- Dhall.Parser.Token: validCodepoint :: Char -> Bool

+ Dhall.Parser.Token: validCodepoint :: Int -> Bool

- Dhall.TypeCheck: MissingHandler :: Set Text -> TypeMessage s a

+ Dhall.TypeCheck: MissingHandler :: Text -> Set Text -> TypeMessage s a

- Dhall.Util: getExpressionAndHeader :: Censor -> Input -> IO (Text, Expr Src Import)

+ Dhall.Util: getExpressionAndHeader :: Censor -> Input -> IO (Header, Expr Src Import)

Files

CHANGELOG.md +86/−0
benchmark/parser/Main.hs +8/−9
dhall-lang/Prelude/Integer/abs +19/−0
dhall-lang/Prelude/Integer/add +26/−0
dhall-lang/Prelude/Integer/clamp +14/−0
dhall-lang/Prelude/Integer/equal +26/−0
dhall-lang/Prelude/Integer/greaterThan +32/−0
dhall-lang/Prelude/Integer/greaterThanEqual +30/−0
dhall-lang/Prelude/Integer/lessThan +26/−0
dhall-lang/Prelude/Integer/lessThanEqual +30/−0
dhall-lang/Prelude/Integer/multiply +43/−0
dhall-lang/Prelude/Integer/negate +14/−0
dhall-lang/Prelude/Integer/package.dhall +37/−1
dhall-lang/Prelude/Integer/subtract +56/−0
dhall-lang/Prelude/Integer/toNatural +19/−0
dhall-lang/Prelude/JSON/Tagged +2/−5
dhall-lang/Prelude/JSON/core.dhall +44/−0
dhall-lang/Prelude/JSON/omitNullFields +141/−0
dhall-lang/Prelude/JSON/package.dhall +19/−37
dhall-lang/Prelude/JSON/render +20/−22
dhall-lang/Prelude/JSON/renderYAML +175/−0
dhall-lang/Prelude/JSON/tagInline +28/−0
dhall-lang/Prelude/JSON/tagNested +32/−0
dhall-lang/Prelude/List/drop +29/−0
dhall-lang/Prelude/List/package.dhall +9/−0
dhall-lang/Prelude/List/partition +33/−0
dhall-lang/Prelude/List/shifted +3/−3
dhall-lang/Prelude/List/take +25/−0
dhall-lang/Prelude/Natural/listMax +28/−0
dhall-lang/Prelude/Natural/listMin +32/−0
dhall-lang/Prelude/Natural/max +20/−0
dhall-lang/Prelude/Natural/min +18/−0
dhall-lang/Prelude/Natural/package.dhall +15/−0
dhall-lang/Prelude/Natural/sort +60/−0
dhall-lang/Prelude/Text/concatMapSep +1/−1
dhall-lang/Prelude/Text/concatSep +1/−1
dhall-lang/Prelude/Text/show +6/−1
dhall-lang/Prelude/XML/render +3/−3
dhall-lang/Prelude/package.dhall +4/−4
dhall-lang/tests/binary-decode/success/unit/IntegerBigNegativeA.dhallb +1/−0
dhall-lang/tests/binary-decode/success/unit/IntegerBigNegativeB.dhall +2/−0
dhall-lang/tests/binary-decode/success/unit/IntegerBigPositiveA.dhallb binary
dhall-lang/tests/binary-decode/success/unit/IntegerBigPositiveB.dhall +2/−0
dhall-lang/tests/binary-decode/success/unit/NaturalBigA.dhallb binary
dhall-lang/tests/binary-decode/success/unit/NaturalBigB.dhall +2/−0
dhall-lang/tests/import/success/referentiallyTransparentMissing.dhall +9/−0
dhall-lang/tests/normalization/success/unit/IntegerClampA.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerClampB.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerClampNegativeA.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerClampNegativeB.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerClampPositiveA.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerClampPositiveB.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerClampZeroA.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerClampZeroB.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerNegateA.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerNegateB.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerNegateNegativeA.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerNegateNegativeB.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerNegatePositiveA.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerNegatePositiveB.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerNegateZeroA.dhall +1/−0
dhall-lang/tests/normalization/success/unit/IntegerNegateZeroB.dhall +1/−0
dhall-lang/tests/normalization/success/unit/ListBuildFoldFusionB.dhall +8/−1
dhall-lang/tests/normalization/success/unit/NaturalBuildFoldFusionB.dhall +1/−1
dhall-lang/tests/normalization/success/unit/OptionalBuildFoldFusionB.dhall +3/−1
dhall-lang/tests/parser/failure/nonCharacterUnbraced.dhall +6/−0
dhall-lang/tests/parser/failure/surrogatePairUnbraced.dhall +5/−0
dhall-lang/tests/parser/success/missingFooA.dhall +1/−0
dhall-lang/tests/parser/success/missingFooB.dhallb binary
dhall-lang/tests/parser/success/missingInParenthesesA.dhall +1/−0
dhall-lang/tests/parser/success/missingInParenthesesB.dhallb binary
dhall-lang/tests/parser/success/missingSlashA.dhall +1/−0
dhall-lang/tests/parser/success/missingSlashB.dhallb binary
dhall-lang/tests/parser/success/preferMissingNoSpacesA.dhall +1/−0
dhall-lang/tests/parser/success/preferMissingNoSpacesB.dhallb binary
dhall-lang/tests/parser/success/text/nonAssignedUnicodeA.dhall +1/−0
dhall-lang/tests/parser/success/text/nonAssignedUnicodeB.dhallb +1/−0
dhall-lang/tests/parser/success/unit/CompletionA.dhall +1/−1
dhall-lang/tests/type-inference/success/preludeB.dhall +79/−1
dhall-lang/tests/type-inference/success/unit/IntegerClampA.dhall +1/−0
dhall-lang/tests/type-inference/success/unit/IntegerClampB.dhall +1/−0
dhall-lang/tests/type-inference/success/unit/IntegerNegateA.dhall +1/−0
dhall-lang/tests/type-inference/success/unit/IntegerNegateB.dhall +1/−0
dhall.cabal +70/−41
doctest/Main.hs +11/−4
ghc-src/Dhall/Import/HTTP.hs +18/−6
ghc-src/Dhall/Import/Manager.hs +14/−0
ghcjs-src/Dhall/Import/HTTP.hs +13/−1
ghcjs-src/Dhall/Import/Manager.hs +17/−0
src/Dhall.hs +317/−306
src/Dhall/Binary.hs +1248/−967
src/Dhall/Core.hs +86/−1303
src/Dhall/Diff.hs +28/−9
src/Dhall/Eval.hs +33/−26
src/Dhall/Format.hs +33/−33
src/Dhall/Freeze.hs +18/−22
src/Dhall/Import.hs +42/−46
src/Dhall/Import/Types.hs +17/−3
src/Dhall/Lint.hs +55/−7
src/Dhall/Main.hs +62/−41
src/Dhall/Map.hs +33/−0
src/Dhall/Normalize.hs +1239/−0
src/Dhall/Parser.hs +17/−14
src/Dhall/Parser/Combinators.hs +5/−9
src/Dhall/Parser/Expression.hs +205/−149
src/Dhall/Parser/Token.hs +146/−140
src/Dhall/Pretty.hs +2/−8
src/Dhall/Pretty/Internal.hs +180/−26
src/Dhall/Pretty/Internal.hs-boot +3/−0
src/Dhall/Repl.hs +24/−22
src/Dhall/Set.hs +24/−2
src/Dhall/Syntax.hs +49/−25
src/Dhall/Tags.hs +3/−3
src/Dhall/Tutorial.hs +1/−1
src/Dhall/TypeCheck.hs +147/−79
src/Dhall/URL.hs +1/−1
src/Dhall/Util.hs +37/−16
tests/Dhall/Test/Dhall.hs +11/−11
tests/Dhall/Test/Diff.hs +3/−8
tests/Dhall/Test/Format.hs +13/−7
tests/Dhall/Test/Parser.hs +47/−50
tests/Dhall/Test/QuickCheck.hs +87/−41
tests/Dhall/Test/Regression.hs +14/−6
tests/diff/function.txt +1/−1
tests/diff/insideList.txt +7/−0
tests/diff/insideListA.dhall +3/−0
tests/diff/insideListB.dhall +3/−0
tests/format/concatSepB.dhall +1/−1
tests/format/envVarsA.dhall +1/−0
tests/format/envVarsB.dhall +1/−0
tests/format/escapeSingleQuotedOpenInterpolationB.dhall +3/−1
tests/format/headerB.dhall +1/−1
tests/format/importAltPrecedenceA.dhall +1/−0
tests/format/importAltPrecedenceB.dhall +1/−0
tests/format/innerMultilineB.dhall +11/−1
tests/format/interpolation0A.dhall +1/−0
tests/format/interpolation0B.dhall +3/−0
tests/format/issue1400-1A.dhall +14/−0
tests/format/issue1400-1B.dhall +13/−0
tests/format/issue1400-2A.dhall +14/−0
tests/format/issue1400-2B.dhall +11/−0
tests/format/issue1413B.dhall +1/−1
tests/format/issue1545-1A.dhall +1/−0
tests/format/issue1545-1B.dhall +3/−0
tests/format/issue1545-2A.dhall +1/−0
tests/format/issue1545-2B.dhall +3/−0
tests/format/issue183A.dhall +11/−0
tests/format/issue183B.dhall +11/−0
tests/format/letNewlineCommentsB.dhall +1/−1
tests/format/multilineArgumentA.dhall +1/−0
tests/format/multilineArgumentB.dhall +3/−0
tests/format/multilineB.dhall +3/−1
tests/format/multilineTrailingSingleQuoteA.dhall +1/−0
tests/format/multilineTrailingSingleQuoteB.dhall +3/−0
tests/format/multilineTrailingWhitespaceA.dhall +1/−0
tests/format/multilineTrailingWhitespaceB.dhall +7/−0
tests/format/nestedAnnotationA.dhall +1/−0
tests/format/nestedAnnotationB.dhall +1/−0
tests/format/stringWithNullA.dhall +1/−0
tests/format/stringWithNullB.dhall +3/−0
tests/format/textLitNewlinesOnlyA.dhall +1/−0
tests/format/textLitNewlinesOnlyB.dhall +1/−0
tests/regression/issue1584.dhall +19/−0

CHANGELOG.md view

@@ -1,3 +1,89 @@+1.28.0++* [Supports version 12.0.0 of the standard](https://github.com/dhall-lang/dhall-lang/releases/tag/v12.0.0)+* BREAKING CHANGE: [Add `Integer/{clamp,negate}` built-ins](https://github.com/dhall-lang/dhall-haskell/pull/1486)+    * This is a technically breaking change API since this adds a new+      constructor to the `Expr` type+    * This is also a technically breaking change to the language.  See the [changelog for standard version 12.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v12.0.0) for more details+* BREAKING CHANGE: [Remove support for fusion](https://github.com/dhall-lang/dhall-haskell/pull/1478)+    * This is also a technically breaking change to the language.  See the [changelog for standard version 12.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v12.0.0) for more details+* BREAKING CHANGE: [Parse whitespace more precisely](https://github.com/dhall-lang/dhall-haskell/pull/1483)+    * The Haskell implementation now matches the official grammar much more+      closely, but as a result will now reject some programs that it used to+      accept+    * For example, `1:Natural` used to be valid and now is no longer valid as+      the standard requires mandatory whitespace after the `:`+    * Consult the [standard grammar](https://github.com/dhall-lang/dhall-lang/blob/master/standard/dhall.abnf) if you run into a new parsing error as a result of this change+    * This is also a parsing performance regression (specifically for parsing+      comments), but should not be noticeable in practice.  See [#1512](https://github.com/dhall-lang/dhall-haskell/pull/1512) for more details+* BREAKING CHANGE: Rename `Type` to `Decoder` and `InputType` to `Encoder` [#1483](https://github.com/dhall-lang/dhall-haskell/pull/1485) / [#1489](https://github.com/dhall-lang/dhall-haskell/pull/1489)+* BUG FIX: [Fix `dhall format --check`](https://github.com/dhall-lang/dhall-haskell/pull/1462)+    * Before this change `dhall format --check` would fail due to attempting to+      read all of standard input in twice+* BUG FIX: [Fix `dhall freeze` to always re-freeze an import](https://github.com/dhall-lang/dhall-haskell/pull/1471)+    * Before this fix, `dhall freeze` would not attempt to refreeze an already+      frozen import+* [Permit spaces around completion operator](https://github.com/dhall-lang/dhall-haskell/pull/1532)+    * See the [changelog for standard version 12.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v12.0.0) for more details+* [Make `missing` referentially transparent](https://github.com/dhall-lang/dhall-haskell/pull/1509)+    * `missing` can now be imported transitively via a remote import+    * Normally resolving `missing` would still still fail, except for+      `missing as Location`, which is now a valid transitive import+    * See the [changelog for standard version 12.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v12.0.0) for more details+* [Write cache files atomically](https://github.com/dhall-lang/dhall-haskell/pull/1544)+    * This is a resilience improvement so that the cache is not left in a+      corrupt state in the event of a power outage or exhausting disk/memory+* [New `Dhall.function` utility](https://github.com/dhall-lang/dhall-haskell/pull/1507)+    * This is provides the same functionality as the `Interpret` instance for+      `(->)`, except without the use of typeclasses+* [New `dhall haskell-syntax-tree` command](https://github.com/dhall-lang/dhall-haskell/pull/1553)+    * This command displays the Haskell syntax tree of an expression+      (primarily for debugging purposes)+    * Note that this is highly-volatile and subject to change, so don't depend+      on this programmatically.  We may break the output of this command without+      any notice.+* [Add `instance Show Ann`](https://github.com/dhall-lang/dhall-haskell/pull/1567)+* [Move normalization code from `Dhall.Core` to `Dhall.Normalize`](https://github.com/dhall-lang/dhall-haskell/pull/1452)+    * Note that this is not a breaking change.  The relocated utilities are+      still re-exported from `Dhall.Core`+* [Fix `dhall resolve --transitive-dependencies` to list dependencies in "post-order"](https://github.com/dhall-lang/dhall-haskell/pull/1539)+* Performance improvements+    * [#1500](https://github.com/dhall-lang/dhall-haskell/pull/1500)+    * [#1522](https://github.com/dhall-lang/dhall-haskell/pull/1522)+    * [#1568](https://github.com/dhall-lang/dhall-haskell/pull/1568)+    * [#1580](https://github.com/dhall-lang/dhall-haskell/pull/1578)+* Fixes and improvements to code formatting+    * [#1460](https://github.com/dhall-lang/dhall-haskell/pull/1460)+    * [#1466](https://github.com/dhall-lang/dhall-haskell/pull/1466)+    * [#1508](https://github.com/dhall-lang/dhall-haskell/pull/1508)+    * [#1527](https://github.com/dhall-lang/dhall-haskell/pull/1527)+    * [#1422](https://github.com/dhall-lang/dhall-haskell/pull/1422)+    * [#1552](https://github.com/dhall-lang/dhall-haskell/pull/1552)+    * [#1543](https://github.com/dhall-lang/dhall-haskell/pull/1543)+    * [#1554](https://github.com/dhall-lang/dhall-haskell/pull/1554)+    * [#1569](https://github.com/dhall-lang/dhall-haskell/pull/1569)+* Fixes and improvements to code linting+    * [#1518](https://github.com/dhall-lang/dhall-haskell/pull/1518)+    * [#1531](https://github.com/dhall-lang/dhall-haskell/pull/1531)+* Fixes and improvements to error messages+    * [#1443](https://github.com/dhall-lang/dhall-haskell/pull/1443)+    * [#1448](https://github.com/dhall-lang/dhall-haskell/pull/1448)+    * [#1482](https://github.com/dhall-lang/dhall-haskell/pull/1482)+    * [#1519](https://github.com/dhall-lang/dhall-haskell/pull/1519)+    * [#1556](https://github.com/dhall-lang/dhall-haskell/pull/1556)+    * [#1528](https://github.com/dhall-lang/dhall-haskell/pull/1528)+* Fixes and improvements to the parser+    * [#1473](https://github.com/dhall-lang/dhall-haskell/pull/1473)+    * [#1549](https://github.com/dhall-lang/dhall-haskell/pull/1549)+    * [#1563](https://github.com/dhall-lang/dhall-haskell/pull/1563)+    * [#1584](https://github.com/dhall-lang/dhall-haskell/pull/1584)+* Fixes and improvements to diffs+    * [#1585](https://github.com/dhall-lang/dhall-haskell/pull/1585)+* Fixes and improvements to the REPL+    * [#1573](https://github.com/dhall-lang/dhall-haskell/pull/1573)+* Fixes and improvements to documentation+    * [#1530](https://github.com/dhall-lang/dhall-haskell/pull/1530)+ 1.27.0  * [Supports version 11.0.0 of the standard](https://github.com/dhall-lang/dhall-lang/releases/tag/v11.0.0)

benchmark/parser/Main.hs view

@@ -6,7 +6,8 @@ import Control.Monad (forM) import Data.Map (Map, foldrWithKey, singleton, unions) import Data.Monoid ((<>))-import Gauge (defaultMain, bgroup, bench, whnf, nfIO)+import Data.Void (Void)+import Gauge (defaultMain, bgroup, bench, nf, whnf, nfIO)  import System.Directory @@ -67,27 +68,25 @@  benchExprFromBytes     :: String -> Data.ByteString.Lazy.ByteString -> Gauge.Benchmark-benchExprFromBytes name bytes = bench name (whnf f bytes)+benchExprFromBytes name bytes = bench name (nf f bytes)   where     f bytes = do-        term <- case Codec.Serialise.deserialiseOrFail bytes of-            Left  _    -> Nothing-            Right term -> return term-        case Dhall.Binary.decodeExpression term-          :: Either Dhall.Binary.DecodingFailure (Dhall.Expr () Dhall.Import) of-            Left  _          -> Nothing-            Right expression -> return expression+        case Dhall.Binary.decodeExpression bytes of+            Left  exception  -> error (show exception)+            Right expression -> expression :: Dhall.Expr Void Dhall.Import  main :: IO () main = do     prelude <- loadPreludeFiles     issue108Text  <- TIO.readFile "benchmark/examples/issue108.dhall"     issue108Bytes <- Data.ByteString.Lazy.readFile "benchmark/examples/issue108.dhall.bin"+    kubernetesExample <- Data.ByteString.Lazy.readFile "benchmark/examples/kubernetes.dhall.bin"     defaultMain         [ bgroup "Issue #108"             [ benchExprFromText  "Text"   issue108Text             , benchExprFromBytes "Binary" issue108Bytes             ]+        , benchExprFromBytes "Kubernetes/Binary" kubernetesExample         , benchExprFromText "Long variable names" (T.replicate 1000000 "x")         , benchExprFromText "Large number of function arguments" (T.replicate 10000 "x ")         , benchExprFromText "Long double-quoted strings" ("\"" <> T.replicate 1000000 "x" <> "\"")

+ dhall-lang/Prelude/Integer/abs view

@@ -0,0 +1,19 @@+{-+Returns the absolute value of an `Integer`, i.e. its non-negative value.+-}+let abs+    : Integer → Natural+    =   λ(n : Integer)+      →       if Natural/isZero (Integer/clamp n)++        then  Integer/clamp (Integer/negate n)++        else  Integer/clamp n++let example0 = assert : abs +7 ≡ 7++let example2 = assert : abs +0 ≡ 0++let example3 = assert : abs -3 ≡ 3++in  abs

+ dhall-lang/Prelude/Integer/add view

@@ -0,0 +1,26 @@+{-+`add m n` computes `m + n`.+-}+let Integer/subtract =+        ./subtract sha256:8de76d2e235eec1629750ae62e191f13631b36708bfda0425572d87e5a9a37e7+      ? ./subtract++let add+    : Integer → Integer → Integer+    = λ(m : Integer) → λ(n : Integer) → Integer/subtract (Integer/negate m) n++let example0 = assert : add +3 +5 ≡ +8++let example1 = assert : add -3 -5 ≡ -8++let example2 = assert : add -4 +4 ≡ +0++let example3 = assert : add -3 +5 ≡ +2++let example4 = assert : add +3 -5 ≡ -2++let example5 = assert : add +0 -3 ≡ -3++let example6 = assert : add +0 +3 ≡ +3++in  add

+ dhall-lang/Prelude/Integer/clamp view

@@ -0,0 +1,14 @@+{-+Convert an `Integer` to a `Natural` number, with negative numbers becoming zero.+-}+let clamp+    : Integer → Natural+    = Integer/clamp++let example0 = assert : clamp +7 ≡ 7++let example2 = assert : clamp +0 ≡ 0++let example3 = assert : clamp -3 ≡ 0++in  clamp

+ dhall-lang/Prelude/Integer/equal view

@@ -0,0 +1,26 @@+{-+`equal` checks if two Integers are equal.+-}+let greaterThan =+        ./greaterThan sha256:accaa6b7cbca7ec2ace4a529e5f3bb57679df2b5ad962bde5b7867d9253d4b8c+      ? ./greaterThan++let Bool/not =+        ../Bool/not sha256:723df402df24377d8a853afed08d9d69a0a6d86e2e5b2bac8960b0d4756c7dc4+      ? ../Bool/not++let equal+    : Integer → Integer → Bool+    =   λ(a : Integer)+      → λ(b : Integer)+      → Bool/not (greaterThan a b) && Bool/not (greaterThan b a)++let example0 = assert : equal +5 +5 ≡ True++let example1 = assert : equal +5 +6 ≡ False++let example2 = assert : equal +5 -5 ≡ False++let example3 = assert : equal -5 -5 ≡ True++in  equal

+ dhall-lang/Prelude/Integer/greaterThan view

@@ -0,0 +1,32 @@+{-+`greaterThan` checks if one Integer is greater than another.+-}+let Integer/subtract =+        ./subtract sha256:8de76d2e235eec1629750ae62e191f13631b36708bfda0425572d87e5a9a37e7+      ? ./subtract++let Bool/not =+        ../Bool/not sha256:723df402df24377d8a853afed08d9d69a0a6d86e2e5b2bac8960b0d4756c7dc4+      ? ../Bool/not++let greaterThan+    : Integer → Integer → Bool+    =   λ(x : Integer)+      → λ(y : Integer)+      → Bool/not (Natural/isZero (Integer/clamp (Integer/subtract y x)))++let example0 = assert : greaterThan +5 +6 ≡ False++let example1 = assert : greaterThan +5 +5 ≡ False++let example2 = assert : greaterThan +5 +4 ≡ True++let example3 = assert : greaterThan -5 +8 ≡ False++let example4 = assert : greaterThan -5 -3 ≡ False++let example5 = assert : greaterThan -3 -5 ≡ True++let example6 = assert : greaterThan -3 -3 ≡ False++in  greaterThan

+ dhall-lang/Prelude/Integer/greaterThanEqual view

@@ -0,0 +1,30 @@+{-+`greaterThanEqual` checks if one Integer is greater than or equal to another.+-}+let greaterThan =+        ./greaterThan sha256:accaa6b7cbca7ec2ace4a529e5f3bb57679df2b5ad962bde5b7867d9253d4b8c+      ? ./greaterThan++let Bool/not =+        ../Bool/not sha256:723df402df24377d8a853afed08d9d69a0a6d86e2e5b2bac8960b0d4756c7dc4+      ? ../Bool/not++let greaterThanEqual+    : Integer → Integer → Bool+    = λ(x : Integer) → λ(y : Integer) → Bool/not (greaterThan y x)++let example0 = assert : greaterThanEqual +5 +6 ≡ False++let example1 = assert : greaterThanEqual +5 +5 ≡ True++let example2 = assert : greaterThanEqual +5 +4 ≡ True++let example3 = assert : greaterThanEqual -5 +8 ≡ False++let example4 = assert : greaterThanEqual -5 -3 ≡ False++let example5 = assert : greaterThanEqual -3 -5 ≡ True++let example6 = assert : greaterThanEqual -3 -3 ≡ True++in  greaterThanEqual

+ dhall-lang/Prelude/Integer/lessThan view

@@ -0,0 +1,26 @@+{-+`lessThan` checks if one Integer is less than another.+-}+let greaterThan =+        ./greaterThan sha256:accaa6b7cbca7ec2ace4a529e5f3bb57679df2b5ad962bde5b7867d9253d4b8c+      ? ./greaterThan++let lessThan+    : Integer → Integer → Bool+    = λ(x : Integer) → λ(y : Integer) → greaterThan y x++let example0 = assert : lessThan +5 +6 ≡ True++let example1 = assert : lessThan +5 +5 ≡ False++let example2 = assert : lessThan +5 +4 ≡ False++let example3 = assert : lessThan -5 +8 ≡ True++let example4 = assert : lessThan -5 -3 ≡ True++let example5 = assert : lessThan -3 -5 ≡ False++let example6 = assert : lessThan -3 -3 ≡ False++in  lessThan

+ dhall-lang/Prelude/Integer/lessThanEqual view

@@ -0,0 +1,30 @@+{-+`lessThanEqual` checks if one Integer is less than or equal to another.+-}+let lessThan =+        ./lessThan sha256:14cc3bc6ca8757f7c3af338f079fcc18e0c7ee3ed0d20914a9693aec81ae628d+      ? ./lessThan++let Bool/not =+        ../Bool/not sha256:723df402df24377d8a853afed08d9d69a0a6d86e2e5b2bac8960b0d4756c7dc4+      ? ../Bool/not++let lessThanEqual+    : Integer → Integer → Bool+    = λ(x : Integer) → λ(y : Integer) → Bool/not (lessThan y x)++let example0 = assert : lessThanEqual +5 +6 ≡ True++let example1 = assert : lessThanEqual +5 +5 ≡ True++let example2 = assert : lessThanEqual +5 +4 ≡ False++let example3 = assert : lessThanEqual -5 +8 ≡ True++let example4 = assert : lessThanEqual -5 -3 ≡ True++let example5 = assert : lessThanEqual -3 -5 ≡ False++let example6 = assert : lessThanEqual -3 -3 ≡ True++in  lessThanEqual

+ dhall-lang/Prelude/Integer/multiply view

@@ -0,0 +1,43 @@+{-+`multiply m n` computes `m * n`.+-}++let Integer/abs =+        ./abs sha256:35212fcbe1e60cb95b033a4a9c6e45befca4a298aa9919915999d09e69ddced1+      ? ./abs++let multiply+    : Integer → Integer → Integer+    =   λ(m : Integer)+      → λ(n : Integer)+      → let mAbs = Integer/abs m++        let nAbs = Integer/abs n++        let mNonPos = Natural/isZero (Integer/clamp m)++        let nNonPos = Natural/isZero (Integer/clamp n)++        in        if mNonPos == nNonPos++            then  Natural/toInteger (mAbs * nAbs)++            else  Integer/negate (Natural/toInteger (mAbs * nAbs))++let example0 = assert : multiply +3 +5 ≡ +15++let example1 = assert : multiply -3 +5 ≡ -15++let example2 = assert : multiply -3 -5 ≡ +15++let example3 = assert : multiply +0 +5 ≡ +0++let example4 = assert : multiply +5 +0 ≡ +0++let example5 = assert : multiply +0 +0 ≡ +0++let example6 = assert : multiply +1 +5 ≡ +5++let example7 = assert : multiply +3 -1 ≡ -3++in  multiply

+ dhall-lang/Prelude/Integer/negate view

@@ -0,0 +1,14 @@+{-+Invert the sign of an `Integer`, with zero remaining unchanged.+-}+let negate+    : Integer → Integer+    = Integer/negate++let example0 = assert : negate -3 ≡ +3++let example2 = assert : negate +7 ≡ -7++let example3 = assert : negate +0 ≡ +0++in  negate

dhall-lang/Prelude/Integer/package.dhall view

@@ -1,7 +1,43 @@-{ show =+{ abs =+      ./abs sha256:35212fcbe1e60cb95b033a4a9c6e45befca4a298aa9919915999d09e69ddced1+    ? ./abs+, add =+      ./add sha256:96f1ae60f958febc911935ac4aa2685394642b116b7bddcec7e1ed201a69ed2c+    ? ./add+, clamp =+      ./clamp sha256:ea42096cf3e024fadfaf910e0b839005b0ea7514fff11e5a3950a77694d9c5d2+    ? ./clamp+, equal =+      ./equal sha256:e4414b9eef4142eed6bb0b52eb6fd0074210b68d210e96dd5161697b0f14426a+    ? ./equal+, greaterThan =+      ./greaterThan sha256:accaa6b7cbca7ec2ace4a529e5f3bb57679df2b5ad962bde5b7867d9253d4b8c+    ? ./greaterThan+, greaterThanEqual =+      ./greaterThanEqual sha256:cede1f63b58cb26623148ef741f18e6476ad71d9d541dd54be2b1ec4972a4ad0+    ? ./greaterThanEqual+, lessThan =+      ./lessThan sha256:14cc3bc6ca8757f7c3af338f079fcc18e0c7ee3ed0d20914a9693aec81ae628d+    ? ./lessThan+, lessThanEqual =+      ./lessThanEqual sha256:a849203a9cd270210588f9db23e02b819117a997df1c8131b6f9a634cb2e5c8d+    ? ./lessThanEqual+, multiply =+      ./multiply sha256:71b2a720976c70f0cd06baba9c213867b9744e655927dc3857fa92c864c3cf86+    ? ./multiply+, negate =+      ./negate sha256:2373c992e1de93634bc6a8781eb073b2a92a70170133e49762a785f3a136df5d+    ? ./negate+, show =       ./show sha256:ecf8b0594cd5181bc45d3b7ea0d44d3ba9ad5dac6ec17bb8968beb65f4b1baa9     ? ./show+, subtract =+      ./subtract sha256:8de76d2e235eec1629750ae62e191f13631b36708bfda0425572d87e5a9a37e7+    ? ./subtract , toDouble =       ./toDouble sha256:77bc5d635dc4d952f37cc96f2a681d5ac503b4e8b21fc00055b1946adb5beda7     ? ./toDouble+, toNatural =+      ./toNatural sha256:68dabff205ffdb1ca0df3dabc561ce717b7ae6521c9da9eed893b923ae5a0e1c+    ? ./toNatural }

+ dhall-lang/Prelude/Integer/subtract view

@@ -0,0 +1,56 @@+{-+`subtract m n` computes `n - m`.+-}+let Natural/lessThanEqual =+        ../Natural/lessThanEqual sha256:1a5caa2b80a42b9f58fff58e47ac0d9a9946d0b2d36c54034b8ddfe3cb0f3c99+      ? ../Natural/lessThanEqual++let Integer/abs =+        ./abs sha256:35212fcbe1e60cb95b033a4a9c6e45befca4a298aa9919915999d09e69ddced1+      ? ./abs++let subtract+    : Integer → Integer → Integer+    =   λ(m : Integer)+      → λ(n : Integer)+      → let mAbs = Integer/abs m++        let nAbs = Integer/abs n++        let mNonPos = Natural/isZero (Integer/clamp m)++        let nNonPos = Natural/isZero (Integer/clamp n)++        let diff =+                    if mNonPos == nNonPos++              then        if Natural/lessThanEqual mAbs nAbs++                    then  Integer/negate+                            (Natural/toInteger (Natural/subtract mAbs nAbs))++                    else  Natural/toInteger (Natural/subtract nAbs mAbs)++              else  Natural/toInteger (mAbs + nAbs)++        in  if mNonPos then diff else Integer/negate diff++let example0 = assert : subtract +3 +5 ≡ +2++let example1 = assert : subtract +4 +4 ≡ +0++let example2 = assert : subtract +5 +3 ≡ -2++let example3 = assert : subtract -3 -5 ≡ -2++let example4 = assert : subtract -4 -4 ≡ +0++let example5 = assert : subtract -5 -3 ≡ +2++let example6 = assert : subtract -3 +5 ≡ +8++let example7 = assert : subtract +3 -5 ≡ -8++let example8 = assert : subtract +0 -3 ≡ -3++in  subtract

+ dhall-lang/Prelude/Integer/toNatural view

@@ -0,0 +1,19 @@+{-+Convert an `Integer` to an `Optional Natural`, with negative numbers becoming `None Natural`.+-}+let Integer/lessThan =+        ./lessThan sha256:14cc3bc6ca8757f7c3af338f079fcc18e0c7ee3ed0d20914a9693aec81ae628d+      ? ./lessThan++let toNatural+    : Integer → Optional Natural+    =   λ(n : Integer)+      → if Integer/lessThan n +0 then None Natural else Some (Integer/clamp n)++let example0 = assert : toNatural +7 ≡ Some 7++let example2 = assert : toNatural +0 ≡ Some 0++let example3 = assert : toNatural -3 ≡ None Natural++in  toNatural

dhall-lang/Prelude/JSON/Tagged view

@@ -62,11 +62,8 @@ -} let Tagged     : Type → Type-    =   λ ( a-          : Type-          )-      → { field :-            Text+    =   λ(a : Type)+      → { field : Text         , nesting :               ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335             ? ./Nesting

+ dhall-lang/Prelude/JSON/core.dhall view

@@ -0,0 +1,44 @@+{- A record of functions useful for constructing `JSON` values.++   This is only a subset of what `package.dhall` exports. If you are+   not writing a JSON prelude function, you should use the+   `package.dhall` file instead.++   It is used internally by `render`, `renderYAML` and+   `omitNullFields` instead of `package.dhall` to avoid import+   cycles.+-}+{ Type =+      ./Type sha256:5adb234f5868a5b0eddeb034d690aaba8cb94ea20d0d557003e90334fff6be3e+    ? ./Type+, Tagged =+      ./Tagged sha256:21feca7d2b23f210d0696131d792e18a7d24fdcc85d41a49ba85b98670eba194+    ? ./Tagged+, Nesting =+      ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335+    ? ./Nesting+, keyText =+      ./keyText sha256:f7b6c802ca5764d03d5e9a6e48d9cb167c01392f775d9c2c87b83cdaa60ea0cc+    ? ./keyText+, keyValue =+      ./keyValue sha256:a0a97199d280c4cce72ffcbbf93b7ceda0a569cf4d173ac98e0aaaa78034b98c+    ? ./keyValue+, string =+      ./string sha256:7a8ac435d30a96092d72889f3d48eabf7cba47ecf553fd6bc07a79fdf473e8d2+    ? ./string+, number =+      ./number sha256:534745568065ae19d2b0fe1d09eeb071e9717d0f392187eb0bc95f386b018bec+    ? ./number+, object =+      ./object sha256:a4e047cf157c3971b026b3942a87d474c85950d9b9654f8ebc8631740abf75a9+    ? ./object+, array =+      ./array sha256:3a4c06cf135f4c80619e48c0808f6600d19782705bc59ee7c27cfc2e0f097eb7+    ? ./array+, bool =+      ./bool sha256:018d29f030b45d642aba6bb81bf2c19a7bf183684612ce7a2c8afd2099783c48+    ? ./bool+, null =+      ./null sha256:52c1d45ab2ca54875b444bfb1afdea497c8c9b0652e5044fafd8b16d97f4b78d+    ? ./null+}

+ dhall-lang/Prelude/JSON/omitNullFields view

@@ -0,0 +1,141 @@+{-+This utility omits all `null` record fields, which is often the idiomatic way+for a configuration to encode absent fields+-}+let JSON =+        ./core.dhall sha256:22ba363a8622642e788ffdd8fb98e5a51b1be8ebfcbefe2853e74932078a60af+      ? ./core.dhall++let List/concatMap =+        ../List/concatMap sha256:3b2167061d11fda1e4f6de0522cbe83e0d5ac4ef5ddf6bb0b2064470c5d3fb64+      ? ../List/concatMap++let List/map =+        ../List/map sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680+      ? ../List/map++let omitNullFields+    : JSON.Type → JSON.Type+    =   λ(old : JSON.Type)+      → λ(JSON : Type)+      → λ ( json+          : { string : Text → JSON+            , number : Double → JSON+            , object : List { mapKey : Text, mapValue : JSON } → JSON+            , array : List JSON → JSON+            , bool : Bool → JSON+            , null : JSON+            }+          )+      → let result =+              old+                { value : JSON, isNull : Bool }+                { string =+                    λ(x : Text) → { value = json.string x, isNull = False }+                , number =+                    λ(x : Double) → { value = json.number x, isNull = False }+                , object =+                      λ ( keyValues+                        : List+                            { mapKey : Text+                            , mapValue : { value : JSON, isNull : Bool }+                            }+                        )+                    → let value =+                            json.object+                              ( List/concatMap+                                  { mapKey : Text+                                  , mapValue : { value : JSON, isNull : Bool }+                                  }+                                  { mapKey : Text, mapValue : JSON }+                                  (   λ ( keyValue+                                        : { mapKey : Text+                                          , mapValue :+                                              { value : JSON, isNull : Bool }+                                          }+                                        )+                                    →       if keyValue.mapValue.isNull++                                      then  [] : List+                                                   { mapKey : Text+                                                   , mapValue : JSON+                                                   }++                                      else  [   keyValue.{ mapKey }+                                              ∧ { mapValue =+                                                    keyValue.mapValue.value+                                                }+                                            ]+                                  )+                                  keyValues+                              )++                      in  { value = value, isNull = False }+                , array =+                      λ(xs : List { value : JSON, isNull : Bool })+                    → let value =+                            json.array+                              ( List/map+                                  { value : JSON, isNull : Bool }+                                  JSON+                                  (   λ(x : { value : JSON, isNull : Bool })+                                    → x.value+                                  )+                                  xs+                              )++                      in  { value = value, isNull = False }+                , bool = λ(x : Bool) → { value = json.bool x, isNull = False }+                , null = { value = json.null, isNull = True }+                }++        in  result.value++let property =+        λ(a : Text)+      → λ(b : Double)+      → λ(c : Bool)+      →   assert+        :   omitNullFields+              ( JSON.object+                  ( toMap+                      { string = JSON.string a+                      , number = JSON.number b+                      , bool = JSON.bool c+                      , null = JSON.null+                      }+                  )+              )+          ≡ JSON.object+              ( toMap+                  { string = JSON.string a+                  , number = JSON.number b+                  , bool = JSON.bool c+                  }+              )++let example =+        assert+      :   omitNullFields+            ( JSON.object+                ( toMap+                    { array =+                        JSON.array [ JSON.object (toMap { null = JSON.null }) ]+                    }+                )+            )+        ≡ JSON.object+            ( toMap+                { array =+                    JSON.array+                      [ JSON.object+                          ([] : List { mapKey : Text, mapValue : JSON.Type })+                      ]+                }+            )++let example =+        assert+      : omitNullFields (JSON.array [ JSON.null ]) ≡ JSON.array [ JSON.null ]++in  omitNullFields

dhall-lang/Prelude/JSON/package.dhall view

@@ -1,37 +1,19 @@-{ Type =-      ./Type sha256:5adb234f5868a5b0eddeb034d690aaba8cb94ea20d0d557003e90334fff6be3e-    ? ./Type-, Tagged =-      ./Tagged sha256:21feca7d2b23f210d0696131d792e18a7d24fdcc85d41a49ba85b98670eba194-    ? ./Tagged-, Nesting =-      ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335-    ? ./Nesting-, keyText =-      ./keyText sha256:f7b6c802ca5764d03d5e9a6e48d9cb167c01392f775d9c2c87b83cdaa60ea0cc-    ? ./keyText-, keyValue =-      ./keyValue sha256:a0a97199d280c4cce72ffcbbf93b7ceda0a569cf4d173ac98e0aaaa78034b98c-    ? ./keyValue-, string =-      ./string sha256:7a8ac435d30a96092d72889f3d48eabf7cba47ecf553fd6bc07a79fdf473e8d2-    ? ./string-, number =-      ./number sha256:534745568065ae19d2b0fe1d09eeb071e9717d0f392187eb0bc95f386b018bec-    ? ./number-, object =-      ./object sha256:a4e047cf157c3971b026b3942a87d474c85950d9b9654f8ebc8631740abf75a9-    ? ./object-, array =-      ./array sha256:3a4c06cf135f4c80619e48c0808f6600d19782705bc59ee7c27cfc2e0f097eb7-    ? ./array-, bool =-      ./bool sha256:018d29f030b45d642aba6bb81bf2c19a7bf183684612ce7a2c8afd2099783c48-    ? ./bool-, null =-      ./null sha256:52c1d45ab2ca54875b444bfb1afdea497c8c9b0652e5044fafd8b16d97f4b78d-    ? ./null-, render =-      ./render sha256:81f5a84efbb35211b1556838e86d17ed497912cf765bfa4ab76708b21e5371f1-    ? ./render-}+  { render =+        ./render sha256:81f5a84efbb35211b1556838e86d17ed497912cf765bfa4ab76708b21e5371f1+      ? ./render+  , renderYAML =+        ./renderYAML sha256:862b535f6b905f1ce4b83207c58dd53ce5af0026da4c0960a3aec90fdbbb3eb0+      ? ./renderYAML+  , omitNullFields =+        ./omitNullFields sha256:c28270c553f48c406bd161c61776963315e278af5dae9331c4a320c3f4ecb4ec+      ? ./omitNullFields+  , tagInline =+        ./tagInline sha256:49559ac11906ba6cc9eac25753e31e7addb13bc760df108024174c55523984c4+      ? ./tagInline+  , tagNested =+        ./tagNested sha256:93a7415853b7677c832246efadc8e880c1b641a23589286a836a384ca311d26f+      ? ./tagNested+  }+∧ (   ./core.dhall sha256:22ba363a8622642e788ffdd8fb98e5a51b1be8ebfcbefe2853e74932078a60af+    ? ./core.dhall+  )

dhall-lang/Prelude/JSON/render view

@@ -2,34 +2,18 @@     This is useful for debugging `JSON` values or for tests.  For anything    more sophisticated you should use `dhall-to-json` or `dhall-to-yaml`--```-let JSON = ./package.dhall--in  JSON.render-    ( JSON.array-      [ JSON.bool True-      , JSON.string "Hello"-      , JSON.object-        [ { mapKey = "foo", mapValue = JSON.null       }-        , { mapKey = "bar", mapValue = JSON.number 1.0 }-        ]-      ]-    )-= "[ true, \"Hello\", { \"foo\": null, \"bar\": 1.0 } ]"-``` -} let JSON =-        ./Type sha256:5adb234f5868a5b0eddeb034d690aaba8cb94ea20d0d557003e90334fff6be3e-      ? ./Type+        ./core.dhall sha256:22ba363a8622642e788ffdd8fb98e5a51b1be8ebfcbefe2853e74932078a60af+      ? ./core.dhall  let Text/concatMapSep =         ../Text/concatMapSep sha256:c272aca80a607bc5963d1fcb38819e7e0d3e72ac4d02b1183b1afb6a91340840       ? ../Text/concatMapSep  let render-    : JSON → Text-    =   λ(j : JSON)+    : JSON.Type → Text+    =   λ(j : JSON.Type)       → j           Text           { string = λ(x : Text) → Text/show x@@ -44,15 +28,29 @@                           → " ${Text/show e.mapKey}: ${e.mapValue}"                         )                         x-                +                 in  "{${body} }"           , array =                 λ(x : List Text)               → let body = Text/concatMapSep "," Text (λ(y : Text) → " ${y}") x-                +                 in  "[${body} ]"           , bool = λ(x : Bool) → if x then "true" else "false"           , null = "null"           }++let example0 =+        assert+      :   render+            ( JSON.array+                [ JSON.bool True+                , JSON.string "Hello"+                , JSON.object+                    [ { mapKey = "foo", mapValue = JSON.null }+                    , { mapKey = "bar", mapValue = JSON.number 1.0 }+                    ]+                ]+            )+        ≡ "[ true, \"Hello\", { \"foo\": null, \"bar\": 1.0 } ]"  in  render

+ dhall-lang/Prelude/JSON/renderYAML view

@@ -0,0 +1,175 @@+{- Render a `JSON` value as `Text` in YAML format.++   The generated YAML text will only contain escaped object keys and+   string values and might therefore not be very human readable.++   However, it is useful for debugging `JSON` values or for tests.+   For anything more sophisticated you should use `dhall-to-json` or+   `dhall-to-yaml`.+-}++let JSON =+        ./core.dhall sha256:22ba363a8622642e788ffdd8fb98e5a51b1be8ebfcbefe2853e74932078a60af+      ? ./core.dhall++let Text/concatSep =+        ../Text/concatSep sha256:e4401d69918c61b92a4c0288f7d60a6560ca99726138ed8ebc58dca2cd205e58+      ? ../Text/concatSep++let List/drop =+        ../List/drop sha256:af983ba3ead494dd72beed05c0f3a17c36a4244adedf7ced502c6512196ed0cf+      ? ../List/drop++let List/null =+        ../List/null sha256:2338e39637e9a50d66ae1482c0ed559bbcc11e9442bfca8f8c176bbcd9c4fc80+      ? ../List/null++let List/map =+        ../List/map sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680+      ? ../List/map++let List/concatMap =+        ../List/concatMap sha256:3b2167061d11fda1e4f6de0522cbe83e0d5ac4ef5ddf6bb0b2064470c5d3fb64+      ? ../List/concatMap++let Optional/map =+        ../Optional/map sha256:e7f44219250b89b094fbf9996e04b5daafc0902d864113420072ae60706ac73d+      ? ../Optional/map++let NonEmpty+    : Type → Type+    = λ(a : Type) → { head : a, tail : List a }++let uncons+    : ∀(a : Type) → List a → Optional (NonEmpty a)+    =   λ(a : Type)+      → λ(ls : List a)+      → Optional/map+          a+          (NonEmpty a)+          (λ(head : a) → { head = head, tail = List/drop 1 a ls })+          (List/head a ls)++let nonEmptyToList+    : ∀(a : Type) → NonEmpty a → List a+    = λ(a : Type) → λ(nonEmpty : NonEmpty a) → [ nonEmpty.head ] # nonEmpty.tail++let concatNonEmpty+    : ∀(a : Type) → NonEmpty (NonEmpty a) → NonEmpty a+    =   λ(a : Type)+      → λ(lss : NonEmpty (NonEmpty a))+      → { head = lss.head.head+        , tail =+              lss.head.tail+            # List/concatMap (NonEmpty a) a (nonEmptyToList a) lss.tail+        }++let Block+    : Type+    = NonEmpty Text++let indentBlockWith+    : Text → Text → Block → Block+    =   λ(headIndent : Text)+      → λ(tailIndent : Text)+      → λ(block : Block)+      → { head = headIndent ++ block.head+        , tail = List/map Text Text (λ(t : Text) → tailIndent ++ t) block.tail+        }++let manyBlocks+    : Block → List Block → Block+    =   λ(ifEmpty : Block)+      → λ(blocks : List Block)+      → Optional/fold+          (NonEmpty Block)+          (uncons Block blocks)+          Block+          (concatNonEmpty Text)+          ifEmpty++let singleLine+    : Text → Block+    = λ(text : Text) → { head = text, tail = [] : List Text }++let indentKeyedBlock+    : Text → Text → Text → Block → Block+    =   λ(key : Text)+      → λ(spacer : Text)+      → λ(indentation : Text)+      → λ(block : Block)+      →       if List/null Text block.tail++        then  singleLine (key ++ spacer ++ block.head)++        else  indentBlockWith+                key+                indentation+                { head = "", tail = nonEmptyToList Text block }++let blockToText+    : Block → Text+    = λ(block : Block) → Text/concatSep "\n" (nonEmptyToList Text block) ++ "\n"++let renderYAML+    : JSON.Type → Text+    =   λ(json : JSON.Type)+      → let ObjectField = { mapKey : Text, mapValue : Block }++        in  blockToText+              ( json+                  Block+                  { string = λ(x : Text) → singleLine (Text/show x)+                  , number = λ(x : Double) → singleLine (Double/show x)+                  , object =+                        λ(fields : List ObjectField)+                      → manyBlocks+                          (singleLine "{}")+                          ( List/map+                              ObjectField+                              Block+                              (   λ(e : ObjectField)+                                → indentKeyedBlock+                                    "! ${Text/show e.mapKey}:"+                                    " "+                                    "  "+                                    e.mapValue+                              )+                              fields+                          )+                  , array =+                        λ(elements : List Block)+                      → manyBlocks+                          (singleLine "[]")+                          ( List/map+                              Block+                              Block+                              (indentBlockWith "- " "  ")+                              elements+                          )+                  , bool =+                      λ(x : Bool) → singleLine (if x then "true" else "false")+                  , null = singleLine "null"+                  }+              )++let example0 =+        assert+      :   renderYAML+            ( JSON.array+                [ JSON.bool True+                , JSON.string "Hello"+                , JSON.object+                    [ { mapKey = "foo", mapValue = JSON.null }+                    , { mapKey = "bar", mapValue = JSON.number 1.0 }+                    ]+                ]+            )+        ≡ ''+          - true+          - "Hello"+          - ! "foo": null+            ! "bar": 1.0+          ''++in  renderYAML

+ dhall-lang/Prelude/JSON/tagInline view

@@ -0,0 +1,28 @@+{- Prepare a union value for JSON- or YAML-encoding with the inline layout+-}+let Nesting =+        ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335+      ? ./Nesting++let Tagged =+        ./Tagged sha256:21feca7d2b23f210d0696131d792e18a7d24fdcc85d41a49ba85b98670eba194+      ? ./Tagged++let tagInline+    : Text → ∀(a : Type) → a → Tagged a+    =   λ(tagFieldName : Text)+      → λ(a : Type)+      → λ(contents : a)+      → { nesting = Nesting.Inline, field = tagFieldName, contents = contents }++let example0 =+      let Example = < Left : { foo : Natural } | Right : { bar : Bool } >++      in    assert+          :   tagInline "name" Example (Example.Left { foo = 2 })+            ≡ { field = "name"+              , nesting = Nesting.Inline+              , contents = Example.Left { foo = 2 }+              }++in  tagInline

+ dhall-lang/Prelude/JSON/tagNested view

@@ -0,0 +1,32 @@+{- Prepare a union value for JSON- or YAML-encoding with the nested layout+-}+let Nesting =+        ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335+      ? ./Nesting++let Tagged =+        ./Tagged sha256:21feca7d2b23f210d0696131d792e18a7d24fdcc85d41a49ba85b98670eba194+      ? ./Tagged++let tagNested+    : Text → Text → ∀(a : Type) → a → Tagged a+    =   λ(contentsFieldName : Text)+      → λ(tagFieldName : Text)+      → λ(a : Type)+      → λ(contents : a)+      → { nesting = Nesting.Nested contentsFieldName+        , field = tagFieldName+        , contents = contents+        }++let example0 =+      let Example = < Left : { foo : Natural } | Right : { bar : Bool } >++      in    assert+          :   tagNested "value" "name" Example (Example.Left { foo = 2 })+            ≡ { field = "name"+              , nesting = Nesting.Nested "value"+              , contents = Example.Left { foo = 2 }+              }++in  tagNested

+ dhall-lang/Prelude/List/drop view

@@ -0,0 +1,29 @@+-- Remove first `n` elements of a list+let Natural/greaterThanEqual =+        ../Natural/greaterThanEqual sha256:30ebfab0febd7aa0ccccfdf3dc36ee6d50f0117f35dd4a9b034750b7e885a1a4+      ? ../Natural/greaterThanEqual++let drop+    : ∀(n : Natural) → ∀(a : Type) → List a → List a+    =   λ(n : Natural)+      → λ(a : Type)+      → λ(xs : List a)+      → List/fold+          { index : Natural, value : a }+          (List/indexed a xs)+          (List a)+          (   λ(x : { index : Natural, value : a })+            → λ(xs : List a)+            →       if Natural/greaterThanEqual x.index n++              then  [ x.value ] # xs++              else  xs+          )+          ([] : List a)++let example = assert : drop 2 Natural [ 2, 3, 5 ] ≡ [ 5 ]++let example = assert : drop 5 Natural [ 2, 3, 5 ] ≡ ([] : List Natural)++in  drop

dhall-lang/Prelude/List/package.dhall view

@@ -16,6 +16,9 @@ , default =       ./default sha256:0ed2a04df6c1d55c08bcdbad82b30980af9ac40d2df7a1628f3663e3e8b4fe01     ? ./default+, drop =+      ./drop sha256:af983ba3ead494dd72beed05c0f3a17c36a4244adedf7ced502c6512196ed0cf+    ? ./drop , empty =       ./empty sha256:b2f561f35098c457353723c93a22bd5de28d26ecc5370814bef9dfda421e0147     ? ./empty@@ -49,6 +52,9 @@ , null =       ./null sha256:2338e39637e9a50d66ae1482c0ed559bbcc11e9442bfca8f8c176bbcd9c4fc80     ? ./null+, partition =+      ./partition sha256:38147ac6d750a6492736dd90cc967bf09aa405c499de943c64fab7b86ae02f03+    ? ./partition , replicate =       ./replicate sha256:d4250b45278f2d692302489ac3e78280acb238d27541c837ce46911ff3baa347     ? ./replicate@@ -58,6 +64,9 @@ , shifted =       ./shifted sha256:54fb22c7e952ebce1cfc0fcdd33ce4cfa817bff9d6564af268dea6685f8b5dfe     ? ./shifted+, take =+      ./take sha256:b3e08ee8c3a5bf3d8ccee6b2b2008fbb8e51e7373aef6f1af67ad10078c9fbfa+    ? ./take , unzip =       ./unzip sha256:4d6003e9e683a289fe33f4c90f958eb1e08ea0bbb474210fcd90d1885c9660e9     ? ./unzip

+ dhall-lang/Prelude/List/partition view

@@ -0,0 +1,33 @@+{-+`partition` divides a `List` of elements into those that satisfy a predicate+and those that do not+-}+let Partition+    : Type → Type+    = λ(a : Type) → { true : List a, false : List a }++let partition+    : ∀(a : Type) → (a → Bool) → List a → Partition a+    =   λ(a : Type)+      → λ(f : a → Bool)+      → λ(xs : List a)+      → List/fold+          a+          xs+          (Partition a)+          (   λ(x : a)+            → λ(p : Partition a)+            →       if f x++              then  { true = [ x ] # p.true, false = p.false }++              else  { true = p.true, false = [ x ] # p.false }+          )+          { true = [] : List a, false = [] : List a }++let example0 =+        assert+      :   partition Natural Natural/even [ 0, 1, 2, 3 ]+        ≡ { true = [ 0, 2 ], false = [ 1, 3 ] }++in  partition

dhall-lang/Prelude/List/shifted view

@@ -22,7 +22,7 @@                         → λ(y : { count : Natural, diff : Natural → list })                         → let length =                                 List/length { index : Natural, value : a } kvs-                          +                           in  { count = y.count + length                               , diff =                                     λ(n : Natural)@@ -38,14 +38,14 @@                                                 { index = kvOld.index + n                                                 , value = kvOld.value                                                 }-                                          +                                           in  cons kvNew z                                       )                                       (y.diff (n + length))                               }                       )                       { count = 0, diff = λ(_ : Natural) → nil }-              +               in  result.diff 0           )

+ dhall-lang/Prelude/List/take view

@@ -0,0 +1,25 @@+-- Truncate a list to the first `n` elements+let Natural/lessThan =+        ../Natural/lessThan sha256:3381b66749290769badf8855d8a3f4af62e8de52d1364d838a9d1e20c94fa70c+      ? ../Natural/lessThan++let take+    : ∀(n : Natural) → ∀(a : Type) → List a → List a+    =   λ(n : Natural)+      → λ(a : Type)+      → λ(xs : List a)+      → List/fold+          { index : Natural, value : a }+          (List/indexed a xs)+          (List a)+          (   λ(x : { index : Natural, value : a })+            → λ(xs : List a)+            → if Natural/lessThan x.index n then [ x.value ] # xs else xs+          )+          ([] : List a)++let example = assert : take 2 Natural [ 2, 3, 5 ] ≡ [ 2, 3 ]++let example = assert : take 5 Natural [ 2, 3, 5 ] ≡ [ 2, 3, 5 ]++in  take

+ dhall-lang/Prelude/Natural/listMax view

@@ -0,0 +1,28 @@+{-+`listMax` returns the largest element of a `List` or `None Natural` if the+`List` is empty+-}+let max =+        ./max sha256:1f3b18da330223ab039fad11693da72c7e68d516f50502c73f41a89a097b62f7+      ? ./max++let Optional/map =+        ../Optional/map sha256:e7f44219250b89b094fbf9996e04b5daafc0902d864113420072ae60706ac73d+      ? ../Optional/map++let listMax+    : List Natural → Optional Natural+    =   λ(xs : List Natural)+      → Optional/map+          Natural+          Natural+          (λ(n : Natural) → List/fold Natural xs Natural max n)+          (List/head Natural xs)++let example0 = assert : listMax [ 1, 2 ] ≡ Some 2++let example1 = assert : listMax ([] : List Natural) ≡ None Natural++let property0 = λ(n : Natural) → assert : listMax [ n ] ≡ Some n++in  listMax

+ dhall-lang/Prelude/Natural/listMin view

@@ -0,0 +1,32 @@+{-+`listMin` returns the smallest element of a `List` or `None Natural` if the+`List` is empty+-}+let min =+        ./min sha256:f25f9c462e4dbf0eb15f9ff6ac840c6e9c82255a7f4f2ab408bdab338e028710+      ? ./min++let Optional/map =+        ../Optional/map sha256:e7f44219250b89b094fbf9996e04b5daafc0902d864113420072ae60706ac73d+      ? ../Optional/map++let listMin+    : List Natural → Optional Natural+    =   λ(xs : List Natural)+      → Optional/map+          Natural+          Natural+          (   λ(n : Natural)+            → if Natural/isZero n then n else List/fold Natural xs Natural min n+          )+          (List/head Natural xs)++let example0 = assert : listMin [ 0, 1 ] ≡ Some 0++let example1 = assert : listMin ([] : List Natural) ≡ None Natural++let example2 = assert : listMin [ 3, 2, 1 ] ≡ Some 1++let property0 = λ(n : Natural) → assert : listMin [ n ] ≡ Some n++in  listMin

+ dhall-lang/Prelude/Natural/max view

@@ -0,0 +1,20 @@+{-+`max a b` returns the larger of `a` or `b`+-}+let lessThanEqual =+        ./lessThanEqual sha256:1a5caa2b80a42b9f58fff58e47ac0d9a9946d0b2d36c54034b8ddfe3cb0f3c99+      ? ./lessThanEqual++let max+    : Natural → Natural → Natural+    = λ(a : Natural) → λ(b : Natural) → if lessThanEqual a b then b else a++let example0 = assert : max 1 2 ≡ 2++let example1 = assert : max 2 1 ≡ 2++let property0 = λ(n : Natural) → assert : max n n ≡ n++let property1 = λ(n : Natural) → assert : max 0 n ≡ n++in  max

+ dhall-lang/Prelude/Natural/min view

@@ -0,0 +1,18 @@+{-+`min a b` returns the smaller of `a` or `b`+-}+let lessThanEqual =+        ./lessThanEqual sha256:1a5caa2b80a42b9f58fff58e47ac0d9a9946d0b2d36c54034b8ddfe3cb0f3c99+      ? ./lessThanEqual++let min+    : Natural → Natural → Natural+    = λ(a : Natural) → λ(b : Natural) → if lessThanEqual a b then a else b++let example0 = assert : min 1 2 ≡ 1++let example1 = assert : min 2 1 ≡ 1++let property0 = λ(n : Natural) → assert : min n n ≡ n++in  min

dhall-lang/Prelude/Natural/package.dhall view

@@ -46,6 +46,21 @@ , greaterThan =       ./greaterThan sha256:f702abcdfcd7ad73619b9285d7e41c3a1d017fb6b8d037cf40bd93bf30c09b2c     ? ./greaterThan+, min =+      ./min sha256:f25f9c462e4dbf0eb15f9ff6ac840c6e9c82255a7f4f2ab408bdab338e028710+    ? ./min+, max =+      ./max sha256:1f3b18da330223ab039fad11693da72c7e68d516f50502c73f41a89a097b62f7+    ? ./max+, listMin =+      ./listMin sha256:89e0d9c23750efd8a8a2a6945579f21e46bd503b0655d4bfdd0e0e51e39c37cc+    ? ./listMin+, listMax =+      ./listMax sha256:30917e8ca230ea6044c6d8ea6e72bcf6f76437aaecc347f790e8a5946c6aa0e5+    ? ./listMax+, sort =+      ./sort sha256:ed2eb5a33c5c96ac9227b0b4c77bdbf8911026d721c603ac897ae84b2bfb5dcd+    ? ./sort , subtract =       ./subtract sha256:b9277ac637d09142a3a3ac79137ef5955c42f8b33b6746d59db2c9d75ccdd745     ? ./subtract

+ dhall-lang/Prelude/Natural/sort view

@@ -0,0 +1,60 @@+{-+`sort` sorts a `List` of `Natural`s in ascending order+-}+let greaterThanEqual =+        ./greaterThanEqual sha256:30ebfab0febd7aa0ccccfdf3dc36ee6d50f0117f35dd4a9b034750b7e885a1a4+      ? ./greaterThanEqual++let listMin =+        ./listMin sha256:89e0d9c23750efd8a8a2a6945579f21e46bd503b0655d4bfdd0e0e51e39c37cc+      ? ./listMin++let List/partition =+        ../List/partition sha256:38147ac6d750a6492736dd90cc967bf09aa405c499de943c64fab7b86ae02f03+      ? ../List/partition++let Accumulator = { sorted : List Natural, rest : List Natural }++let partitionMinima =+        λ(xs : List Natural)+      → Optional/fold+          Natural+          (listMin xs)+          { true : List Natural, false : List Natural }+          (λ(m : Natural) → List/partition Natural (greaterThanEqual m) xs)+          { true = [] : List Natural, false = [] : List Natural }++let test0 =+        assert+      : partitionMinima [ 2, 1, 1, 3 ] ≡ { true = [ 1, 1 ], false = [ 2, 3 ] }++let step =+        λ(x : Accumulator)+      → let p = partitionMinima x.rest++        in  { sorted = x.sorted # p.true, rest = p.false }++let test1 =+        assert+      :   step { sorted = [ 1, 1 ], rest = [ 2, 3 ] }+        ≡ { sorted = [ 1, 1, 2 ], rest = [ 3 ] }++let sort+    : List Natural → List Natural+    =   λ(xs : List Natural)+      → let x =+              Natural/fold+                (List/length Natural xs)+                Accumulator+                step+                { sorted = [] : List Natural, rest = xs }++        in  x.sorted++let example0 = assert : sort ([] : List Natural) ≡ ([] : List Natural)++let example1 = assert : sort [ 1 ] ≡ [ 1 ]++let example2 = assert : sort [ 3, 2, 1, 3, 2, 1 ] ≡ [ 1, 1, 2, 2, 3, 3 ]++in  sort

dhall-lang/Prelude/Text/concatMapSep view

@@ -26,7 +26,7 @@                       status                 )                 Status.Empty-        +         in  merge { Empty = "", NonEmpty = λ(result : Text) → result } status  let example0 =

dhall-lang/Prelude/Text/concatSep view

@@ -23,7 +23,7 @@                       status                 )                 Status.Empty-        +         in  merge { Empty = "", NonEmpty = λ(result : Text) → result } status  let example0 = assert : concatSep ", " [ "ABC", "DEF", "GHI" ] ≡ "ABC, DEF, GHI"

dhall-lang/Prelude/Text/show view

@@ -9,6 +9,11 @@ let example0 = assert : show "ABC" ≡ "\"ABC\""  let example1 =-      assert : show "\u0000 \$ \\ \n ☺" ≡ "\"\\u0000 \\u0024 \\\\ \\n ☺\""+        assert+      :   show+            ''+            ${"\u0000"} $ \ +            ${" "}☺''+        ≡ "\"\\u0000 \\u0024 \\\\ \\n ☺\""  in  show

dhall-lang/Prelude/XML/render view

@@ -52,13 +52,13 @@                     }                   )               → let attribs = Text/concatMap Attr renderAttr elem.attributes-                +                 in      "<${elem.name}${attribs}"                     ++  (       if Natural/isZero                                      (List/length Text elem.content)-                          +                           then  "/>"-                          +                           else  ">${Text/concat elem.content}</${elem.name}>"                         )           }

dhall-lang/Prelude/package.dhall view

@@ -8,10 +8,10 @@       ./Function/package.dhall sha256:74c3822b98b9d37f9f820af8e1a7ee790bcfac03050eabd45af4a255fb93e026     ? ./Function/package.dhall , Integer =-      ./Integer/package.dhall sha256:eb464566d3192dd16ce915a9bd874aaaad612d5c69beb356e5b7d2e0c4949dcf+      ./Integer/package.dhall sha256:dbc82e5542a642b9372ce6126967028c0cade2b8ad6923312b086b686ad67e06     ? ./Integer/package.dhall , List =-      ./List/package.dhall sha256:88ae09f29981480e62a39c925011b3246d716a80871440f071cf981efea1ad5e+      ./List/package.dhall sha256:f0fdab7ab30415c128d89424589c42a15c835338be116fa14484086e4ba118d7     ? ./List/package.dhall , Location =       ./Location/package.dhall sha256:0eb4e4a60814018009c720f6820aaa13cf9491eb1b09afb7b832039c6ee4d470@@ -23,13 +23,13 @@       ./Monoid sha256:26fafa098600ef7a54ef9dba5ada416bbbdd21df1af306c052420c61553ad4af     ? ./Monoid , Natural =-      ./Natural/package.dhall sha256:4574df29e6bb82fd894c311f6c2ad9a22574756eb62f06d475aa8306d25006fc+      ./Natural/package.dhall sha256:e230d4ee318826ab9517ae5d6f38d1a9359d7cff815cc32912cc6b991656bb1a     ? ./Natural/package.dhall , Optional =       ./Optional/package.dhall sha256:7608f2d38dabee8bfe6865b4adc11289059984220f422d2b023b15b3908f7a4c     ? ./Optional/package.dhall , JSON =-      ./JSON/package.dhall sha256:0c3c40a63108f2e6ad59f23b789c18eb484d0e9aebc9416c5a4f338c6753084b+      ./JSON/package.dhall sha256:843783d29e60b558c2de431ce1206ce34bdfde375fcf06de8ec5bf77092fdef7     ? ./JSON/package.dhall , Text =       ./Text/package.dhall sha256:0a0ad9f649aed94c2680491efb384925b5b2bb5b353f1b8a7eb134955c1ffe45

+ dhall-lang/tests/binary-decode/success/unit/IntegerBigNegativeA.dhallb view

@@ -0,0 +1,1 @@+ÃIÿÿÿÿÿÿÿÿ

+ dhall-lang/tests/binary-decode/success/unit/IntegerBigNegativeB.dhall view

@@ -0,0 +1,2 @@+{- -2^65 -}+-36893488147419103232

+ dhall-lang/tests/binary-decode/success/unit/IntegerBigPositiveA.dhallb view

binary file changed (absent → 13 bytes)

+ dhall-lang/tests/binary-decode/success/unit/IntegerBigPositiveB.dhall view

@@ -0,0 +1,2 @@+{- 2^65 -}++36893488147419103232

+ dhall-lang/tests/binary-decode/success/unit/NaturalBigA.dhallb view

binary file changed (absent → 13 bytes)

+ dhall-lang/tests/binary-decode/success/unit/NaturalBigB.dhall view

@@ -0,0 +1,2 @@+{- 2^65 -}+36893488147419103232

+ dhall-lang/tests/import/success/referentiallyTransparentMissing.dhall view

@@ -0,0 +1,9 @@+{- This test verifies that `missing` is treated as a referentially transparent+   import.  The following import contains a `missing as Location` in its+   test assertion that should succeed since:++   * The `missing` is never actually resolved (due to the `as Location`)+   * The `missing` should be treated as referentially transparent (and therefore+     be a valid transitive dependency of a remote import)+-}+https://prelude.dhall-lang.org/v11.0.0/Location/Type

+ dhall-lang/tests/normalization/success/unit/IntegerClampA.dhall view

@@ -0,0 +1,1 @@+Integer/clamp

+ dhall-lang/tests/normalization/success/unit/IntegerClampB.dhall view

@@ -0,0 +1,1 @@+Integer/clamp

+ dhall-lang/tests/normalization/success/unit/IntegerClampNegativeA.dhall view

@@ -0,0 +1,1 @@+Integer/clamp -6

+ dhall-lang/tests/normalization/success/unit/IntegerClampNegativeB.dhall view

@@ -0,0 +1,1 @@+0

+ dhall-lang/tests/normalization/success/unit/IntegerClampPositiveA.dhall view

@@ -0,0 +1,1 @@+Integer/clamp +5

+ dhall-lang/tests/normalization/success/unit/IntegerClampPositiveB.dhall view

@@ -0,0 +1,1 @@+5

+ dhall-lang/tests/normalization/success/unit/IntegerClampZeroA.dhall view

@@ -0,0 +1,1 @@+Integer/clamp +0

+ dhall-lang/tests/normalization/success/unit/IntegerClampZeroB.dhall view

@@ -0,0 +1,1 @@+0

+ dhall-lang/tests/normalization/success/unit/IntegerNegateA.dhall view

@@ -0,0 +1,1 @@+Integer/negate

+ dhall-lang/tests/normalization/success/unit/IntegerNegateB.dhall view

@@ -0,0 +1,1 @@+Integer/negate

+ dhall-lang/tests/normalization/success/unit/IntegerNegateNegativeA.dhall view

@@ -0,0 +1,1 @@+Integer/negate -7

+ dhall-lang/tests/normalization/success/unit/IntegerNegateNegativeB.dhall view

@@ -0,0 +1,1 @@++7

+ dhall-lang/tests/normalization/success/unit/IntegerNegatePositiveA.dhall view

@@ -0,0 +1,1 @@+Integer/negate +3

+ dhall-lang/tests/normalization/success/unit/IntegerNegatePositiveB.dhall view

@@ -0,0 +1,1 @@+-3

+ dhall-lang/tests/normalization/success/unit/IntegerNegateZeroA.dhall view

@@ -0,0 +1,1 @@+Integer/negate +0

+ dhall-lang/tests/normalization/success/unit/IntegerNegateZeroB.dhall view

@@ -0,0 +1,1 @@++0

dhall-lang/tests/normalization/success/unit/ListBuildFoldFusionB.dhall view

@@ -1,1 +1,8 @@-λ(T : Type) → λ(x : List T) → x+  λ(T : Type)+→ λ(x : List T)+→ List/fold+    T+    x+    (List T)+    (λ(a : T) → λ(`as` : List T) → [ a ] # `as`)+    ([] : List T)

dhall-lang/tests/normalization/success/unit/NaturalBuildFoldFusionB.dhall view

@@ -1,1 +1,1 @@-λ(x : Natural) → x+λ(x : Natural) → Natural/fold x Natural (λ(n : Natural) → n + 1) 0

dhall-lang/tests/normalization/success/unit/OptionalBuildFoldFusionB.dhall view

@@ -1,1 +1,3 @@-λ(T : Type) → λ(x : Optional T) → x+  λ(T : Type)+→ λ(x : Optional T)+→ Optional/fold T x (Optional T) (λ(a : T) → Some a) (None T)

+ dhall-lang/tests/parser/failure/nonCharacterUnbraced.dhall view

@@ -0,0 +1,6 @@+{-+The parser should reject unicode escape sequences for non-characters+(0xNFFFE-0xNFFFF for each `N` in `{ 0 .. F }), regardless of whether they are+braced or not.+-}+"\uFFFE"

+ dhall-lang/tests/parser/failure/surrogatePairUnbraced.dhall view

@@ -0,0 +1,5 @@+{-+The parser should reject unicode escape sequences for surrogate pairs+(0xD800-DFFF), regardless of whether they are braced or not.+-}+"\uD800"

+ dhall-lang/tests/parser/success/missingFooA.dhall view

@@ -0,0 +1,1 @@+missingFoo

+ dhall-lang/tests/parser/success/missingFooB.dhallb view

binary file changed (absent → 13 bytes)

+ dhall-lang/tests/parser/success/missingInParenthesesA.dhall view

@@ -0,0 +1,1 @@+(missing)

+ dhall-lang/tests/parser/success/missingInParenthesesB.dhallb view

binary file changed (absent → 6 bytes)

+ dhall-lang/tests/parser/success/missingSlashA.dhall view

@@ -0,0 +1,1 @@+missing/

+ dhall-lang/tests/parser/success/missingSlashB.dhallb view

binary file changed (absent → 11 bytes)

+ dhall-lang/tests/parser/success/preferMissingNoSpacesA.dhall view

@@ -0,0 +1,1 @@+missing//foo

+ dhall-lang/tests/parser/success/preferMissingNoSpacesB.dhallb view

binary file changed (absent → 15 bytes)

+ dhall-lang/tests/parser/success/text/nonAssignedUnicodeA.dhall view

@@ -0,0 +1,1 @@+"\u{1FFF0}"

+ dhall-lang/tests/parser/success/text/nonAssignedUnicodeB.dhallb view

@@ -0,0 +1,1 @@+dð¿°

dhall-lang/tests/parser/success/unit/CompletionA.dhall view

@@ -1,1 +1,1 @@-T::r+T :: r

dhall-lang/tests/type-inference/success/preludeB.dhall view

@@ -21,7 +21,22 @@         → ∀(x : A)         → C     }-, Integer : { show : Integer → Text, toDouble : Integer → Double }+, Integer :+    { abs : ∀(n : Integer) → Natural+    , add : ∀(m : Integer) → ∀(n : Integer) → Integer+    , clamp : Integer → Natural+    , equal : ∀(a : Integer) → ∀(b : Integer) → Bool+    , greaterThan : ∀(x : Integer) → ∀(y : Integer) → Bool+    , greaterThanEqual : ∀(x : Integer) → ∀(y : Integer) → Bool+    , lessThan : ∀(x : Integer) → ∀(y : Integer) → Bool+    , lessThanEqual : ∀(x : Integer) → ∀(y : Integer) → Bool+    , multiply : ∀(m : Integer) → ∀(n : Integer) → Integer+    , negate : Integer → Integer+    , show : Integer → Text+    , subtract : ∀(m : Integer) → ∀(n : Integer) → Integer+    , toDouble : Integer → Double+    , toNatural : ∀(n : Integer) → Optional Natural+    } , JSON :     { Nesting : Type     , Tagged : ∀(a : Type) → Type@@ -129,6 +144,31 @@               }             )         → JSON+    , omitNullFields :+          ∀ ( old+            :   ∀(JSON : Type)+              → ∀ ( json+                  : { array : List JSON → JSON+                    , bool : Bool → JSON+                    , null : JSON+                    , number : Double → JSON+                    , object : List { mapKey : Text, mapValue : JSON } → JSON+                    , string : Text → JSON+                    }+                  )+              → JSON+            )+        → ∀(JSON : Type)+        → ∀ ( json+            : { array : List JSON → JSON+              , bool : Bool → JSON+              , null : JSON+              , number : Double → JSON+              , object : List { mapKey : Text, mapValue : JSON } → JSON+              , string : Text → JSON+              }+            )+        → JSON     , render :           ∀ ( j             :   ∀(JSON : Type)@@ -144,6 +184,21 @@               → JSON             )         → Text+    , renderYAML :+          ∀ ( json+            :   ∀(JSON : Type)+              → ∀ ( json+                  : { array : List JSON → JSON+                    , bool : Bool → JSON+                    , null : JSON+                    , number : Double → JSON+                    , object : List { mapKey : Text, mapValue : JSON } → JSON+                    , string : Text → JSON+                    }+                  )+              → JSON+            )+        → Text     , string :           ∀(x : Text)         → ∀(JSON : Type)@@ -157,6 +212,17 @@               }             )         → JSON+    , tagInline :+          ∀(tagFieldName : Text)+        → ∀(a : Type)+        → ∀(contents : a)+        → { contents : a, field : Text, nesting : < Inline | Nested : Text > }+    , tagNested :+          ∀(contentsFieldName : Text)+        → ∀(tagFieldName : Text)+        → ∀(a : Type)+        → ∀(contents : a)+        → { contents : a, field : Text, nesting : < Inline | Nested : Text > }     } , List :     { all : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : List a) → Bool@@ -169,6 +235,7 @@     , concatMap :         ∀(a : Type) → ∀(b : Type) → ∀(f : a → List b) → ∀(xs : List a) → List b     , default : ∀(a : Type) → ∀(o : Optional (List a)) → List a+    , drop : ∀(n : Natural) → ∀(a : Type) → ∀(xs : List a) → List a     , empty : ∀(a : Type) → List a     , filter : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : List a) → List a     , fold :@@ -186,12 +253,18 @@     , length : ∀(a : Type) → List a → Natural     , map : ∀(a : Type) → ∀(b : Type) → ∀(f : a → b) → ∀(xs : List a) → List b     , null : ∀(a : Type) → ∀(xs : List a) → Bool+    , partition :+          ∀(a : Type)+        → ∀(f : a → Bool)+        → ∀(xs : List a)+        → { false : List a, true : List a }     , replicate : ∀(n : Natural) → ∀(a : Type) → ∀(x : a) → List a     , reverse : ∀(a : Type) → List a → List a     , shifted :           ∀(a : Type)         → ∀(kvss : List (List { index : Natural, value : a }))         → List { index : Natural, value : a }+    , take : ∀(n : Natural) → ∀(a : Type) → ∀(xs : List a) → List a     , unzip :           ∀(a : Type)         → ∀(b : Type)@@ -251,9 +324,14 @@     , isZero : Natural → Bool     , lessThan : ∀(x : Natural) → ∀(y : Natural) → Bool     , lessThanEqual : ∀(x : Natural) → ∀(y : Natural) → Bool+    , listMax : ∀(xs : List Natural) → Optional Natural+    , listMin : ∀(xs : List Natural) → Optional Natural+    , max : ∀(a : Natural) → ∀(b : Natural) → Natural+    , min : ∀(a : Natural) → ∀(b : Natural) → Natural     , odd : Natural → Bool     , product : ∀(xs : List Natural) → Natural     , show : Natural → Text+    , sort : ∀(xs : List Natural) → List Natural     , subtract : Natural → Natural → Natural     , sum : ∀(xs : List Natural) → Natural     , toDouble : ∀(n : Natural) → Double

+ dhall-lang/tests/type-inference/success/unit/IntegerClampA.dhall view

@@ -0,0 +1,1 @@+Integer/clamp

+ dhall-lang/tests/type-inference/success/unit/IntegerClampB.dhall view

@@ -0,0 +1,1 @@+Integer → Natural

+ dhall-lang/tests/type-inference/success/unit/IntegerNegateA.dhall view

@@ -0,0 +1,1 @@+Integer/negate

+ dhall-lang/tests/type-inference/success/unit/IntegerNegateB.dhall view

@@ -0,0 +1,1 @@+Integer → Integer

dhall.cabal view

@@ -1,5 +1,5 @@ Name: dhall-Version: 1.27.0+Version: 1.28.0 Cabal-Version: >=1.10 Build-Type: Simple Tested-With: GHC == 7.10.3, GHC == 8.4.3, GHC == 8.6.1@@ -40,28 +40,46 @@     dhall-lang/Prelude/Double/show     dhall-lang/Prelude/Function/compose     dhall-lang/Prelude/Function/package.dhall+    dhall-lang/Prelude/Integer/abs+    dhall-lang/Prelude/Integer/add+    dhall-lang/Prelude/Integer/clamp+    dhall-lang/Prelude/Integer/equal+    dhall-lang/Prelude/Integer/greaterThan+    dhall-lang/Prelude/Integer/greaterThanEqual+    dhall-lang/Prelude/Integer/lessThan+    dhall-lang/Prelude/Integer/lessThanEqual+    dhall-lang/Prelude/Integer/multiply+    dhall-lang/Prelude/Integer/negate     dhall-lang/Prelude/Integer/package.dhall     dhall-lang/Prelude/Integer/show+    dhall-lang/Prelude/Integer/subtract     dhall-lang/Prelude/Integer/toDouble+    dhall-lang/Prelude/Integer/toNatural+    dhall-lang/Prelude/JSON/Nesting+    dhall-lang/Prelude/JSON/Tagged+    dhall-lang/Prelude/JSON/Type     dhall-lang/Prelude/JSON/array     dhall-lang/Prelude/JSON/bool+    dhall-lang/Prelude/JSON/core.dhall     dhall-lang/Prelude/JSON/keyText     dhall-lang/Prelude/JSON/keyValue-    dhall-lang/Prelude/JSON/Nesting     dhall-lang/Prelude/JSON/null     dhall-lang/Prelude/JSON/number     dhall-lang/Prelude/JSON/object+    dhall-lang/Prelude/JSON/omitNullFields     dhall-lang/Prelude/JSON/package.dhall     dhall-lang/Prelude/JSON/render+    dhall-lang/Prelude/JSON/renderYAML     dhall-lang/Prelude/JSON/string-    dhall-lang/Prelude/JSON/Tagged-    dhall-lang/Prelude/JSON/Type+    dhall-lang/Prelude/JSON/tagInline+    dhall-lang/Prelude/JSON/tagNested     dhall-lang/Prelude/List/all     dhall-lang/Prelude/List/any     dhall-lang/Prelude/List/build     dhall-lang/Prelude/List/concat     dhall-lang/Prelude/List/concatMap     dhall-lang/Prelude/List/default+    dhall-lang/Prelude/List/drop     dhall-lang/Prelude/List/empty     dhall-lang/Prelude/List/filter     dhall-lang/Prelude/List/fold@@ -74,20 +92,22 @@     dhall-lang/Prelude/List/map     dhall-lang/Prelude/List/null     dhall-lang/Prelude/List/package.dhall+    dhall-lang/Prelude/List/partition     dhall-lang/Prelude/List/replicate     dhall-lang/Prelude/List/reverse     dhall-lang/Prelude/List/shifted+    dhall-lang/Prelude/List/take     dhall-lang/Prelude/List/unzip-    dhall-lang/Prelude/Location/package.dhall     dhall-lang/Prelude/Location/Type+    dhall-lang/Prelude/Location/package.dhall     dhall-lang/Prelude/Map/Entry+    dhall-lang/Prelude/Map/Type     dhall-lang/Prelude/Map/empty-    dhall-lang/Prelude/Map/keys     dhall-lang/Prelude/Map/keyText     dhall-lang/Prelude/Map/keyValue+    dhall-lang/Prelude/Map/keys     dhall-lang/Prelude/Map/map     dhall-lang/Prelude/Map/package.dhall-    dhall-lang/Prelude/Map/Type     dhall-lang/Prelude/Map/values     dhall-lang/Prelude/Monoid     dhall-lang/Prelude/Natural/build@@ -100,10 +120,15 @@     dhall-lang/Prelude/Natural/isZero     dhall-lang/Prelude/Natural/lessThan     dhall-lang/Prelude/Natural/lessThanEqual+    dhall-lang/Prelude/Natural/listMax+    dhall-lang/Prelude/Natural/listMin+    dhall-lang/Prelude/Natural/max+    dhall-lang/Prelude/Natural/min     dhall-lang/Prelude/Natural/odd     dhall-lang/Prelude/Natural/package.dhall     dhall-lang/Prelude/Natural/product     dhall-lang/Prelude/Natural/show+    dhall-lang/Prelude/Natural/sort     dhall-lang/Prelude/Natural/subtract     dhall-lang/Prelude/Natural/sum     dhall-lang/Prelude/Natural/toDouble@@ -123,7 +148,6 @@     dhall-lang/Prelude/Optional/package.dhall     dhall-lang/Prelude/Optional/toList     dhall-lang/Prelude/Optional/unzip-    dhall-lang/Prelude/package.dhall     dhall-lang/Prelude/Text/concat     dhall-lang/Prelude/Text/concatMap     dhall-lang/Prelude/Text/concatMapSep@@ -132,6 +156,7 @@     dhall-lang/Prelude/Text/defaultMap     dhall-lang/Prelude/Text/package.dhall     dhall-lang/Prelude/Text/show+    dhall-lang/Prelude/XML/Type     dhall-lang/Prelude/XML/attribute     dhall-lang/Prelude/XML/element     dhall-lang/Prelude/XML/emptyAttributes@@ -139,7 +164,7 @@     dhall-lang/Prelude/XML/package.dhall     dhall-lang/Prelude/XML/render     dhall-lang/Prelude/XML/text-    dhall-lang/Prelude/XML/Type+    dhall-lang/Prelude/package.dhall     dhall-lang/tests/binary-decode/failure/unit/*.dhallb     dhall-lang/tests/binary-decode/success/unit/*.dhall     dhall-lang/tests/binary-decode/success/unit/*.dhallb@@ -396,6 +421,7 @@         aeson                       >= 1.0.0.0  && < 1.5 ,         aeson-pretty                               < 0.9 ,         ansi-terminal               >= 0.6.3.1  && < 0.11,+        atomic-write                >= 0.2.0.7  && < 0.3 ,         bytestring                                 < 0.11,         case-insensitive                           < 1.3 ,         cborg                       >= 0.2.0.0  && < 0.3 ,@@ -411,16 +437,17 @@         exceptions                  >= 0.8.3    && < 0.11,         filepath                    >= 1.4      && < 1.5 ,         haskeline                   >= 0.7.2.1  && < 0.8 ,-        hashable                    >= 1.2      && < 1.3 ,+        hashable                    >= 1.2      && < 1.4 ,         lens-family-core            >= 1.0.0    && < 2.1 ,-        megaparsec                  >= 6.5.0    && < 7.1 ,+        megaparsec                  >= 7        && < 8.1 ,         memory                      >= 0.14     && < 0.16,         mtl                         >= 2.2.1    && < 2.3 ,         network-uri                 >= 2.6      && < 2.7 ,         optparse-applicative        >= 0.14.0.0 && < 0.16,         parsers                     >= 0.12.4   && < 0.13,-        prettyprinter               >= 1.2.0.1  && < 1.4 ,+        prettyprinter               >= 1.5.1    && < 1.6 ,         prettyprinter-ansi-terminal >= 1.1.1    && < 1.2 ,+        pretty-simple                              < 4   ,         profunctors                 >= 3.1.2    && < 5.6 ,         repline                     >= 0.2.1.0  && < 0.3 ,         serialise                   >= 0.2.0.0  && < 0.3 ,@@ -484,47 +511,49 @@             TemplateHaskell      Exposed-Modules:-        Dhall,-        Dhall.Binary,-        Dhall.Context,-        Dhall.Core,-        Dhall.Crypto,-        Dhall.Diff,-        Dhall.Tags,-        Dhall.Format,-        Dhall.Freeze,-        Dhall.Import,-        Dhall.Lint,-        Dhall.Main,-        Dhall.Map,-        Dhall.Optics,-        Dhall.Set,-        Dhall.Src,-        Dhall.Parser,-        Dhall.Parser.Expression,-        Dhall.Parser.Token,-        Dhall.Pretty,-        Dhall.Repl,-        Dhall.Tutorial,-        Dhall.TypeCheck,+        Dhall+        Dhall.Binary+        Dhall.Context+        Dhall.Core+        Dhall.Crypto+        Dhall.Diff+        Dhall.Format+        Dhall.Freeze+        Dhall.Import+        Dhall.Lint+        Dhall.Main+        Dhall.Map+        Dhall.Optics+        Dhall.Parser+        Dhall.Parser.Expression+        Dhall.Parser.Token+        Dhall.Pretty+        Dhall.Repl+        Dhall.Set+        Dhall.Src+        Dhall.Tags+        Dhall.Tutorial+        Dhall.TypeCheck         Dhall.Util         Dhall.Version     if !flag(cross)         Exposed-Modules:             Dhall.TH     Other-Modules:-        Dhall.Pretty.Internal,-        Dhall.Parser.Combinators,-        Dhall.URL,-        Dhall.Import.Types,-        Dhall.Syntax,-        Dhall.Eval,+        Dhall.Eval+        Dhall.Import.Types+        Dhall.Normalize+        Dhall.Parser.Combinators+        Dhall.Pretty.Internal+        Dhall.Syntax+        Dhall.URL         Paths_dhall     Autogen-Modules:         Paths_dhall     if flag(with-http)       Other-Modules:         Dhall.Import.HTTP+        Dhall.Import.Manager      GHC-Options: -Wall -fwarn-incomplete-uni-patterns     Default-Language: Haskell2010

doctest/Main.hs view

@@ -27,10 +27,17 @@         Test.DocTest.doctest             [ "-DWITH_HTTP"             , "--fast"+            , prefix </> "ghc-src"++            -- Unfortunately we cannot target the entire @src@ directory.+            -- The reason is that src/Dhall/Version.hs depends on+            -- the generated Paths_dhall module which is "out-of-scope"+            -- when running the testsuite with cabal v1-test.+            -- Instead, we target a selection of modules whose combined module+            -- dependency tree covers all modules that contain doctests.++            -- , prefix </> "src"             , "-i" <> (prefix </> "src")-            , "-i" <> (prefix </> "ghc-src")-            , prefix </> "src/Dhall.hs"-            , prefix </> "src/Dhall/Import.hs"-            , prefix </> "src/Dhall/Tutorial.hs"             , prefix </> "src/Dhall/Tags.hs"+            , prefix </> "src/Dhall/Tutorial.hs"             ]

ghc-src/Dhall/Import/HTTP.hs view

@@ -2,7 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} -module Dhall.Import.HTTP where+module Dhall.Import.HTTP+    ( fetchFromHttpUrl+    ) where  import Control.Exception (Exception) import Control.Monad.IO.Class (MonadIO(..))@@ -169,18 +171,28 @@         <>  show e' <> "\n" #endif -newManager :: IO Manager+newManager :: StateT Status IO Manager newManager = do     let settings = HTTP.tlsManagerSettings-#ifdef MIN_VERSION_http_client #if MIN_VERSION_http_client(0,5,0)           { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (30 * 1000 * 1000) }  -- 30 seconds #else           { HTTP.managerResponseTimeout = Just (30 * 1000 * 1000) }  -- 30 seconds #endif-#endif-    HTTP.newManager settings +    Status { _manager = oldManager, ..} <- State.get++    case oldManager of+        Nothing -> do+            manager <- liftIO (HTTP.newManager settings)++            State.put (Status { _manager = Just manager , ..})++            return manager++        Just manager -> do+            return manager+ data NotCORSCompliant = NotCORSCompliant     { expectedOrigins :: [ByteString]     , actualOrigin    :: ByteString@@ -260,7 +272,7 @@  fetchFromHttpUrl :: URL -> Maybe [HTTPHeader] -> StateT Status IO Text.Text fetchFromHttpUrl childURL mheaders = do-    manager <- liftIO $ newManager+    manager <- newManager      let childURLString = Text.unpack (renderURL childURL)

+ ghc-src/Dhall/Import/Manager.hs view

@@ -0,0 +1,14 @@+{-| Both the GHC and GHCJS implementations of "Dhall.Import.Manager" export a+    `Manager` type suitable for use within the "Dhall.Import" module++    For the GHC implementation the `Manager` type is a real `Manager` from the+    @http-client@ package.  For the GHCJS implementation the `Manager` type is+    a synonym for @`Data.Void.Void`@ since GHCJS does not use a `Manager` for+    HTTP requests.+-}+module Dhall.Import.Manager+    ( -- * Manager+      Manager+    ) where++import Network.HTTP.Client (Manager)

ghcjs-src/Dhall/Import/HTTP.hs view

@@ -1,7 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} -module Dhall.Import.HTTP where+module Dhall.Import.HTTP+    ( fetchFromHttpUrl+    , Manager+    ) where  import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.State.Strict (StateT)@@ -12,9 +15,18 @@ import qualified Data.Text as Text import qualified JavaScript.XHR +import Data.Void (Void) import Dhall.Core (URL(..)) import Dhall.URL (renderURL) import Dhall.Import.Types++{-| The GHCJS implementation does not require a `Manager`++    The purpose of this synonym is so that "Dhall.Import.Types" can import a+    `Manager` type from "Dhall.Import.HTTP" that does the correct thing for+    both the GHC and GHCJS implementations+-}+type Manager = Void  fetchFromHttpUrl     :: URL

+ ghcjs-src/Dhall/Import/Manager.hs view

@@ -0,0 +1,17 @@+{-| Both the GHC and GHCJS implementations of "Dhall.Import.Manager" export a+    `Manager` type suitable for use within the "Dhall.Import" module++    For the GHC implementation the `Manager` type is a real `Manager` from the+    @http-client@ package.  For the GHCJS implementation the `Manager` type is+    a synonym for @`Data.Void.Void`@ since GHCJS does not use a `Manager` for+    HTTP requests.+-}+module Dhall.Import.Manager+    ( -- * Manager+      Manager+    ) where++import Data.Void (Void)++-- | GHCJS does not use a `Manager`+type Manager = Void

src/Dhall.hs view

@@ -41,14 +41,14 @@     , HasEvaluateSettings     , detailed -    -- * Types-    , Type (..)-    , RecordType(..)-    , UnionType(..)-    , InputType(..)+    -- * Decoders+    , Decoder (..)+    , RecordDecoder(..)+    , UnionDecoder(..)+    , Encoder(..)     , FromDhall(..)     , Interpret-    , InvalidType(..)+    , InvalidDecoder(..)     , ExtractErrors(..)     , Extractor     , MonadicExtractor@@ -72,6 +72,7 @@     , sequence     , list     , vector+    , function     , setFromDistinctList     , setIgnoringDuplicates     , hashSetFromDistinctList@@ -94,14 +95,14 @@     , Inject     , inject     , genericToDhall-    , RecordInputType(..)-    , inputFieldWith-    , inputField-    , inputRecord-    , UnionInputType(..)-    , inputConstructorWith-    , inputConstructor-    , inputUnion+    , RecordEncoder(..)+    , encodeFieldWith+    , encodeField+    , recordEncoder+    , UnionEncoder(..)+    , encodeConstructorWith+    , encodeConstructor+    , unionEncoder     , (>|<)      -- * Miscellaneous@@ -140,7 +141,7 @@ import Data.Vector (Vector) import Data.Void (Void) import Data.Word (Word8, Word16, Word32, Word64)-import Dhall.Core (Expr(..), Chunks(..), DhallDouble(..))+import Dhall.Syntax (Expr(..), Chunks(..), DhallDouble(..)) import Dhall.Import (Imported(..)) import Dhall.Parser (Src(..)) import Dhall.TypeCheck (DetailedTypeError(..), TypeError)@@ -202,7 +203,7 @@ -} typeError :: Expr s a -> Expr s a -> Extractor s a b typeError expected actual =-    Failure . ExtractErrors . pure . TypeMismatch $ InvalidType expected actual+    Failure . ExtractErrors . pure . TypeMismatch $ InvalidDecoder expected actual  -- | Turn a `Text` message into an extraction failure extractError :: Text -> Extractor s a b@@ -240,7 +241,7 @@     a term-level error, described with a freeform text value. -} data ExtractError s a =-    TypeMismatch (InvalidType s a)+    TypeMismatch (InvalidDecoder s a)   | ExtractError Text  instance (Pretty s, Pretty a, Typeable s, Typeable a) => Show (ExtractError s a) where@@ -256,32 +257,32 @@  instance (Pretty s, Pretty a, Typeable s, Typeable a) => Exception (ExtractError s a) -{-| Every `Type` must obey the contract that if an expression's type matches the+{-| Every `Decoder` must obey the contract that if an expression's type matches the     the `expected` type then the `extract` function must not fail with a type error.     If not, then this value is returned. -    This value indicates that an invalid `Type` was provided to the `input`+    This value indicates that an invalid `Decoder` was provided to the `input`     function -}-data InvalidType s a = InvalidType-  { invalidTypeExpected   :: Expr s a-  , invalidTypeExpression :: Expr s a+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 (InvalidType s a)+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 (InvalidType s a) where-    show InvalidType { .. } =-        _ERROR <> ": Invalid Dhall.Type                                                  \n\+instance (Pretty s, Pretty a, Typeable s, Typeable a) => Show (InvalidDecoder s a) where+    show InvalidDecoder { .. } =+        _ERROR <> ": Invalid Dhall.Decoder                                               \n\         \                                                                                \n\-        \Every Type must provide an extract function that succeeds if an expression      \n\-        \matches the expected type.  You provided a Type that disobeys this contract     \n\+        \Every Decoder must provide an extract function that succeeds if an expression   \n\+        \matches the expected type.  You provided a Decoder that disobeys this contract  \n\         \                                                                                \n\-        \The Type provided has the expected dhall type:                                  \n\+        \The Decoder provided has the expected dhall type:                               \n\         \                                                                                \n\         \" <> show txt0 <> "\n\         \                                                                                \n\@@ -290,8 +291,8 @@         \" <> show txt1 <> "\n\         \                                                                                \n"         where-          txt0 = Dhall.Util.insert invalidTypeExpected-          txt1 = Dhall.Util.insert invalidTypeExpression+          txt0 = Dhall.Util.insert invalidDecoderExpected+          txt1 = Dhall.Util.insert invalidDecoderExpression  -- | @since 1.16 data InputSettings = InputSettings@@ -403,8 +404,8 @@     This uses the settings from 'defaultInputSettings'. -} input-    :: Type a-    -- ^ The type of value to decode from Dhall to Haskell+    :: Decoder a+    -- ^ The decoder for the Dhall value     -> Text     -- ^ The Dhall program     -> IO a@@ -420,13 +421,13 @@ -} inputWithSettings     :: InputSettings-    -> Type a-    -- ^ The type of value to decode from Dhall to Haskell+    -> Decoder a+    -- ^ The decoder for the Dhall value     -> Text     -- ^ The Dhall program     -> IO a     -- ^ The decoded value in Haskell-inputWithSettings settings (Type {..}) txt = do+inputWithSettings settings (Decoder {..}) txt = do     expr  <- Dhall.Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt)      let InputSettings {..} = settings@@ -464,8 +465,8 @@     @since 1.16 -} inputFile-  :: Type a-  -- ^ The type of value to decode from Dhall to Haskell+  :: Decoder a+  -- ^ The decoder for the Dhall value   -> FilePath   -- ^ The path to the Dhall program.   -> IO a@@ -480,8 +481,8 @@ -} inputFileWithSettings   :: EvaluateSettings-  -> Type a-  -- ^ The type of value to decode from Dhall to Haskell+  -> Decoder a+  -- ^ The decoder for the Dhall value   -> FilePath   -- ^ The path to the Dhall program.   -> IO a@@ -546,13 +547,13 @@ --   a much better user experience. rawInput     :: Alternative f-    => Type a-    -- ^ The type of value to decode from Dhall to Haskell+    => 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 (Type {..}) expr = do+rawInput (Decoder {..}) expr = do     case extract (Dhall.Core.normalize expr) of         Success x  -> pure x         Failure _e -> empty@@ -672,24 +673,24 @@     handler1 :: TypeError Src Void -> IO a     handler1 e = Control.Exception.throwIO (DetailedTypeError e) -{-| A @(Type a)@ represents a way to marshal a value of type @\'a\'@ from Dhall+{-| A @(Decoder a)@ represents a way to marshal a value of type @\'a\'@ from Dhall     into Haskell -    You can produce `Type`s either explicitly:+    You can produce `Decoder`s either explicitly: -> example :: Type (Vector Text)+> example :: Decoder (Vector Text) > example = vector text      ... or implicitly using `auto`: -> example :: Type (Vector Text)+> example :: Decoder (Vector Text) > example = auto -    You can consume `Type`s using the `input` function:+    You can consume `Decoder`s using the `input` function: -> input :: Type a -> Text -> IO a+> input :: Decoder a -> Text -> IO a -}-data Type a = Type+data Decoder a = Decoder     { extract  :: Expr Src Void -> Extractor Src Void a     -- ^ Extracts Haskell value from the Dhall expression     , expected :: Expr Src Void@@ -702,8 +703,8 @@ >>> input bool "True" True -}-bool :: Type Bool-bool = Type {..}+bool :: Decoder Bool+bool = Decoder {..}   where     extract (BoolLit b) = pure b     extract expr        = typeError expected expr@@ -715,8 +716,8 @@ >>> input natural "42" 42 -}-natural :: Type Natural-natural = Type {..}+natural :: Decoder Natural+natural = Decoder {..}   where     extract (NaturalLit n) = pure n     extract  expr             = typeError Natural expr@@ -728,8 +729,8 @@ >>> input integer "+42" 42 -}-integer :: Type Integer-integer = Type {..}+integer :: Decoder Integer+integer = Decoder {..}   where     extract (IntegerLit n) = pure n     extract  expr          = typeError Integer expr@@ -741,7 +742,7 @@ >>> input scientific "1e100" 1.0e100 -}-scientific :: Type Scientific+scientific :: Decoder Scientific scientific = fmap Data.Scientific.fromFloatDigits double  {-| Decode a `Double`@@ -749,8 +750,8 @@ >>> input double "42.0" 42.0 -}-double :: Type Double-double = Type {..}+double :: Decoder Double+double = Decoder {..}   where     extract (DoubleLit (DhallDouble n)) = pure n     extract  expr                       = typeError Double expr@@ -762,7 +763,7 @@ >>> input lazyText "\"Test\"" "Test" -}-lazyText :: Type Data.Text.Lazy.Text+lazyText :: Decoder Data.Text.Lazy.Text lazyText = fmap Data.Text.Lazy.fromStrict strictText  {-| Decode strict `Text`@@ -770,8 +771,8 @@ >>> input strictText "\"Test\"" "Test" -}-strictText :: Type Text-strictText = Type {..}+strictText :: Decoder Text+strictText = Decoder {..}   where     extract (TextLit (Chunks [] t)) = pure t     extract  expr = typeError Text expr@@ -782,8 +783,8 @@ >>> input (maybe natural) "Some 1" Just 1 -}-maybe :: Type a -> Type (Maybe a)-maybe (Type extractIn expectedIn) = Type extractOut expectedOut+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@@ -796,8 +797,8 @@ >>> input (sequence natural) "[1, 2, 3]" fromList [1,2,3] -}-sequence :: Type a -> Type (Seq a)-sequence (Type extractIn expectedIn) = Type extractOut expectedOut+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@@ -809,7 +810,7 @@ >>> input (list natural) "[1, 2, 3]" [1,2,3] -}-list :: Type a -> Type [a]+list :: Decoder a -> Decoder [a] list = fmap Data.Foldable.toList . sequence  {-| Decode a `Vector`@@ -817,9 +818,33 @@ >>> input (vector natural) "[1, 2, 3]" [1,2,3] -}-vector :: Type a -> Type (Vector a)+vector :: Decoder a -> Decoder (Vector a) vector = fmap Data.Vector.fromList . list +{-| Decode a Dhall function into a Haskell function++>>> f <- input (function defaultInterpretOptions inject bool) "Natural/even" :: IO (Natural -> Bool)+>>> f 0+True+>>> f 1+False+-}+function+    :: InterpretOptions+    -> Encoder a+    -> Decoder b+    -> Decoder (a -> b)+function options (Encoder {..}) (Decoder extractIn expectedIn) =+    Decoder extractOut expectedOut+  where+    normalizer_ = Just (inputNormalizer options)++    extractOut e = pure (\i -> case extractIn (Dhall.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 "_" declared expectedIn+ {-| Decode a `Set` from a `List`  >>> input (setIgnoringDuplicates natural) "[1, 2, 3]"@@ -831,7 +856,7 @@ fromList [1,3]  -}-setIgnoringDuplicates :: (Ord a) => Type a -> Type (Data.Set.Set a)+setIgnoringDuplicates :: (Ord a) => Decoder a -> Decoder (Data.Set.Set a) setIgnoringDuplicates = fmap Data.Set.fromList . list  {-| Decode a `HashSet` from a `List`@@ -846,8 +871,8 @@  -} hashSetIgnoringDuplicates :: (Hashable a, Ord a)-                          => Type a-                          -> Type (Data.HashSet.HashSet a)+                          => Decoder a+                          -> Decoder (Data.HashSet.HashSet a) hashSetIgnoringDuplicates = fmap Data.HashSet.fromList . list  {-| Decode a `Set` from a `List` with distinct elements@@ -876,7 +901,7 @@ >  -}-setFromDistinctList :: (Ord a, Show a) => Type a -> Type (Data.Set.Set a)+setFromDistinctList :: (Ord a, Show a) => Decoder a -> Decoder (Data.Set.Set a) setFromDistinctList = setHelper Data.Set.size Data.Set.fromList  {-| Decode a `HashSet` from a `List` with distinct elements@@ -906,17 +931,17 @@  -} hashSetFromDistinctList :: (Hashable a, Ord a, Show a)-                        => Type a-                        -> Type (Data.HashSet.HashSet 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)-          -> Type a-          -> Type (t a)-setHelper size toSet (Type extractIn expectedIn) = Type extractOut expectedOut+          -> 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@@ -954,7 +979,7 @@ fromList [(1,False)]  -}-map :: Ord k => Type k -> Type v -> Type (Map k v)+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@@@ -971,7 +996,7 @@ fromList [(1,False)]  -}-hashMap :: (Eq k, Hashable k) => Type k -> Type v -> Type (HashMap k v)+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@@ -979,8 +1004,8 @@ >>> input (pairFromMapEntry strictText natural) "{ mapKey = \"foo\", mapValue = 3 }" ("foo",3) -}-pairFromMapEntry :: Type k -> Type v -> Type (k, v)-pairFromMapEntry k v = Type extractOut expectedOut+pairFromMapEntry :: Decoder k -> Decoder v -> Decoder (k, v)+pairFromMapEntry k v = Decoder extractOut expectedOut   where     extractOut (RecordLit kvs)         | Just key <- Dhall.Map.lookup "mapKey" kvs@@ -995,8 +1020,8 @@ >>> input unit "{=}"  -- GHC doesn't print the result if it is ()  -}-unit :: Type ()-unit = Type extractOut expectedOut+unit :: Decoder ()+unit = Decoder extractOut expectedOut   where     extractOut (RecordLit fields)         | Data.Foldable.null fields = pure ()@@ -1008,7 +1033,7 @@  Since @<>@ is uninhabited, @'input' 'void'@ will always fail. -}-void :: Type Void+void :: Decoder Void void = union mempty  {-| Decode a `String`@@ -1017,16 +1042,16 @@ "ABC"  -}-string :: Type String+string :: Decoder String string = Data.Text.Lazy.unpack <$> lazyText -{-| Given a pair of `Type`s, decode a tuple-record into their pairing.+{-| Given a pair of `Decoder`s, decode a tuple-record into their pairing.  >>> input (pair natural bool) "{ _1 = 42, _2 = False }" (42,False) -}-pair :: Type a -> Type b -> Type (a, b)-pair l r = Type extractOut expectedOut+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) $ Dhall.Map.lookup "_1" fields)@@ -1054,9 +1079,9 @@     types. -} class FromDhall a where-    autoWith:: InterpretOptions -> Type a+    autoWith:: InterpretOptions -> Decoder a     default autoWith-        :: (Generic a, GenericFromDhall (Rep a)) => InterpretOptions -> Type a+        :: (Generic a, GenericFromDhall (Rep a)) => InterpretOptions -> Decoder a     autoWith options = fmap GHC.Generics.to (evalState (genericAutoWith options) 1)  {-| A compatibility alias for `FromDhall`@@ -1126,20 +1151,8 @@     autoWith opts = Dhall.hashMap (autoWith opts) (autoWith opts)  instance (ToDhall a, FromDhall b) => FromDhall (a -> b) where-    autoWith opts = Type extractOut expectedOut-      where-        normalizer_ = Just (inputNormalizer opts)--        -- ToDo-        extractOut e = pure (\i -> case extractIn (Dhall.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 "_" declared expectedIn--        InputType {..} = injectWith opts--        Type extractIn expectedIn = autoWith opts+    autoWith opts =+        function opts (injectWith opts) (autoWith opts)  instance (FromDhall a, FromDhall b) => FromDhall (a, b) @@ -1147,7 +1160,7 @@  > auto = autoWith defaultInterpretOptions -}-auto :: FromDhall a => Type a+auto :: FromDhall a => Decoder a auto = autoWith defaultInterpretOptions  {-| This type is exactly the same as `Data.Fix.Fix` except with a different@@ -1160,7 +1173,7 @@ resultToFix (Result x) = Fix (fmap resultToFix x)  instance FromDhall (f (Result f)) => FromDhall (Result f) where-    autoWith options = Type { expected = expected_, extract = extract_ }+    autoWith options = Decoder { expected = expected_, extract = extract_ }       where         expected_ = "result" @@ -1244,11 +1257,11 @@ -- > -- >     print (convert x :: Expr) instance (Functor f, FromDhall (f (Result f))) => FromDhall (Fix f) where-    autoWith options = Type { expected = expected_, extract = extract_ }+    autoWith options = Decoder { expected = expected_, extract = extract_ }       where         expected_ =             Pi "result" (Const Dhall.Core.Type)-                (Pi "Make" (Pi "_" (expected (autoWith options :: Type (f (Result f)))) "result")+                (Pi "Make" (Pi "_" (expected (autoWith options :: Decoder (f (Result f)))) "result")                     "result"                 ) @@ -1263,7 +1276,7 @@     having to explicitly provide a `FromDhall` instance for a type as long as     the type derives `Generic` -}-genericAuto :: (Generic a, GenericFromDhall (Rep a)) => Type a+genericAuto :: (Generic a, GenericFromDhall (Rep a)) => Decoder a genericAuto = fmap to (evalState (genericAutoWith defaultInterpretOptions) 1)  {-| Use these options to tweak how Dhall derives a generic implementation of@@ -1330,7 +1343,7 @@     for automatically deriving a generic implementation -} class GenericFromDhall f where-    genericAutoWith :: InterpretOptions -> State Int (Type (f a))+    genericAutoWith :: InterpretOptions -> State Int (Decoder (f a))  instance GenericFromDhall f => GenericFromDhall (M1 D d f) where     genericAutoWith options = do@@ -1338,7 +1351,7 @@         pure (fmap M1 res)  instance GenericFromDhall V1 where-    genericAutoWith _ = pure Type {..}+    genericAutoWith _ = pure Decoder {..}       where         extract expr = typeError expected expr @@ -1399,7 +1412,7 @@   empty  instance (Constructor c1, Constructor c2, GenericFromDhall f1, GenericFromDhall f2) => GenericFromDhall (M1 C c1 f1 :+: M1 C c2 f2) where-    genericAutoWith options@(InterpretOptions {..}) = pure (Type {..})+    genericAutoWith options@(InterpretOptions {..}) = pure (Decoder {..})       where         nL :: M1 i c1 f1 a         nL = undefined@@ -1427,11 +1440,11 @@                     ]                 ) -        Type extractL expectedL = evalState (genericAutoWith options) 1-        Type extractR expectedR = evalState (genericAutoWith options) 1+        Decoder extractL expectedL = evalState (genericAutoWith options) 1+        Decoder extractR expectedR = evalState (genericAutoWith options) 1  instance (Constructor c, GenericFromDhall (f :+: g), GenericFromDhall h) => GenericFromDhall ((f :+: g) :+: M1 C c h) where-    genericAutoWith options@(InterpretOptions {..}) = pure (Type {..})+    genericAutoWith options@(InterpretOptions {..}) = pure (Decoder {..})       where         n :: M1 i c h a         n = undefined@@ -1448,13 +1461,13 @@         expected =             Union (Dhall.Map.insert name (notEmptyRecord expectedR) ktsL) -        Type extractL expectedL = evalState (genericAutoWith options) 1-        Type extractR expectedR = evalState (genericAutoWith options) 1+        Decoder extractL expectedL = evalState (genericAutoWith options) 1+        Decoder extractR expectedR = evalState (genericAutoWith options) 1          ktsL = unsafeExpectUnion "genericAutoWith (:+:)" expectedL  instance (Constructor c, GenericFromDhall f, GenericFromDhall (g :+: h)) => GenericFromDhall (M1 C c f :+: (g :+: h)) where-    genericAutoWith options@(InterpretOptions {..}) = pure (Type {..})+    genericAutoWith options@(InterpretOptions {..}) = pure (Decoder {..})       where         n :: M1 i c f a         n = undefined@@ -1471,20 +1484,20 @@         expected =             Union (Dhall.Map.insert name (notEmptyRecord expectedL) ktsR) -        Type extractL expectedL = evalState (genericAutoWith options) 1-        Type extractR expectedR = evalState (genericAutoWith options) 1+        Decoder extractL expectedL = evalState (genericAutoWith options) 1+        Decoder extractR expectedR = evalState (genericAutoWith options) 1          ktsR = unsafeExpectUnion "genericAutoWith (:+:)" expectedR  instance (GenericFromDhall (f :+: g), GenericFromDhall (h :+: i)) => GenericFromDhall ((f :+: g) :+: (h :+: i)) where-    genericAutoWith options = pure (Type {..})+    genericAutoWith options = pure (Decoder {..})       where         extract e = fmap L1 (extractL e) `ealt` fmap R1 (extractR e)          expected = Union (Dhall.Map.union ktsL ktsR) -        Type extractL expectedL = evalState (genericAutoWith options) 1-        Type extractR expectedR = evalState (genericAutoWith options) 1+        Decoder extractL expectedL = evalState (genericAutoWith options) 1+        Decoder extractR expectedR = evalState (genericAutoWith options) 1          ktsL = unsafeExpectUnion "genericAutoWith (:+:)" expectedL         ktsR = unsafeExpectUnion "genericAutoWith (:+:)" expectedR@@ -1495,7 +1508,7 @@         pure (fmap M1 res)  instance GenericFromDhall U1 where-    genericAutoWith _ = pure (Type {..})+    genericAutoWith _ = pure (Decoder {..})       where         extract _ = pure U1 @@ -1510,8 +1523,8 @@  instance (GenericFromDhall (f :*: g), GenericFromDhall (h :*: i)) => GenericFromDhall ((f :*: g) :*: (h :*: i)) where     genericAutoWith options = do-        Type extractL expectedL <- genericAutoWith options-        Type extractR expectedR <- genericAutoWith options+        Decoder extractL expectedL <- genericAutoWith options+        Decoder extractR expectedR <- genericAutoWith options          let ktsL = unsafeExpectRecord "genericAutoWith (:*:)" expectedL         let ktsR = unsafeExpectRecord "genericAutoWith (:*:)" expectedR@@ -1521,7 +1534,7 @@         let extract expression =                 liftA2 (:*:) (extractL expression) (extractR expression) -        return (Type {..})+        return (Decoder {..})  instance (GenericFromDhall (f :*: g), Selector s, FromDhall a) => GenericFromDhall ((f :*: g) :*: M1 S s (K1 i a)) where     genericAutoWith options@InterpretOptions{..} = do@@ -1530,9 +1543,9 @@          nameR <- fmap fieldModifier (getSelName nR) -        Type extractL expectedL <- genericAutoWith options+        Decoder extractL expectedL <- genericAutoWith options -        let Type extractR expectedR = autoWith options+        let Decoder extractR expectedR = autoWith options          let ktsL = unsafeExpectRecord "genericAutoWith (:*:)" expectedL @@ -1551,7 +1564,7 @@                             _ -> die                     _ -> die -        return (Type {..})+        return (Decoder {..})  instance (Selector s, FromDhall a, GenericFromDhall (f :*: g)) => GenericFromDhall (M1 S s (K1 i a) :*: (f :*: g)) where     genericAutoWith options@InterpretOptions{..} = do@@ -1560,9 +1573,9 @@          nameL <- fmap fieldModifier (getSelName nL) -        let Type extractL expectedL = autoWith options+        let Decoder extractL expectedL = autoWith options -        Type extractR expectedR <- genericAutoWith options+        Decoder extractR expectedR <- genericAutoWith options          let ktsR = unsafeExpectRecord "genericAutoWith (:*:)" expectedR @@ -1581,7 +1594,7 @@                             _ -> die                     _ -> die -        return (Type {..})+        return (Decoder {..})  instance (Selector s1, Selector s2, FromDhall a1, FromDhall a2) => GenericFromDhall (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where     genericAutoWith options@InterpretOptions{..} = do@@ -1594,8 +1607,8 @@         nameL <- fmap fieldModifier (getSelName nL)         nameR <- fmap fieldModifier (getSelName nR) -        let Type extractL expectedL = autoWith options-        let Type extractR expectedR = autoWith options+        let Decoder extractL expectedL = autoWith options+        let Decoder extractR expectedR = autoWith options          let expected =                 Record@@ -1618,7 +1631,7 @@                             Nothing -> die                     _ -> die -        return (Type {..})+        return (Decoder {..})  instance (Selector s, FromDhall a) => GenericFromDhall (M1 S s (K1 i a)) where     genericAutoWith options@InterpretOptions{..} = do@@ -1627,7 +1640,7 @@          name <- fmap fieldModifier (getSelName n) -        let Type { extract = extract', expected = expected'} = autoWith options+        let Decoder { extract = extract', expected = expected'} = autoWith options          let expected =                 case singletonConstructors of@@ -1660,20 +1673,20 @@                     Smart | selName n == "" -> extract0                     _                       -> extract1 -        return (Type {..})+        return (Decoder {..}) -{-| An @(InputType a)@ represents a way to marshal a value of type @\'a\'@ from+{-| An @(Encoder a)@ represents a way to marshal a value of type @\'a\'@ from     Haskell into Dhall -}-data InputType a = InputType+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 InputType where-    contramap f (InputType embed declared) = InputType embed' declared+instance Contravariant Encoder where+    contramap f (Encoder embed declared) = Encoder embed' declared       where         embed' x = embed (f x) @@ -1692,9 +1705,9 @@     * Marshaling the resulting Dhall expression back into a Haskell value -} class ToDhall a where-    injectWith :: InterpretOptions -> InputType a+    injectWith :: InterpretOptions -> Encoder a     default injectWith-        :: (Generic a, GenericToDhall (Rep a)) => InterpretOptions -> InputType a+        :: (Generic a, GenericToDhall (Rep a)) => InterpretOptions -> Encoder a     injectWith options         = contramap GHC.Generics.from (evalState (genericToDhallWith options) 1) @@ -1708,7 +1721,7 @@  > inject = injectWith defaultInterpretOptions -}-inject :: ToDhall a => InputType a+inject :: ToDhall a => Encoder a inject = injectWith defaultInterpretOptions  {-| Use the default options for injecting a value, whose structure is@@ -1718,26 +1731,26 @@ want to define orphan instances for. -} genericToDhall-  :: (Generic a, GenericToDhall (Rep a)) => InputType a+  :: (Generic a, GenericToDhall (Rep a)) => Encoder a genericToDhall     = contramap GHC.Generics.from (evalState (genericToDhallWith defaultInterpretOptions) 1)  instance ToDhall Void where-    injectWith _ = InputType {..}+    injectWith _ = Encoder {..}       where         embed = Data.Void.absurd          declared = Union mempty  instance ToDhall Bool where-    injectWith _ = InputType {..}+    injectWith _ = Encoder {..}       where         embed = BoolLit          declared = Bool  instance ToDhall Data.Text.Lazy.Text where-    injectWith _ = InputType {..}+    injectWith _ = Encoder {..}       where         embed text =             TextLit (Chunks [] (Data.Text.Lazy.toStrict text))@@ -1745,7 +1758,7 @@         declared = Text  instance ToDhall Text where-    injectWith _ = InputType {..}+    injectWith _ = Encoder {..}       where         embed text = TextLit (Chunks [] text) @@ -1753,24 +1766,24 @@  instance {-# OVERLAPS #-} ToDhall String where     injectWith options =-        contramap Data.Text.pack (injectWith options :: InputType Text)+        contramap Data.Text.pack (injectWith options :: Encoder Text)  instance ToDhall Natural where-    injectWith _ = InputType {..}+    injectWith _ = Encoder {..}       where         embed = NaturalLit          declared = Natural  instance ToDhall Integer where-    injectWith _ = InputType {..}+    injectWith _ = Encoder {..}       where         embed = IntegerLit          declared = Integer  instance ToDhall Int where-    injectWith _ = InputType {..}+    injectWith _ = Encoder {..}       where         embed = IntegerLit . toInteger @@ -1783,7 +1796,7 @@ -}  instance ToDhall Word where-    injectWith _ = InputType {..}+    injectWith _ = Encoder {..}       where         embed = NaturalLit . fromIntegral @@ -1796,7 +1809,7 @@ -}  instance ToDhall Word8 where-    injectWith _ = InputType {..}+    injectWith _ = Encoder {..}       where         embed = NaturalLit . fromIntegral @@ -1809,7 +1822,7 @@ -}  instance ToDhall Word16 where-    injectWith _ = InputType {..}+    injectWith _ = Encoder {..}       where         embed = NaturalLit . fromIntegral @@ -1822,7 +1835,7 @@ -}  instance ToDhall Word32 where-    injectWith _ = InputType {..}+    injectWith _ = Encoder {..}       where         embed = NaturalLit . fromIntegral @@ -1835,14 +1848,14 @@ -}  instance ToDhall Word64 where-    injectWith _ = InputType {..}+    injectWith _ = Encoder {..}       where         embed = NaturalLit . fromIntegral          declared = Natural  instance ToDhall Double where-    injectWith _ = InputType {..}+    injectWith _ = Encoder {..}       where         embed = DoubleLit . DhallDouble @@ -1850,27 +1863,27 @@  instance ToDhall Scientific where     injectWith options =-        contramap Data.Scientific.toRealFloat (injectWith options :: InputType Double)+        contramap Data.Scientific.toRealFloat (injectWith options :: Encoder Double)  instance ToDhall () where-    injectWith _ = InputType {..}+    injectWith _ = Encoder {..}       where         embed = const (RecordLit mempty)          declared = Record mempty  instance ToDhall a => ToDhall (Maybe a) where-    injectWith options = InputType embedOut declaredOut+    injectWith options = Encoder embedOut declaredOut       where         embedOut (Just x ) = Some (embedIn x)         embedOut  Nothing  = App None declaredIn -        InputType embedIn declaredIn = injectWith options+        Encoder embedIn declaredIn = injectWith options          declaredOut = App Optional declaredIn  instance ToDhall a => ToDhall (Seq a) where-    injectWith options = InputType embedOut declaredOut+    injectWith options = Encoder embedOut declaredOut       where         embedOut xs = ListLit listType (fmap embedIn xs)           where@@ -1880,7 +1893,7 @@          declaredOut = App List declaredIn -        InputType embedIn declaredIn = injectWith options+        Encoder embedIn declaredIn = injectWith options  instance ToDhall a => ToDhall [a] where     injectWith = fmap (contramap Data.Sequence.fromList) injectWith@@ -1920,7 +1933,7 @@  -} instance (ToDhall k, ToDhall v) => ToDhall (Data.Map.Map k v) where-    injectWith options = InputType embedOut declaredOut+    injectWith options = Encoder embedOut declaredOut       where         embedOut m = ListLit listType (mapEntries m)           where@@ -1935,8 +1948,8 @@         recordPair (k, v) = RecordLit (Dhall.Map.fromList                                 [("mapKey", embedK k), ("mapValue", embedV v)]) -        InputType embedK declaredK = injectWith options-        InputType embedV declaredV = injectWith options+        Encoder embedK declaredK = injectWith options+        Encoder embedV declaredV = injectWith options  {-| Embed a `Data.HashMap` as a @Prelude.Map.Type@ @@ -1948,7 +1961,7 @@  -} instance (ToDhall k, ToDhall v) => ToDhall (HashMap k v) where-    injectWith options = InputType embedOut declaredOut+    injectWith options = Encoder embedOut declaredOut       where         embedOut m = ListLit listType (mapEntries m)           where@@ -1963,14 +1976,14 @@         recordPair (k, v) = RecordLit (Dhall.Map.fromList                                 [("mapKey", embedK k), ("mapValue", embedV v)]) -        InputType embedK declaredK = injectWith options-        InputType embedV declaredV = injectWith options+        Encoder embedK declaredK = injectWith options+        Encoder embedV declaredV = injectWith options  {-| This is the underlying class that powers the `FromDhall` class's support     for automatically deriving a generic implementation -} class GenericToDhall f where-    genericToDhallWith :: InterpretOptions -> State Int (InputType (f a))+    genericToDhallWith :: InterpretOptions -> State Int (Encoder (f a))  instance GenericToDhall f => GenericToDhall (M1 D d f) where     genericToDhallWith options = do@@ -1984,7 +1997,7 @@  instance (Selector s, ToDhall a) => GenericToDhall (M1 S s (K1 i a)) where     genericToDhallWith options@InterpretOptions{..} = do-        let InputType { embed = embed', declared = declared' } =+        let Encoder { embed = embed', declared = declared' } =                 injectWith options          let n :: M1 S s (K1 i a) r@@ -2012,10 +2025,10 @@                     _ ->                         Record (Dhall.Map.singleton name declared') -        return (InputType {..})+        return (Encoder {..})  instance (Constructor c1, Constructor c2, GenericToDhall f1, GenericToDhall f2) => GenericToDhall (M1 C c1 f1 :+: M1 C c2 f2) where-    genericToDhallWith options@(InterpretOptions {..}) = pure (InputType {..})+    genericToDhallWith options@(InterpretOptions {..}) = pure (Encoder {..})       where         embed (L1 (M1 l)) =             case notEmptyRecordLit (embedL l) of@@ -2048,11 +2061,11 @@         keyL = constructorModifier (Data.Text.pack (conName nL))         keyR = constructorModifier (Data.Text.pack (conName nR)) -        InputType embedL declaredL = evalState (genericToDhallWith options) 1-        InputType embedR declaredR = evalState (genericToDhallWith options) 1+        Encoder embedL declaredL = evalState (genericToDhallWith options) 1+        Encoder embedR declaredR = evalState (genericToDhallWith options) 1  instance (Constructor c, GenericToDhall (f :+: g), GenericToDhall h) => GenericToDhall ((f :+: g) :+: M1 C c h) where-    genericToDhallWith options@(InterpretOptions {..}) = pure (InputType {..})+    genericToDhallWith options@(InterpretOptions {..}) = pure (Encoder {..})       where         embed (L1 l) =             case maybeValL of@@ -2073,13 +2086,13 @@          declared = Union (Dhall.Map.insert keyR (notEmptyRecord declaredR) ktsL) -        InputType embedL declaredL = evalState (genericToDhallWith options) 1-        InputType embedR declaredR = evalState (genericToDhallWith options) 1+        Encoder embedL declaredL = evalState (genericToDhallWith options) 1+        Encoder embedR declaredR = evalState (genericToDhallWith options) 1          ktsL = unsafeExpectUnion "genericToDhallWith (:+:)" declaredL  instance (Constructor c, GenericToDhall f, GenericToDhall (g :+: h)) => GenericToDhall (M1 C c f :+: (g :+: h)) where-    genericToDhallWith options@(InterpretOptions {..}) = pure (InputType {..})+    genericToDhallWith options@(InterpretOptions {..}) = pure (Encoder {..})       where         embed (L1 (M1 l)) =             case notEmptyRecordLit (embedL l) of@@ -2100,13 +2113,13 @@          declared = Union (Dhall.Map.insert keyL (notEmptyRecord declaredL) ktsR) -        InputType embedL declaredL = evalState (genericToDhallWith options) 1-        InputType embedR declaredR = evalState (genericToDhallWith options) 1+        Encoder embedL declaredL = evalState (genericToDhallWith options) 1+        Encoder embedR declaredR = evalState (genericToDhallWith options) 1          ktsR = unsafeExpectUnion "genericToDhallWith (:+:)" declaredR  instance (GenericToDhall (f :+: g), GenericToDhall (h :+: i)) => GenericToDhall ((f :+: g) :+: (h :+: i)) where-    genericToDhallWith options = pure (InputType {..})+    genericToDhallWith options = pure (Encoder {..})       where         embed (L1 l) =             case maybeValL of@@ -2125,16 +2138,16 @@          declared = Union (Dhall.Map.union ktsL ktsR) -        InputType embedL declaredL = evalState (genericToDhallWith options) 1-        InputType embedR declaredR = evalState (genericToDhallWith options) 1+        Encoder embedL declaredL = evalState (genericToDhallWith options) 1+        Encoder embedR declaredR = evalState (genericToDhallWith options) 1          ktsL = unsafeExpectUnion "genericToDhallWith (:+:)" declaredL         ktsR = unsafeExpectUnion "genericToDhallWith (:+:)" declaredR  instance (GenericToDhall (f :*: g), GenericToDhall (h :*: i)) => GenericToDhall ((f :*: g) :*: (h :*: i)) where     genericToDhallWith options = do-        InputType embedL declaredL <- genericToDhallWith options-        InputType embedR declaredR <- genericToDhallWith options+        Encoder embedL declaredL <- genericToDhallWith options+        Encoder embedR declaredR <- genericToDhallWith options          let embed (l :*: r) =                 RecordLit (Dhall.Map.union mapL mapR)@@ -2150,7 +2163,7 @@                 mapL = unsafeExpectRecord "genericToDhallWith (:*:)" declaredL                 mapR = unsafeExpectRecord "genericToDhallWith (:*:)" declaredR -        pure (InputType {..})+        pure (Encoder {..})  instance (GenericToDhall (f :*: g), Selector s, ToDhall a) => GenericToDhall ((f :*: g) :*: M1 S s (K1 i a)) where     genericToDhallWith options@InterpretOptions{..} = do@@ -2159,9 +2172,9 @@          nameR <- fmap fieldModifier (getSelName nR) -        InputType embedL declaredL <- genericToDhallWith options+        Encoder embedL declaredL <- genericToDhallWith options -        let InputType embedR declaredR = injectWith options+        let Encoder embedR declaredR = injectWith options          let embed (l :*: M1 (K1 r)) =                 RecordLit (Dhall.Map.insert nameR (embedR r) mapL)@@ -2173,7 +2186,7 @@               where                 mapL = unsafeExpectRecord "genericToDhallWith (:*:)" declaredL -        return (InputType {..})+        return (Encoder {..})  instance (Selector s, ToDhall a, GenericToDhall (f :*: g)) => GenericToDhall (M1 S s (K1 i a) :*: (f :*: g)) where     genericToDhallWith options@InterpretOptions{..} = do@@ -2182,9 +2195,9 @@          nameL <- fmap fieldModifier (getSelName nL) -        let InputType embedL declaredL = injectWith options+        let Encoder embedL declaredL = injectWith options -        InputType embedR declaredR <- genericToDhallWith options+        Encoder embedR declaredR <- genericToDhallWith options          let embed (M1 (K1 l) :*: r) =                 RecordLit (Dhall.Map.insert nameL (embedL l) mapR)@@ -2196,7 +2209,7 @@               where                 mapR = unsafeExpectRecord "genericToDhallWith (:*:)" declaredR -        return (InputType {..})+        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     genericToDhallWith options@InterpretOptions{..} = do@@ -2209,8 +2222,8 @@         nameL <- fmap fieldModifier (getSelName nL)         nameR <- fmap fieldModifier (getSelName nR) -        let InputType embedL declaredL = injectWith options-        let InputType embedR declaredR = injectWith options+        let Encoder embedL declaredL = injectWith options+        let Encoder embedR declaredR = injectWith options          let embed (M1 (K1 l) :*: M1 (K1 r)) =                 RecordLit@@ -2224,16 +2237,16 @@                         [ (nameL, declaredL), (nameR, declaredR) ]                     ) -        return (InputType {..})+        return (Encoder {..})  instance GenericToDhall U1 where-    genericToDhallWith _ = pure (InputType {..})+    genericToDhallWith _ = pure (Encoder {..})       where         embed _ = RecordLit mempty          declared = Record mempty -{-| The 'RecordType' applicative functor allows you to build a 'Type' parser+{-| The 'RecordDecoder' applicative functor allows you to build a 'Decoder'     from a Dhall record.      For example, let's take the following Haskell data type:@@ -2257,12 +2270,12 @@ >     289 > } -    Our parser has type 'Type' @Project@, but we can't build that out of any-    smaller parsers, as 'Type's cannot be combined (they are only 'Functor's).-    However, we can use a 'RecordType' to build a 'Type' for @Project@:+    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 :: Type Project+project :: Decoder Project project =   record     ( Project <$> field "name" strictText@@ -2272,8 +2285,8 @@ :} -} -newtype RecordType a =-  RecordType+newtype RecordDecoder a =+  RecordDecoder     ( Data.Functor.Product.Product         ( Control.Applicative.Const             ( Dhall.Map.Map@@ -2290,10 +2303,10 @@   deriving (Functor, Applicative)  --- | Run a 'RecordType' parser to build a 'Type' parser.-record :: RecordType a -> Dhall.Type a-record ( RecordType ( Data.Functor.Product.Pair ( Control.Applicative.Const fields ) ( Data.Functor.Compose.Compose extractF ) ) ) =-  Type+-- | 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 extractF ) ) ) =+  Decoder     { extract =         extractF     , expected =@@ -2302,27 +2315,26 @@   -- | Parse a single field of a record.-field :: Text -> Type a -> RecordType a-field key valueType@(Type extract expected) =+field :: Text -> Decoder a -> RecordDecoder a+field key valueDecoder@(Decoder extract expected) =   let     extractBody expr@(RecordLit fields) = case Dhall.Map.lookup key fields of       Just v -> extract v       _ -> typeError expected expr     extractBody expr = typeError expected expr   in-    RecordType+    RecordDecoder       ( Data.Functor.Product.Pair           ( Control.Applicative.Const               ( Dhall.Map.singleton                   key-                  ( Dhall.expected valueType )+                  ( Dhall.expected valueDecoder )               )           )           ( Data.Functor.Compose.Compose extractBody )       ) -{-| The 'UnionType' monoid allows you to build a 'Type' parser-    from a Dhall union+{-| The 'UnionDecoder' monoid allows you to build a 'Decoder' from a Dhall union      For example, let's take the following Haskell data type: @@ -2340,12 +2352,12 @@ > | Errored : Text > >.Result "Finish successfully" -    Our parser has type 'Type' @Status@, but we can't build that out of any-    smaller parsers, as 'Type's cannot be combined (they are only 'Functor's).-    However, we can use a 'UnionType' to build a 'Type' for @Status@:+    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 :: Type Status+status :: Decoder Status status = union   (  ( Queued  <$> constructor "Queued"  natural )   <> ( Result  <$> constructor "Result"  strictText )@@ -2354,21 +2366,21 @@ :}  -}-newtype UnionType a =-    UnionType-      ( Data.Functor.Compose.Compose (Dhall.Map.Map Text) Type a )+newtype UnionDecoder a =+    UnionDecoder+      ( Data.Functor.Compose.Compose (Dhall.Map.Map Text) Decoder a )   deriving (Functor) -instance Data.Semigroup.Semigroup (UnionType a) where-    (<>) = coerce ((<>) :: Dhall.Map.Map Text (Type a) -> Dhall.Map.Map Text (Type a) -> Dhall.Map.Map Text (Type a))+instance Data.Semigroup.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 (UnionType a) where-    mempty = coerce (mempty :: Dhall.Map.Map Text (Type a))+instance Monoid (UnionDecoder a) where+    mempty = coerce (mempty :: Dhall.Map.Map Text (Decoder a))     mappend = (Data.Semigroup.<>) --- | Run a 'UnionType' parser to build a 'Type' parser.-union :: UnionType a -> Type a-union (UnionType (Data.Functor.Compose.Compose mp)) = Type+-- | Run a 'UnionDecoder' to build a 'Decoder'.+union :: UnionDecoder a -> Decoder a+union (UnionDecoder (Data.Functor.Compose.Compose mp)) = Decoder     { extract  = extractF     , expected = Union expect     }@@ -2387,12 +2399,12 @@       in Data.Maybe.maybe (typeError (Union expect) e0) (uncurry extract) result  -- | Parse a single constructor of a union-constructor :: Text -> Type a -> UnionType a-constructor key valueType = UnionType-    ( Data.Functor.Compose.Compose (Dhall.Map.singleton key valueType) )+constructor :: Text -> Decoder a -> UnionDecoder a+constructor key valueDecoder = UnionDecoder+    ( Data.Functor.Compose.Compose (Dhall.Map.singleton key valueDecoder) ) -{-| The 'RecordInputType' divisible (contravariant) functor allows you to build-    an 'InputType' injector for a Dhall record.+{-| 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: @@ -2415,17 +2427,17 @@ >     289 > } -    Our injector has type 'InputType' @Project@, but we can't build that out of any-    smaller injectors, as 'InputType's cannot be combined (they are only 'Contravariant's).-    However, we can use an 'InputRecordType' to build an 'InputType' for @Project@:+    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 :: InputType Project+injectProject :: Encoder Project injectProject =-  inputRecord-    ( adapt >$< inputFieldWith "name" inject-            >*< inputFieldWith "description" inject-            >*< inputFieldWith "stars" inject+  recordEncoder+    ( adapt >$< encodeFieldWith "name" inject+            >*< encodeFieldWith "description" inject+            >*< encodeFieldWith "stars" inject     )   where     adapt (Project{..}) = (projectName, (projectDescription, projectStars))@@ -2434,12 +2446,12 @@     Or, since we are simply using the `ToDhall` instance to inject each field, we could write  >>> :{-injectProject :: InputType Project+injectProject :: Encoder Project injectProject =-  inputRecord-    ( adapt >$< inputField "name"-            >*< inputField "description"-            >*< inputField "stars"+  recordEncoder+    ( adapt >$< encodeField "name"+            >*< encodeField "description"+            >*< encodeField "stars"     )   where     adapt (Project{..}) = (projectName, (projectDescription, projectStars))@@ -2454,41 +2466,40 @@ infixr 5 >*<  -- | Intermediate type used for building a `ToDhall` instance for a record-newtype RecordInputType a-  = RecordInputType (Dhall.Map.Map Text (InputType a))+newtype RecordEncoder a+  = RecordEncoder (Dhall.Map.Map Text (Encoder a)) -instance Contravariant RecordInputType where-  contramap f (RecordInputType inputTypeRecord) = RecordInputType $ contramap f <$> inputTypeRecord+instance Contravariant RecordEncoder where+  contramap f (RecordEncoder encodeTypeRecord) = RecordEncoder $ contramap f <$> encodeTypeRecord -instance Divisible RecordInputType where-  divide f (RecordInputType bInputTypeRecord) (RecordInputType cInputTypeRecord) =-      RecordInputType+instance Divisible RecordEncoder where+  divide f (RecordEncoder bEncoderRecord) (RecordEncoder cEncoderRecord) =+      RecordEncoder     $ Dhall.Map.union-      ((contramap $ fst . f) <$> bInputTypeRecord)-      ((contramap $ snd . f) <$> cInputTypeRecord)-  conquer = RecordInputType mempty+      ((contramap $ fst . f) <$> bEncoderRecord)+      ((contramap $ snd . f) <$> cEncoderRecord)+  conquer = RecordEncoder mempty  {-| Specify how to encode one field of a record by supplying an explicit-    `InputType` for that field+    `Encoder` for that field -}-inputFieldWith :: Text -> InputType a -> RecordInputType a-inputFieldWith name inputType = RecordInputType $ Dhall.Map.singleton name inputType+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 -}-inputField :: ToDhall a => Text -> RecordInputType a-inputField name = inputFieldWith name inject+encodeField :: ToDhall a => Text -> RecordEncoder a+encodeField name = encodeFieldWith name inject --- | Convert a `RecordInputType` into the equivalent `InputType`-inputRecord :: RecordInputType a -> InputType a-inputRecord (RecordInputType inputTypeRecord) = InputType makeRecordLit recordType+-- | Convert a `RecordEncoder` into the equivalent `Encoder`+recordEncoder :: RecordEncoder a -> Encoder a+recordEncoder (RecordEncoder encodeTypeRecord) = Encoder makeRecordLit recordType   where-    recordType = Record $ declared <$> inputTypeRecord-    makeRecordLit x = RecordLit $ (($ x) . embed) <$> inputTypeRecord+    recordType = Record $ declared <$> encodeTypeRecord+    makeRecordLit x = RecordLit $ (($ x) . embed) <$> encodeTypeRecord -{-| 'UnionInputType' allows you to build an 'InputType' injector for a Dhall-    record.+{-| 'UnionEncoder' allows you to build an 'Encoder' for a Dhall record.      For example, let's take the following Haskell data type: @@ -2506,16 +2517,16 @@ > | Errored : Text > >.Result "Finish successfully" -    Our injector has type 'InputType' @Status@, but we can't build that out of any-    smaller injectors, as 'InputType's cannot be combined.-    However, we can use an 'UnionInputType' to build an 'InputType' for @Status@:+    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 :: InputType Status-injectStatus = adapt >$< inputUnion-  (   inputConstructorWith "Queued"  inject-  >|< inputConstructorWith "Result"  inject-  >|< inputConstructorWith "Errored" inject+injectStatus :: Encoder Status+injectStatus = adapt >$< unionEncoder+  (   encodeConstructorWith "Queued"  inject+  >|< encodeConstructorWith "Result"  inject+  >|< encodeConstructorWith "Errored" inject   )   where     adapt (Queued  n) = Left n@@ -2526,11 +2537,11 @@     Or, since we are simply using the `ToDhall` instance to inject each branch, we could write  >>> :{-injectStatus :: InputType Status-injectStatus = adapt >$< inputUnion-  (   inputConstructor "Queued"-  >|< inputConstructor "Result"-  >|< inputConstructor "Errored"+injectStatus :: Encoder Status+injectStatus = adapt >$< unionEncoder+  (   encodeConstructor "Queued"+  >|< encodeConstructor "Result"+  >|< encodeConstructor "Errored"   )   where     adapt (Queued  n) = Left n@@ -2539,8 +2550,8 @@ :}  -}-newtype UnionInputType a =-  UnionInputType+newtype UnionEncoder a =+  UnionEncoder     ( Data.Functor.Product.Product         ( Control.Applicative.Const             ( Dhall.Map.Map@@ -2553,16 +2564,16 @@     )   deriving (Contravariant) --- | Combines two 'UnionInputType' values.  See 'UnionInputType' for usage+-- | Combines two 'UnionEncoder' values.  See 'UnionEncoder' for usage -- notes. -- -- Ideally, this matches 'Data.Functor.Contravariant.Divisible.chosen';--- however, this allows 'UnionInputType' to not need a 'Divisible' instance+-- however, this allows 'UnionEncoder' to not need a 'Divisible' instance -- itself (since no instance is possible).-(>|<) :: UnionInputType a -> UnionInputType b -> UnionInputType (Either a b)-UnionInputType (Data.Functor.Product.Pair (Control.Applicative.Const mx) (Op fx))-    >|< UnionInputType (Data.Functor.Product.Pair (Control.Applicative.Const my) (Op fy)) =-    UnionInputType+(>|<) :: 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) )@@ -2570,10 +2581,10 @@  infixr 5 >|< --- | Convert a `UnionInputType` into the equivalent `InputType`-inputUnion :: UnionInputType a -> InputType a-inputUnion ( UnionInputType ( Data.Functor.Product.Pair ( Control.Applicative.Const fields ) ( Op embedF ) ) ) =-    InputType+-- | 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@@ -2585,29 +2596,29 @@   where     fields' = fmap notEmptyRecord fields -{-| Specify how to encode an alternative by providing an explicit `InputType`+{-| Specify how to encode an alternative by providing an explicit `Encoder`     for that alternative -}-inputConstructorWith+encodeConstructorWith     :: Text-    -> InputType a-    -> UnionInputType a-inputConstructorWith name inputType = UnionInputType $+    -> Encoder a+    -> UnionEncoder a+encodeConstructorWith name encodeType = UnionEncoder $     Data.Functor.Product.Pair       ( Control.Applicative.Const           ( Dhall.Map.singleton               name-              ( declared inputType )+              ( declared encodeType )           )       )-      ( Op ( (name,) . embed inputType )+      ( Op ( (name,) . embed encodeType )       )  {-| Specify how to encode an alternative by using the default `ToDhall` instance     for that type -}-inputConstructor+encodeConstructor     :: ToDhall a     => Text-    -> UnionInputType a-inputConstructor name = inputConstructorWith name inject+    -> UnionEncoder a+encodeConstructor name = encodeConstructorWith name inject

src/Dhall/Binary.hs view

@@ -1,967 +1,1248 @@-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE FlexibleInstances  #-}-{-# LANGUAGE RecordWildCards    #-}-{-# LANGUAGE OverloadedStrings  #-}--{-| This module contains logic for converting Dhall expressions to and from-    CBOR expressions which can in turn be converted to and from a binary-    representation--}--module Dhall.Binary-    ( -- * Standard versions-      StandardVersion(..)-    , renderStandardVersion--    -- * Encoding and decoding-    , ToTerm(..)-    , FromTerm(..)-    , encodeExpression-    , decodeExpression--    -- * Exceptions-    , DecodingFailure(..)-    ) where--import Codec.CBOR.Term (Term(..))-import Control.Applicative (empty, (<|>))-import Control.Exception (Exception)-import Dhall.Core-    ( Binding(..)-    , Chunks(..)-    , Const(..)-    , Directory(..)-    , DhallDouble(..)-    , Expr(..)-    , File(..)-    , FilePrefix(..)-    , Import(..)-    , ImportHashed(..)-    , ImportMode(..)-    , ImportType(..)-    , MultiLet(..)-    , Scheme(..)-    , URL(..)-    , Var(..)-    )--import Data.Foldable (toList)-import Data.Monoid ((<>))-import Data.Text (Text)-import Data.Void (Void, absurd)-import GHC.Float (double2Float, float2Double)--import qualified Control.Monad       as Monad-import qualified Data.ByteArray-import qualified Data.ByteString-import qualified Data.Sequence-import qualified Dhall.Core-import qualified Dhall.Crypto-import qualified Dhall.Map-import qualified Dhall.Set--{-| 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 `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--}-unApply :: Expr s a -> (Expr s a, [Expr s a])-unApply e₀ = (baseFunction₀, diffArguments₀ [])-  where-    ~(baseFunction₀, diffArguments₀) = go e₀--    go (App f a) = (baseFunction, diffArguments . (a :))-      where-        ~(baseFunction, diffArguments) = go f--    go (Note _ e) = go e--    go baseFunction = (baseFunction, id)---- | Types that can be encoded as a CBOR `Term`-class ToTerm a where-    encode :: a -> Term--instance ToTerm a => ToTerm (Expr Void a) where-    encode (Var (V "_" n)) =-        TInt n-    encode (Var (V x n)) =-        TList [ TString x, TInt n ]-    encode NaturalBuild =-        TString "Natural/build"-    encode NaturalFold =-        TString "Natural/fold"-    encode NaturalIsZero =-        TString "Natural/isZero"-    encode NaturalEven =-        TString "Natural/even"-    encode NaturalOdd =-        TString "Natural/odd"-    encode NaturalToInteger =-        TString "Natural/toInteger"-    encode NaturalShow =-        TString "Natural/show"-    encode NaturalSubtract =-        TString "Natural/subtract"-    encode IntegerToDouble =-        TString "Integer/toDouble"-    encode IntegerShow =-        TString "Integer/show"-    encode DoubleShow =-        TString "Double/show"-    encode ListBuild =-        TString "List/build"-    encode ListFold =-        TString "List/fold"-    encode ListLength =-        TString "List/length"-    encode ListHead =-        TString "List/head"-    encode ListLast =-        TString "List/last"-    encode ListIndexed =-        TString "List/indexed"-    encode ListReverse =-        TString "List/reverse"-    encode OptionalFold =-        TString "Optional/fold"-    encode OptionalBuild =-        TString "Optional/build"-    encode Bool =-        TString "Bool"-    encode Optional =-        TString "Optional"-    encode None =-        TString "None"-    encode Natural =-        TString "Natural"-    encode Integer =-        TString "Integer"-    encode Double =-        TString "Double"-    encode Text =-        TString "Text"-    encode TextShow =-        TString "Text/show"-    encode List =-        TString "List"-    encode (Const Type) =-        TString "Type"-    encode (Const Kind) =-        TString "Kind"-    encode (Const Sort) =-        TString "Sort"-    encode e@(App _ _) =-        TList ([ TInt 0, f₁ ] ++ map encode arguments)-      where-        (f₀, arguments) = unApply e--        f₁ = encode f₀-    encode (Lam "_" _A₀ b₀) =-        TList [ TInt 1, _A₁, b₁ ]-      where-        _A₁ = encode _A₀-        b₁  = encode b₀-    encode (Lam x _A₀ b₀) =-        TList [ TInt 1, TString x, _A₁, b₁ ]-      where-        _A₁ = encode _A₀-        b₁  = encode b₀-    encode (Pi "_" _A₀ _B₀) =-        TList [ TInt 2, _A₁, _B₁ ]-      where-        _A₁ = encode _A₀-        _B₁ = encode _B₀-    encode (Pi x _A₀ _B₀) =-        TList [ TInt 2, TString x, _A₁, _B₁ ]-      where-        _A₁ = encode _A₀-        _B₁ = encode _B₀-    encode (BoolOr l₀ r₀) =-        TList [ TInt 3, TInt 0, l₁, r₁ ]-      where-        l₁ = encode l₀-        r₁ = encode r₀-    encode (BoolAnd l₀ r₀) =-        TList [ TInt 3, TInt 1, l₁, r₁ ]-      where-        l₁ = encode l₀-        r₁ = encode r₀-    encode (BoolEQ l₀ r₀) =-        TList [ TInt 3, TInt 2, l₁, r₁ ]-      where-        l₁ = encode l₀-        r₁ = encode r₀-    encode (BoolNE l₀ r₀) =-        TList [ TInt 3, TInt 3, l₁, r₁ ]-      where-        l₁ = encode l₀-        r₁ = encode r₀-    encode (NaturalPlus l₀ r₀) =-        TList [ TInt 3, TInt 4, l₁, r₁ ]-      where-        l₁ = encode l₀-        r₁ = encode r₀-    encode (NaturalTimes l₀ r₀) =-        TList [ TInt 3, TInt 5, l₁, r₁ ]-      where-        l₁ = encode l₀-        r₁ = encode r₀-    encode (TextAppend l₀ r₀) =-        TList [ TInt 3, TInt 6, l₁, r₁ ]-      where-        l₁ = encode l₀-        r₁ = encode r₀-    encode (ListAppend l₀ r₀) =-        TList [ TInt 3, TInt 7, l₁, r₁ ]-      where-        l₁ = encode l₀-        r₁ = encode r₀-    encode (Combine l₀ r₀) =-        TList [ TInt 3, TInt 8, l₁, r₁ ]-      where-        l₁ = encode l₀-        r₁ = encode r₀-    encode (Prefer l₀ r₀) =-        TList [ TInt 3, TInt 9, l₁, r₁ ]-      where-        l₁ = encode l₀-        r₁ = encode r₀-    encode (CombineTypes l₀ r₀) =-        TList [ TInt 3, TInt 10, l₁, r₁ ]-      where-        l₁ = encode l₀-        r₁ = encode r₀-    encode (ImportAlt l₀ r₀) =-        TList [ TInt 3, TInt 11, l₁, r₁ ]-      where-        l₁ = encode l₀-        r₁ = encode r₀-    encode (Equivalent l₀ r₀) =-        TList [ TInt 3, TInt 12, l₁, r₁ ]-      where-        l₁ = encode l₀-        r₁ = encode r₀-    encode (RecordCompletion l₀ r₀) =-        TList [ TInt 3, TInt 13, l₁, r₁ ]-      where-        l₁ = encode l₀-        r₁ = encode r₀-    encode (ListLit _T₀ xs₀)-        | null xs₀  = TList [ TInt label, _T₁ ]-        | otherwise = TList ([ TInt 4, TNull ] ++ xs₁)-      where-        (label, _T₁) = case _T₀ of-            Nothing           -> (4 , TNull)-            Just (App List t) -> (4 , encode t)-            Just t            -> (28, encode t)--        xs₁ = map encode (Data.Foldable.toList xs₀)-    encode (Some t₀) =-        TList [ TInt 5, TNull, t₁ ]-      where-        t₁ = encode t₀-    encode (Merge t₀ u₀ Nothing) =-        TList [ TInt 6, t₁, u₁ ]-      where-        t₁ = encode t₀-        u₁ = encode u₀-    encode (Merge t₀ u₀ (Just _T₀)) =-        TList [ TInt 6, t₁, u₁, _T₁ ]-      where-        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 (Dhall.Map.sort xTs₀)-            let x₁  = TString x₀-            let _T₁ = encode _T₀-            return (x₁, _T₁)-    encode (RecordLit xts₀) =-        TList [ TInt 8, TMap xts₁ ]-      where-        xts₁ = do-            (x₀, t₀) <- Dhall.Map.toList (Dhall.Map.sort xts₀)-            let x₁ = TString x₀-            let t₁ = encode t₀-            return (x₁, t₁)-    encode (Field t₀ x) =-        TList [ TInt 9, t₁, TString x ]-      where-        t₁ = encode t₀-    encode (Project t₀ (Left xs₀)) =-        TList ([ TInt 10, t₁ ] ++ xs₁)-      where-        t₁  = encode t₀-        xs₁ = map TString (Dhall.Set.toList xs₀)-    encode (Project t₀ (Right _T₀)) =-        TList [ TInt 10, t₁, TList [ _T₁ ] ]-      where-        _T₁ = encode _T₀-        t₁  = encode t₀-    encode (Union xTs₀) =-        TList [ TInt 11, TMap xTs₁ ]-      where-        xTs₁ = do-            (x₀, mT₀) <- Dhall.Map.toList (Dhall.Map.sort xTs₀)--            let x₁  = TString x₀--            let _T₁ = case mT₀ of-                    Nothing  -> TNull-                    Just _T₀ -> encode _T₀--            return (x₁, _T₁)-    encode (BoolLit b) =-        TBool b-    encode (BoolIf t₀ l₀ r₀) =-        TList [ TInt 14, t₁, l₁, r₁ ]-      where-        t₁ = encode t₀-        l₁ = encode l₀-        r₁ = encode r₀-    encode (NaturalLit n) =-        TList [ TInt 15, TInteger (fromIntegral n) ]-    encode (IntegerLit n) =-        TList [ TInt 16, TInteger n ]-    encode (DoubleLit d) =-        encode d-    encode (TextLit (Chunks xys₀ z₀)) =-        TList ([ TInt 18 ] ++ xys₁ ++ [ z₁ ])-      where-        xys₁ = do-            (x₀, y₀) <- xys₀-            let x₁ = TString x₀-            let y₁ = encode y₀-            [ x₁, y₁ ]--        z₁ = TString z₀-    encode (Assert t₀) =-        TList [ TInt 19, t₁ ]-      where-        t₁ = encode t₀-    encode (Embed x) =-        encode x-    encode (Let a b) =-        TList ([ TInt 25 ] ++ as₁ ++ [ b₁ ])-      where-        MultiLet as₀ b₀ = Dhall.Core.multiLet a b--        as₁ = do-            Binding _ x₀ _ mA₀ _ a₀ <- toList as₀--            let mA₁ = case mA₀ of-                    Nothing       -> TNull-                    Just (_, _A₀) -> encode _A₀--            let a₁ = encode a₀--            [ TString x₀, mA₁, a₁ ]--        b₁ = encode b₀-    encode (Annot t₀ _T₀) =-        TList [ TInt 26, t₁, _T₁ ]-      where-        t₁  = encode t₀-        _T₁ = encode _T₀-    encode (ToMap t₀ Nothing) =-        TList [ TInt 27, t₁ ]-      where-        t₁ = encode t₀-    encode (ToMap t₀ (Just _T₀)) =-        TList [ TInt 27, t₁, _T₁ ]-      where-        t₁  = encode t₀-        _T₁ = encode _T₀-    encode (Note a _) = absurd a--instance ToTerm Import where-    encode import_ =-        case importType of-            Remote (URL { scheme = scheme₀, ..}) ->-                TList-                    (   prefix-                    ++  [ TInt scheme₁, using, TString authority ]-                    ++  map TString (reverse components)-                    ++  [ TString file ]-                    ++  (case query    of Nothing -> [ TNull ]; Just q -> [ TString q ])-                    )-              where-                using = case headers of-                    Nothing ->-                        TNull-                    Just h ->-                        encodeExpression h--                scheme₁ = case scheme₀ of-                    HTTP  -> 0-                    HTTPS -> 1-                File {..} = path--                Directory {..} = directory--            Local prefix₀ path ->-                    TList-                        (   prefix-                        ++  [ TInt prefix₁ ]-                        ++  map TString components₁-                        ++  [ TString file ]-                        )-              where-                File {..} = path--                Directory {..} = directory--                prefix₁ = case prefix₀ of-                  Absolute -> 2-                  Here     -> 3-                  Parent   -> 4-                  Home     -> 5--                components₁ = reverse components--            Env x ->-                TList (prefix ++ [ TInt 6, TString x ])--            Missing ->-                TList (prefix ++ [ TInt 7 ])-      where-        prefix = [ TInt 24, h, m ]-          where-            h = case hash of-                Nothing ->-                    TNull-                Just digest ->-                    TBytes ("\x12\x20" <> Data.ByteArray.convert digest)--            m = TInt (case importMode of Code -> 0; RawText -> 1; Location -> 2;)--        Import {..} = import_--        ImportHashed {..} = importHashed--instance ToTerm Void where-    encode = absurd--instance ToTerm DhallDouble where-    encode (DhallDouble n64)-        -- cborg always encodes NaN as a half-precision float of value "7e00"-        | useHalf   = THalf n32-        | useFloat  = TFloat n32-        | otherwise = TDouble n64-      where-        n32      = double2Float n64-        useFloat = n64 == float2Double n32-        -- the other four cases for Half-floats are -0.0, 0.0 and the infinities-        useHalf  = n64 == 0.0 || n64 == infinity || n64 == -infinity-        infinity = 1/0 :: Double---- | Types that can be decoded from a CBOR `Term`-class FromTerm a where-    decode :: Term -> Maybe a--instance FromTerm a => FromTerm (Expr s a) where-    decode (TInt n) =-        return (Var (V "_" n))-    decode (TInteger n) =-        return (Var (V "_" (fromIntegral n)))-    decode (TString "Natural/build") =-        return NaturalBuild-    decode (TString "Natural/fold") =-        return NaturalFold-    decode (TString "Natural/isZero") =-        return NaturalIsZero-    decode (TString "Natural/even") =-        return NaturalEven-    decode (TString "Natural/odd") =-        return NaturalOdd-    decode (TString "Natural/toInteger") =-        return NaturalToInteger-    decode (TString "Natural/show") =-        return NaturalShow-    decode (TString "Natural/subtract") =-        return NaturalSubtract-    decode (TString "Integer/toDouble") =-        return IntegerToDouble-    decode (TString "Integer/show") =-        return IntegerShow-    decode (TString "Double/show") =-        return DoubleShow-    decode (TString "List/build") =-        return ListBuild-    decode (TString "List/fold") =-        return ListFold-    decode (TString "List/length") =-        return ListLength-    decode (TString "List/head") =-        return ListHead-    decode (TString "List/last") =-        return ListLast-    decode (TString "List/indexed") =-        return ListIndexed-    decode (TString "List/reverse") =-        return ListReverse-    decode (TString "Optional/fold") =-        return OptionalFold-    decode (TString "Optional/build") =-        return OptionalBuild-    decode (TString "Bool") =-        return Bool-    decode (TString "Optional") =-        return Optional-    decode (TString "None") =-        return None-    decode (TString "Natural") =-        return Natural-    decode (TString "Integer") =-        return Integer-    decode (TString "Double") =-        return Double-    decode (TString "Text") =-        return Text-    decode (TString "Text/show") =-        return TextShow-    decode (TString "List") =-        return List-    decode (TString "Type") =-        return (Const Type)-    decode (TString "Kind") =-        return (Const Kind)-    decode (TString "Sort") =-        return (Const Sort)-    decode (TString "_") =-        empty-    decode (TList [ TString x, TInt n ]) = do-        Monad.guard (x /= "_")-        return (Var (V x n))-    decode (TList [ TString x, TInteger n ]) = do-        Monad.guard (x /= "_")-        return (Var (V x (fromIntegral n)))-    decode (TList (TInt 0 : f₁ : xs₁)) = do-        f₀  <- decode f₁-        xs₀ <- traverse decode xs₁-        Monad.guard (not (null xs₀))-        return (foldl App f₀ xs₀)-    decode (TList [ TInt 1, _A₁, b₁ ]) = do-        _A₀ <- decode _A₁-        b₀  <- decode b₁-        return (Lam "_" _A₀ b₀)-    decode (TList [ TInt 1, TString x, _A₁, b₁ ]) = do-        Monad.guard (x /= "_")-        _A₀ <- decode _A₁-        b₀  <- decode b₁-        return (Lam x _A₀ b₀)-    decode (TList [ TInt 2, _A₁, _B₁ ]) = do-        _A₀ <- decode _A₁-        _B₀ <- decode _B₁-        return (Pi "_" _A₀ _B₀)-    decode (TList [ TInt 2, TString x, _A₁, _B₁ ]) = do-        Monad.guard (x /= "_")-        _A₀ <- decode _A₁-        _B₀ <- decode _B₁-        return (Pi x _A₀ _B₀)-    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-                2  -> return BoolEQ-                3  -> return BoolNE-                4  -> return NaturalPlus-                5  -> return NaturalTimes-                6  -> return TextAppend-                7  -> return ListAppend-                8  -> return Combine-                9  -> return Prefer-                10 -> return CombineTypes-                11 -> return ImportAlt-                12 -> return Equivalent-                13 -> return RecordCompletion-                _  -> empty-        return (op l₀ r₀)-    decode (TList [ TInt 4, _T₁ ]) = do-        _T₀ <- decode _T₁-        return (ListLit (Just (App List _T₀)) empty)-    decode (TList (TInt 4 : TNull : xs₁ )) = do-        xs₀ <- traverse decode xs₁-        return (ListLit Nothing (Data.Sequence.fromList xs₀))-    decode (TList [ TInt 5, TNull, t₁ ]) = do-        t₀ <- decode t₁-        return (Some t₀)-    decode (TList [ TInt 6, t₁, u₁ ]) = do-        t₀ <- decode t₁-        u₀ <- decode u₁-        return (Merge t₀ u₀ Nothing)-    decode (TList [ TInt 6, t₁, u₁, _T₁ ]) = do-        t₀  <- decode t₁-        u₀  <- decode u₁-        _T₀ <- decode _T₁-        return (Merge t₀ u₀ (Just _T₀))-    decode (TList [ TInt 7, TMap xTs₁ ]) = do-        let process (TString x, _T₁) = do-                _T₀ <- decode _T₁--                return (x, _T₀)-            process _ =-                empty--        xTs₀ <- traverse process xTs₁--        return (Record (Dhall.Map.fromList xTs₀))-    decode (TList [ TInt 8, TMap xts₁ ]) = do-        let process (TString x, t₁) = do-               t₀ <- decode t₁--               return (x, t₀)-            process _ =-                empty--        xts₀ <- traverse process xts₁--        return (RecordLit (Dhall.Map.fromList xts₀))-    decode (TList [ TInt 9, t₁, TString x ]) = do-        t₀ <- decode t₁--        return (Field t₀ x)-    decode (TList (TInt 10 : t₁ : xs₁)) = do-        t₀ <- decode t₁--        let expectString (TString x) = return x-            expectString  _          = empty--        let decodeLeft = do-                strings <- traverse expectString xs₁--                return (Left (Dhall.Set.fromList strings))--        let decodeRight =-                case xs₁ of-                    [ TList [ _T₁ ] ] -> do-                        _T₀ <- decode _T₁--                        return (Right _T₀)-                    _ -> do-                        empty--        xs₀ <- decodeLeft <|> decodeRight--        return (Project t₀ xs₀)-    decode (TList [ TInt 11, TMap xTs₁ ]) = do-        let process (TString x, _T₁) = do-                mT₀ <- case _T₁ of-                    TNull -> return Nothing-                    _     -> fmap Just (decode _T₁)--                return (x, mT₀)-            process _ =-                empty--        xTs₀ <- traverse process xTs₁--        return (Union (Dhall.Map.fromList xTs₀))-    decode (TBool b) = do-        return (BoolLit b)-    decode (TList [ TInt 14, t₁, l₁, r₁ ]) = do-        t₀ <- decode t₁-        l₀ <- decode l₁-        r₀ <- decode r₁--        return (BoolIf t₀ l₀ r₀)-    decode (TList [ TInt 15, TInt n ]) = do-        Monad.guard (0 <= n)-        return (NaturalLit (fromIntegral n))-    decode (TList [ TInt 15, TInteger n ]) = do-        return (NaturalLit (fromInteger n))-    decode (TList [ TInt 16, TInt n ]) = do-        return (IntegerLit (fromIntegral n))-    decode (TList [ TInt 16, TInteger n ]) = do-        return (IntegerLit n)-    decode (THalf n) = do-        return (DoubleLit (DhallDouble (float2Double n)))-    decode (TFloat n) = do-        return (DoubleLit (DhallDouble (float2Double n)))-    decode (TDouble n) = do-        return (DoubleLit (DhallDouble n))-    decode (TList (TInt 18 : xs)) = do-        let process (TString x : y₁ : zs) = do-                y₀ <- decode y₁--                ~(xys, z) <- process zs--                return ((x, y₀) : xys, z)-            process [ TString z ] = do-                return ([], z)-            process _ = do-                empty--        (xys, z) <- process xs--        return (TextLit (Chunks xys z))-    decode (TList [ TInt 19, t₁ ]) = do-        t₀ <- decode t₁--        return (Assert t₀)-    decode e@(TList (TInt 24 : _)) = fmap Embed (decode e)-    decode (TList (TInt 25 : xs)) = do-        let process (TString x : _A₁ : a₁ : ls₁) = do-                mA₀ <- case _A₁ of-                    TNull -> return Nothing-                    _     -> do-                        _A₀ <- decode _A₁-                        return (Just (Nothing, _A₀))--                a₀  <- decode a₁--                b₀ <- case ls₁ of-                    [ b₁ ] -> decode b₁-                    _      -> process ls₁--                return (Let (Binding Nothing x Nothing mA₀ Nothing a₀) b₀)-            process _ = do-                empty--        process xs-    decode (TList [ TInt 26, t₁, _T₁ ]) = do-        t₀  <- decode t₁-        _T₀ <- decode _T₁-        return (Annot t₀ _T₀)-    decode (TList [ TInt 27, t₁ ]) = do-        t₀ <- decode t₁-        return (ToMap t₀ Nothing)-    decode (TList [ TInt 27, t₁, _T₁ ]) = do-        t₀ <- decode t₁-        _T₀ <- decode _T₁-        return (ToMap t₀ (Just _T₀))-    decode (TList [ TInt 28, _T₁ ]) = do-        _T₀ <- decode _T₁-        return (ListLit (Just _T₀) empty)-    decode _ =-        empty--instance FromTerm Import where-    decode (TList (TInt 24 : h : TInt mode : TInt n : xs)) = do-        hash <- case h of-            TNull -> do-                return Nothing--            TBytes bytes -> do-                let (prefix, suffix) = Data.ByteString.splitAt 2 bytes--                case prefix of-                    "\x12\x20" -> return ()-                    _          -> empty--                digest <- case Dhall.Crypto.sha256DigestFromByteString suffix of-                    Nothing     -> empty-                    Just digest -> return digest--                return (Just digest)--            _ -> do-                empty--        importMode <- case mode of-            0 -> return Code-            1 -> return RawText-            2 -> return Location-            _ -> empty--        let remote scheme = do-                let process [ TString file, q ] = do-                        query <- case q of-                            TNull     -> return Nothing-                            TString x -> return (Just x)-                            _         -> empty-                        return ([], file, query)-                    process (TString path : ys) = do-                        (paths, file, query) <- process ys-                        return (path : paths, file, query)-                    process _ = do-                        empty--                (headers, authority, paths, file, query) <- case xs of-                    headers₀ : TString authority : ys -> do-                        headers₁ <- case headers₀ of-                            TNull -> do-                                return Nothing-                            _     -> do-                                headers <- decode headers₀--                                return (Just headers)-                        (paths, file, query) <- process ys-                        return (headers₁, authority, paths, file, query)-                    _ -> do-                        empty--                let components = reverse paths-                let directory  = Directory {..}-                let path       = File {..}--                return (Remote (URL {..}))--        let local prefix = do-                let process [ TString file ] = do-                        return ([], file)-                    process (TString path : ys) = do-                        (paths, file) <- process ys-                        return (path : paths, file)-                    process _ =-                        empty--                (paths, file) <- process xs--                let components = reverse paths-                let directory  = Directory {..}--                return (Local prefix (File {..}))--        let env = do-                case xs of-                    [ TString x ] -> return (Env x)-                    _             -> empty--        let missing = return Missing--        importType <- case n of-            0 -> remote HTTP-            1 -> remote HTTPS-            2 -> local Absolute-            3 -> local Here-            4 -> local Parent-            5 -> local Home-            6 -> env-            7 -> missing-            _ -> empty--        let importHashed = ImportHashed {..}--        return (Import {..})--    decode _ = empty--instance FromTerm Void where-    decode _ = empty--strip55799Tag :: Term -> Term-strip55799Tag term =-    case term of-        TInt a ->-            TInt a-        TInteger a ->-            TInteger a-        TBytes a ->-            TBytes a-        TBytesI a ->-            TBytesI a-        TString a ->-            TString a-        TStringI a ->-            TStringI a-        TList as ->-            TList (fmap strip55799Tag as)-        TListI as ->-            TListI (fmap strip55799Tag as)-        TMap as ->-            TMap (fmap adapt as)-          where-            adapt (a, b) = (strip55799Tag a, strip55799Tag b)-        TMapI as ->-            TMapI (fmap adapt as)-          where-            adapt (a, b) = (strip55799Tag a, strip55799Tag b)-        TTagged 55799 b ->-            strip55799Tag b-        TTagged a b->-            TTagged a (strip55799Tag b)-        TBool a ->-            TBool a-        TNull ->-            TNull-        TSimple a ->-            TSimple a-        THalf a ->-            THalf a-        TFloat a ->-            TFloat a-        TDouble a ->-            TDouble a---- | Encode a Dhall expression as a CBOR `Term`------ This 'Dhall.Core.denote's the expression before encoding it. To encode an--- already denoted expression, it is more efficient to directly use 'encode'.-encodeExpression :: Expr s Import -> Term-encodeExpression e = encode (Dhall.Core.denote e :: Expr Void Import)---- | Decode a Dhall expression from a CBOR `Term`-decodeExpression :: FromTerm a => Term -> Either DecodingFailure (Expr s a)-decodeExpression term =-    case decodeWithoutVersion <|> decodeWithVersion of-        Just expression -> Right expression-        Nothing         -> Left (CBORIsNotDhall term)-  where-    strippedTerm = strip55799Tag term-    -- This is the behavior specified by the standard-    decodeWithoutVersion = decode strippedTerm--    -- For backwards compatibility with older expressions that have a version-    -- tag to ease the migration-    decodeWithVersion = do-        TList [ TString version, taggedTerm ] <- return strippedTerm--        -- "_" has never been a valid version string, and this ensures that we-        -- don't interpret `[ "_", 0 ]` as the expression `_` (encoded as `0`)-        -- tagged with a version string of `"_"`-        Monad.guard (version /= "_")--        decode taggedTerm--{-| This indicates that a given CBOR expression did not correspond to a valid-    Dhall expression--}-data DecodingFailure = CBORIsNotDhall Term-    deriving (Eq)--instance Exception DecodingFailure--_ERROR :: String-_ERROR = "\ESC[1;31mError\ESC[0m"--instance Show DecodingFailure where-    show (CBORIsNotDhall term) =-            _ERROR <> ": Cannot decode CBOR to Dhall\n"-        <>  "\n"-        <>  "The following CBOR expression does not encode a valid Dhall expression\n"-        <>  "\n"-        <>  "↳ " <> show term <> "\n"+{-# LANGUAGE BangPatterns       #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE RecordWildCards    #-}+{-# LANGUAGE OverloadedStrings  #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++{-| This module contains logic for converting Dhall expressions to and from+    CBOR expressions which can in turn be converted to and from a binary+    representation+-}++module Dhall.Binary+    ( -- * Standard versions+      StandardVersion(..)+    , renderStandardVersion++    -- * Encoding and decoding+    , encodeExpression+    , decodeExpression++    -- * Exceptions+    , DecodingFailure(..)+    ) where++import Codec.CBOR.Decoding (Decoder, TokenType(..))+import Codec.CBOR.Encoding (Encoding)+import Codec.Serialise (Serialise(encode, decode))+import Control.Applicative (empty, (<|>))+import Control.Exception (Exception)+import Data.ByteString.Lazy (ByteString)+import Dhall.Syntax+    ( Binding(..)+    , Chunks(..)+    , Const(..)+    , Directory(..)+    , DhallDouble(..)+    , Expr(..)+    , File(..)+    , FilePrefix(..)+    , Import(..)+    , ImportHashed(..)+    , ImportMode(..)+    , ImportType(..)+    , MultiLet(..)+    , Scheme(..)+    , URL(..)+    , Var(..)+    )++import Data.Foldable (toList, foldl')+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Void (Void, absurd)+import GHC.Float (double2Float, float2Double)++import qualified Codec.CBOR.Decoding  as Decoding+import qualified Codec.CBOR.Encoding  as Encoding+import qualified Codec.CBOR.Read      as Read+import qualified Codec.Serialise      as Serialise+import qualified Control.Monad        as Monad+import qualified Data.ByteArray+import qualified Data.ByteString+import qualified Data.ByteString.Lazy+import qualified Data.Sequence+import qualified Data.Text            as Text+import qualified Dhall.Syntax+import qualified Dhall.Crypto+import qualified Dhall.Map+import qualified Dhall.Set+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 `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+-}+unApply :: Expr s a -> (Expr s a, [Expr s a])+unApply e₀ = (baseFunction₀, diffArguments₀ [])+  where+    ~(baseFunction₀, diffArguments₀) = go e₀++    go (App f a) = (baseFunction, diffArguments . (a :))+      where+        ~(baseFunction, diffArguments) = go f++    go (Note _ e) = go e++    go baseFunction = (baseFunction, id)++decodeExpressionInternal :: (Int -> Decoder s a) -> Decoder s (Expr t a)+decodeExpressionInternal decodeEmbed = go+  where+    go = do+        let die message = fail ("Dhall.Binary.decodeExpressionInternal: " <> message)++        tokenType₀ <- Decoding.peekTokenType++        case tokenType₀ of+            TypeUInt -> do+                !n <- Decoding.decodeWord++                return (Var (V "_" (fromIntegral n)))++            TypeUInt64 -> do+                !n <- Decoding.decodeWord64++                return (Var (V "_" (fromIntegral n)))++            TypeFloat16 -> do+                !n <- Decoding.decodeFloat++                return (DoubleLit (DhallDouble (float2Double n)))++            TypeFloat32 -> do+                !n <- Decoding.decodeFloat++                return (DoubleLit (DhallDouble (float2Double n)))++            TypeFloat64 -> do+                !n <- Decoding.decodeDouble++                return (DoubleLit (DhallDouble n))++            TypeBool -> do+                !b <- Decoding.decodeBool++                return (BoolLit b)++            TypeString -> do+                s <- Decoding.decodeString++                case s of+                    "Natural/build"     -> return NaturalBuild+                    "Natural/fold"      -> return NaturalFold+                    "Natural/isZero"    -> return NaturalIsZero+                    "Natural/even"      -> return NaturalEven+                    "Natural/odd"       -> return NaturalOdd+                    "Natural/toInteger" -> return NaturalToInteger+                    "Natural/show"      -> return NaturalShow+                    "Natural/subtract"  -> return NaturalSubtract+                    "Integer/toDouble"  -> return IntegerToDouble+                    "Integer/clamp"     -> return IntegerClamp+                    "Integer/negate"    -> return IntegerNegate+                    "Integer/show"      -> return IntegerShow+                    "Double/show"       -> return DoubleShow+                    "List/build"        -> return ListBuild+                    "List/fold"         -> return ListFold+                    "List/length"       -> return ListLength+                    "List/head"         -> return ListHead+                    "List/last"         -> return ListLast+                    "List/indexed"      -> return ListIndexed+                    "List/reverse"      -> return ListReverse+                    "Optional/fold"     -> return OptionalFold+                    "Optional/build"    -> return OptionalBuild+                    "Bool"              -> return Bool+                    "Optional"          -> return Optional+                    "None"              -> return None+                    "Natural"           -> return Natural+                    "Integer"           -> return Integer+                    "Double"            -> return Double+                    "Text"              -> return Text+                    "Text/show"         -> return TextShow+                    "List"              -> return List+                    "Type"              -> return (Const Type)+                    "Kind"              -> return (Const Kind)+                    "Sort"              -> return (Const Sort)+                    _                   -> die ("Unrecognized built-in: " <> Text.unpack s)++            TypeListLen -> do+                len <- Decoding.decodeListLen++                case len of+                    0 -> die "Missing tag"+                    _ -> return ()++                tokenType₁ <- Decoding.peekTokenType++                case tokenType₁ of+                    TypeString -> do+                        x <- Decoding.decodeString++                        if x == "_"+                            then die "Non-standard encoding of an α-normalized variable"+                            else return ()++                        tokenType₂ <- Decoding.peekTokenType++                        case tokenType₂ of+                            TypeUInt -> do+                                !n <- Decoding.decodeWord++                                return (Var (V x (fromIntegral n)))++                            TypeUInt64 -> do+                                !n <- Decoding.decodeWord64++                                return (Var (V x (fromIntegral n)))++                            _ -> do+                                die ("Unexpected token type for variable index: " <> show tokenType₂)++                    TypeUInt -> do+                        tag <- Decoding.decodeWord++                        case tag of+                            0 -> do+                                f <- go++                                xs <- Monad.replicateM (len - 2) go++                                if null xs+                                    then die "Non-standard encoding of a function with no arguments"+                                    else return ()++                                return (foldl' App f xs)++                            1 -> do+                                case len of+                                    3 -> do+                                        _A <- go++                                        b <- go++                                        return (Lam "_" _A b)++                                    4 -> do+                                        x <- Decoding.decodeString++                                        if x == "_"+                                            then die "Non-standard encoding of a λ expression"+                                            else return ()++                                        _A <- go++                                        b <- go++                                        return (Lam x _A b)++                                    _ -> do+                                        die ("Incorrect number of tokens used to encode a λ expression: " <> show len)++                            2 -> do+                                case len of+                                    3 -> do+                                        _A <- go++                                        _B <- go++                                        return (Pi "_" _A _B)++                                    4 -> do+                                        x <- Decoding.decodeString++                                        if x == "_"+                                            then die "Non-standard encoding of a ∀ expression"+                                            else return ()++                                        _A <- go++                                        _B <- go++                                        return (Pi x _A _B)++                                    _ -> do+                                        die ("Incorrect number of tokens used to encode a ∀ expression: " <> show len)++                            3 -> do+                                opcode <- Decoding.decodeWord++                                op <- case opcode of+                                    0  -> return BoolOr+                                    1  -> return BoolAnd+                                    2  -> return BoolEQ+                                    3  -> return BoolNE+                                    4  -> return NaturalPlus+                                    5  -> return NaturalTimes+                                    6  -> return TextAppend+                                    7  -> return ListAppend+                                    8  -> return Combine+                                    9  -> return Prefer+                                    10 -> return CombineTypes+                                    11 -> return ImportAlt+                                    12 -> return Equivalent+                                    13 -> return RecordCompletion+                                    _  -> die ("Unrecognized operator code: " <> show opcode)++                                l <- go++                                r <- go++                                return (op l r)++                            4 -> do+                                case len of+                                    2 -> do+                                        _T <- go++                                        return (ListLit (Just (App List _T)) empty)++                                    _ -> do+                                        Decoding.decodeNull++                                        xs <- Monad.replicateM (len - 2) go+                                        return (ListLit Nothing (Data.Sequence.fromList xs))++                            5 -> do+                                Decoding.decodeNull++                                t <- go++                                return (Some t)++                            6 -> do+                                t <- go++                                u <- go++                                case len of+                                    3 -> do+                                        return (Merge t u Nothing)++                                    4 -> do+                                        _T <- go++                                        return (Merge t u (Just _T))++                                    _ -> do+                                        die ("Incorrect number of tokens used to encode a `merge` expression: " <> show len)++                            7 -> do+                                mapLength <- Decoding.decodeMapLen++                                xTs <- Monad.replicateM mapLength $ do+                                    x <- Decoding.decodeString++                                    _T <- go++                                    return (x, _T)++                                return (Record (Dhall.Map.fromList xTs))++                            8 -> do+                                mapLength <- Decoding.decodeMapLen++                                xts <- Monad.replicateM mapLength $ do+                                    x <- Decoding.decodeString++                                    t <- go++                                    return (x, t)++                                return (RecordLit (Dhall.Map.fromList xts))++                            9 -> do+                                t <- go++                                x <- Decoding.decodeString++                                return (Field t x)++                            10 -> do+                                t <- go++                                xs <- case len of+                                    3 -> do+                                        tokenType₂ <- Decoding.peekTokenType++                                        case tokenType₂ of+                                            TypeListLen -> do+                                                _ <- Decoding.decodeListLen++                                                _T <- go++                                                return (Right _T)++                                            TypeString -> do+                                                x <- Decoding.decodeString+                                                return (Left (Dhall.Set.fromList [x]))++                                            _ -> do+                                                die ("Unexpected token type for projection: " <> show tokenType₂)++                                    _ -> do+                                        xs <- Monad.replicateM (len - 2) Decoding.decodeString++                                        return (Left (Dhall.Set.fromList xs))++                                return (Project t xs)++                            11 -> do+                                mapLength <- Decoding.decodeMapLen++                                xTs <- Monad.replicateM mapLength $ do+                                    x <- Decoding.decodeString++                                    tokenType₂ <- Decoding.peekTokenType++                                    mT <- case tokenType₂ of+                                        TypeNull -> do+                                            Decoding.decodeNull++                                            return Nothing++                                        _ -> do+                                            _T <- go++                                            return (Just _T)++                                    return (x, mT)++                                return (Union (Dhall.Map.fromList xTs))++                            14 -> do+                                t <- go++                                l <- go++                                r <- go++                                return (BoolIf t l r)++                            15 -> do+                                tokenType₂ <- Decoding.peekTokenType++                                case tokenType₂ of+                                    TypeUInt -> do+                                        n <- Decoding.decodeWord++                                        return (NaturalLit (fromIntegral n))++                                    TypeUInt64 -> do+                                        n <- Decoding.decodeWord64++                                        return (NaturalLit (fromIntegral n))++                                    TypeInteger -> do+                                        n <- Decoding.decodeInteger+                                        return (NaturalLit (fromIntegral n))++                                    _ -> do+                                        die ("Unexpected token type for Natural literal: " <> show tokenType₂)++                            16 -> do+                                tokenType₂ <- Decoding.peekTokenType++                                case tokenType₂ of+                                    TypeUInt -> do+                                        n <- Decoding.decodeWord++                                        return (IntegerLit (fromIntegral n))++                                    TypeUInt64 -> do+                                        n <- Decoding.decodeWord64++                                        return (IntegerLit (fromIntegral n))++                                    TypeNInt -> do+                                        n <- Decoding.decodeNegWord++                                        return (IntegerLit (-1 - fromIntegral n))++                                    TypeNInt64 -> do+                                        n <- Decoding.decodeNegWord64++                                        return (IntegerLit (-1 - fromIntegral n))+                                    TypeInteger -> do+                                        n <- Decoding.decodeInteger+                                        return (IntegerLit n)++                                    _ -> do+                                        die ("Unexpected token type for Integer literal: " <> show tokenType₂)++                            18 -> do+                                xys <- Monad.replicateM ((len - 2) `quot` 2) $ do+                                    x <- Decoding.decodeString++                                    y <- go++                                    return (x, y)++                                z <- Decoding.decodeString++                                return (TextLit (Chunks xys z))++                            19 -> do+                                t <- go++                                return (Assert t)++                            24 -> do+                                fmap Embed (decodeEmbed len)++                            25 -> do+                                bindings <- Monad.replicateM ((len - 2) `quot` 3) $ do+                                    x <- Decoding.decodeString++                                    tokenType₂ <- Decoding.peekTokenType++                                    mA <- case tokenType₂ of+                                        TypeNull -> do+                                            Decoding.decodeNull++                                            return Nothing++                                        _ -> do+                                            _A <- go++                                            return (Just (Nothing, _A))++                                    a <- go++                                    return (Binding Nothing x Nothing mA Nothing a)++                                b <- go++                                return (foldr Let b bindings)++                            26 -> do+                                t <- go++                                _T <- go++                                return (Annot t _T)++                            27 -> do+                                t <- go++                                mT <- case len of+                                    2 -> do+                                        return Nothing++                                    3 -> do+                                        _T <- go++                                        return (Just _T)++                                    _ -> do+                                        die ("Incorrect number of tokens used to encode a type annotation: " <> show len)++                                return (ToMap t mT)++                            28 -> do+                                _T <- go++                                return (ListLit (Just _T) empty)++                            _ -> do+                                die ("Unexpected tag: " <> show tag)++                    _ -> do+                        die ("Unexpected tag type: " <> show tokenType₁)++            _ -> do+                die ("Unexpected initial token: " <> show tokenType₀)++encodeExpressionInternal :: (a -> Encoding) -> Expr Void a -> Encoding+encodeExpressionInternal encodeEmbed = go+  where+    go e = case e of+        Var (V "_" n) ->+            Encoding.encodeInt n++        Var (V x n) ->+                Encoding.encodeListLen 2+            <>  Encoding.encodeString x+            <>  Encoding.encodeInt n++        NaturalBuild ->+            Encoding.encodeString "Natural/build"++        NaturalFold ->+            Encoding.encodeString "Natural/fold"++        NaturalIsZero ->+            Encoding.encodeString "Natural/isZero"++        NaturalEven ->+            Encoding.encodeString "Natural/even"++        NaturalOdd ->+            Encoding.encodeString "Natural/odd"++        NaturalToInteger ->+            Encoding.encodeString "Natural/toInteger"++        NaturalShow ->+            Encoding.encodeString "Natural/show"++        NaturalSubtract ->+            Encoding.encodeString "Natural/subtract"++        IntegerToDouble ->+            Encoding.encodeString "Integer/toDouble"++        IntegerClamp ->+            Encoding.encodeString "Integer/clamp"++        IntegerNegate ->+            Encoding.encodeString "Integer/negate"++        IntegerShow ->+            Encoding.encodeString "Integer/show"++        DoubleShow ->+            Encoding.encodeString "Double/show"++        ListBuild ->+            Encoding.encodeString "List/build"++        ListFold ->+            Encoding.encodeString "List/fold"++        ListLength ->+            Encoding.encodeString "List/length"++        ListHead ->+            Encoding.encodeString "List/head"++        ListLast ->+            Encoding.encodeString "List/last"++        ListIndexed ->+            Encoding.encodeString "List/indexed"++        ListReverse ->+            Encoding.encodeString "List/reverse"++        OptionalFold ->+            Encoding.encodeString "Optional/fold"++        OptionalBuild ->+            Encoding.encodeString "Optional/build"++        Bool ->+            Encoding.encodeString "Bool"++        Optional ->+            Encoding.encodeString "Optional"++        None ->+            Encoding.encodeString "None"++        Natural ->+            Encoding.encodeString "Natural"++        Integer ->+            Encoding.encodeString "Integer"++        Double ->+            Encoding.encodeString "Double"++        Text ->+            Encoding.encodeString "Text"++        TextShow ->+            Encoding.encodeString "Text/show"++        List ->+            Encoding.encodeString "List"++        Const Type ->+            Encoding.encodeString "Type"++        Const Kind ->+            Encoding.encodeString "Kind"++        Const Sort ->+            Encoding.encodeString "Sort"++        a@App{} ->+            encodeListN+                (2 + length arguments)+                ( Encoding.encodeInt 0+                : go function+                : map go arguments+                )+          where+            (function, arguments) = unApply a++        Lam "_" _A b ->+            encodeList3+                (Encoding.encodeInt 1)+                (go _A)+                (go b)++        Lam x _A b ->+            encodeList4+                (Encoding.encodeInt 1)+                (Encoding.encodeString x)+                (go _A)+                (go b)++        Pi "_" _A _B ->+            encodeList3+                (Encoding.encodeInt 2)+                (go _A)+                (go _B)++        Pi x _A _B ->+            encodeList4+                (Encoding.encodeInt 2)+                (Encoding.encodeString x)+                (go _A)+                (go _B)++        BoolOr l r ->+            encodeOperator 0 l r++        BoolAnd l r ->+            encodeOperator 1 l r++        BoolEQ l r ->+            encodeOperator 2 l r++        BoolNE l r ->+            encodeOperator 3 l r++        NaturalPlus l r ->+            encodeOperator 4 l r++        NaturalTimes l r ->+            encodeOperator 5 l r++        TextAppend l r ->+            encodeOperator 6 l r++        ListAppend l r ->+            encodeOperator 7 l r++        Combine l r ->+            encodeOperator 8 l r++        Prefer l r ->+            encodeOperator 9 l r++        CombineTypes l r ->+            encodeOperator 10 l r++        ImportAlt l r ->+            encodeOperator 11 l r++        Equivalent l r ->+            encodeOperator 12 l r++        RecordCompletion l r ->+            encodeOperator 13 l r++        ListLit _T₀ xs+            | null xs ->+                encodeList2 (Encoding.encodeInt label) _T₁+            | otherwise ->+                encodeListN+                    (2 + length xs)+                    ( Encoding.encodeInt 4+                    : Encoding.encodeNull+                    : map go (Data.Foldable.toList xs)+                    )+          where+            (label, _T₁) = case _T₀ of+                Nothing           -> (4 , Encoding.encodeNull)+                Just (App List t) -> (4 , go t               )+                Just  t           -> (28, go t               )++        Some t ->+            encodeList3+                (Encoding.encodeInt 5)+                Encoding.encodeNull+                (go t)++        Merge t u Nothing ->+            encodeList3+                (Encoding.encodeInt 6)+                (go t)+                (go u)++        Merge t u (Just _T) ->+            encodeList4+                (Encoding.encodeInt 6)+                (go t)+                (go u)+                (go _T)++        Record xTs ->+            encodeList2+                (Encoding.encodeInt 7)+                (encodeMapWith go xTs)++        RecordLit xts ->+            encodeList2+                (Encoding.encodeInt 8)+                (encodeMapWith go xts)++        Field t x ->+            encodeList3+                (Encoding.encodeInt 9)+                (go t)+                (Encoding.encodeString x)++        Project t (Left xs) ->+            encodeListN+                (2 + Dhall.Set.size xs)+                ( Encoding.encodeInt 10+                : go t+                : map Encoding.encodeString (Dhall.Set.toList xs)+                )++        Project t (Right _T) ->+            encodeList3+                (Encoding.encodeInt 10)+                (go t)+                (encodeList1 (go _T))++        Union xTs ->+            encodeList2+                (Encoding.encodeInt 11)+                (encodeMapWith encodeValue xTs)+          where+            encodeValue  Nothing  = Encoding.encodeNull+            encodeValue (Just _T) = go _T++        BoolLit b ->+            Encoding.encodeBool b++        BoolIf t l r ->+            encodeList4+                (Encoding.encodeInt 14)+                (go t)+                (go l)+                (go r)++        NaturalLit n ->+            encodeList2+                (Encoding.encodeInt 15)+                (Encoding.encodeInteger (fromIntegral n))++        IntegerLit n ->+            encodeList2+                (Encoding.encodeInt 16)+                (Encoding.encodeInteger (fromIntegral n))++        DoubleLit (DhallDouble n64)+            | useHalf   -> Encoding.encodeFloat16 n32+            | useFloat  -> Encoding.encodeFloat n32+            | otherwise -> Encoding.encodeDouble n64+          where+            n32 = double2Float n64++            useFloat = n64 == float2Double n32++            useHalf = n64 == 0.0 || n64 == infinity || n64 == -infinity++            infinity = 1/0 :: Double++        -- Fast path for the common case of an uninterpolated string+        TextLit (Chunks [] z) ->+            encodeList2+                (Encoding.encodeInt 18)+                (Encoding.encodeString z)++        TextLit (Chunks xys z) ->+            encodeListN+                (2 + 2 * length xys)+                ( Encoding.encodeInt 18+                : concatMap encodePair xys ++ [ Encoding.encodeString z ]+                )+          where+            encodePair (x, y) = [ Encoding.encodeString x, go y ]++        Assert t ->+            encodeList2+                (Encoding.encodeInt 19)+                (go t)++        Embed x ->+            encodeEmbed x++        Let a₀ b₀ ->+            encodeListN+                (2 + 3 * length as)+                ( Encoding.encodeInt 25+                : concatMap encodeBinding (toList as) ++ [ go b₁ ]+                )+          where+            MultiLet as b₁ = Dhall.Syntax.multiLet a₀ b₀++            encodeBinding (Binding _ x _ mA₀ _ a) =+                [ Encoding.encodeString x+                , mA₁+                , go a+                ]+              where+                mA₁ = case mA₀ of+                    Nothing      -> Encoding.encodeNull+                    Just (_, _A) -> go _A++        Annot t _T ->+            encodeList3+                (Encoding.encodeInt 26)+                (go t)+                (go _T)++        ToMap t Nothing ->+            encodeList2+                (Encoding.encodeInt 27)+                (go t)++        ToMap t (Just _T) ->+            encodeList3+                (Encoding.encodeInt 27)+                (go t)+                (go _T)++        Note _ b ->+            go b++    encodeOperator n l r =+        encodeList4+            (Encoding.encodeInt 3)+            (Encoding.encodeInt n)+            (go l)+            (go r)++    encodeMapWith encodeValue m =+            Encoding.encodeMapLen (fromIntegral (Dhall.Map.size m))+        <>  foldMap encodeKeyValue (Dhall.Map.toList (Dhall.Map.sort m))+      where+        encodeKeyValue (k, v) = Encoding.encodeString k <> encodeValue v++encodeList1 :: Encoding -> Encoding+encodeList1 a = Encoding.encodeListLen 1 <> a+{-# INLINE encodeList1 #-}++encodeList2 :: Encoding -> Encoding -> Encoding+encodeList2 a b = Encoding.encodeListLen 2 <> a <> b+{-# INLINE encodeList2 #-}++encodeList3 :: Encoding -> Encoding -> Encoding -> Encoding+encodeList3 a b c = Encoding.encodeListLen 3 <> a <> b <> c+{-# INLINE encodeList3 #-}++encodeList4 :: Encoding -> Encoding -> Encoding -> Encoding -> Encoding+encodeList4 a b c d = Encoding.encodeListLen 4 <> a <> b <> c <> d+{-# INLINE encodeList4 #-}++encodeListN :: Int -> [ Encoding ] -> Encoding+encodeListN len xs = Encoding.encodeListLen (fromIntegral len) <> mconcat xs+{-# INLINE encodeListN #-}++encodeList :: [ Encoding ] -> Encoding+encodeList xs = encodeListN (length xs) xs+{-# INLINE encodeList #-}++decodeImport :: Int -> Decoder s Import+decodeImport len = do+    let die message = fail ("Dhall.Binary.decodeImport: " <> message)++    tokenType₀ <- Decoding.peekTokenType++    hash <- case tokenType₀ of+        TypeNull -> do+            Decoding.decodeNull++            return Nothing++        TypeBytes -> do+            bytes <- Decoding.decodeBytes++            let (prefix, suffix) = Data.ByteString.splitAt 2 bytes++            case prefix of+                "\x12\x20" -> return ()+                _          -> die ("Unrecognized multihash prefix: " <> show prefix)+            case Dhall.Crypto.sha256DigestFromByteString suffix of+                Nothing     -> die ("Invalid sha256 digest: " <> show bytes)+                Just digest -> return (Just digest)++        _ -> do+            die ("Unexpected hash token: " <> show tokenType₀)++    m <- Decoding.decodeWord++    importMode <- case m of+        0 -> return Code+        1 -> return RawText+        2 -> return Location+        _ -> die ("Unexpected code for import mode: " <> show m)++    let remote scheme = do+            tokenType₁ <- Decoding.peekTokenType++            headers <- case tokenType₁ of+                TypeNull -> do+                    Decoding.decodeNull+                    return Nothing++                _ -> do+                    headers <- decodeExpressionInternal decodeImport++                    return (Just headers)++            authority <- Decoding.decodeString++            paths <- Monad.replicateM (len - 8) Decoding.decodeString++            file <- Decoding.decodeString++            tokenType₂ <- Decoding.peekTokenType++            query <- case tokenType₂ of+                TypeNull -> do+                    Decoding.decodeNull+                    return Nothing+                _ -> do+                    fmap Just Decoding.decodeString++            let components = reverse paths+            let directory  = Directory {..}+            let path       = File {..}++            return (Remote (URL {..}))++    let local prefix = do+            paths <- Monad.replicateM (len - 5) Decoding.decodeString++            file <- Decoding.decodeString++            let components = reverse paths+            let directory  = Directory {..}++            return (Local prefix (File {..}))++    let missing = return Missing++    let env = do+            x <- Decoding.decodeString++            return (Env x)++    n <- Decoding.decodeWord++    importType <- case n of+        0 -> remote HTTP+        1 -> remote HTTPS+        2 -> local Absolute+        3 -> local Here+        4 -> local Parent+        5 -> local Home+        6 -> env+        7 -> missing+        _ -> fail ("Unrecognized import type code: " <> show n)++    let importHashed = ImportHashed {..}++    return (Import {..})++encodeImport :: Import -> Encoding+encodeImport import_ =+    case importType of+        Remote (URL { scheme = scheme₀, .. }) ->+            encodeList+                (   prefix+                ++  [ Encoding.encodeInt scheme₁+                    , using+                    , Encoding.encodeString authority+                    ]+                ++  map Encoding.encodeString (reverse components)+                ++  [ Encoding.encodeString file ]+                ++  [ case query of+                         Nothing -> Encoding.encodeNull+                         Just q  -> Encoding.encodeString q+                    ]+                )+          where+            using = case headers of+                Nothing ->+                    Encoding.encodeNull+                Just h ->+                    encodeExpressionInternal encodeImport (Dhall.Syntax.denote h)++            scheme₁ = case scheme₀ of+                HTTP  -> 0+                HTTPS -> 1++            File{..} = path++            Directory {..} = directory++        Local prefix₀ path ->+            encodeList+                (   prefix+                ++  [ Encoding.encodeInt prefix₁ ]+                ++  map Encoding.encodeString components₁+                ++  [ Encoding.encodeString file ]+                )+          where+            File{..} = path++            Directory{..} = directory++            prefix₁ = case prefix₀ of+                Absolute -> 2+                Here     -> 3+                Parent   -> 4+                Home     -> 5++            components₁ = reverse components++        Env x ->+            encodeList+                (prefix ++ [ Encoding.encodeInt 6, Encoding.encodeString x ])++        Missing ->+            encodeList (prefix ++ [ Encoding.encodeInt 7 ])+  where+    prefix = [ Encoding.encodeInt 24, h, m ]+      where+        h = case hash of+            Nothing ->+                Encoding.encodeNull++            Just digest ->+                Encoding.encodeBytes ("\x12\x20" <> Data.ByteArray.convert digest)++        m = Encoding.encodeInt (case importMode of Code -> 0; RawText -> 1; Location -> 2;)++    Import{..} = import_++    ImportHashed{..} = importHashed++decodeVoid :: Int -> Decoder s Void+decodeVoid _ = fail "Dhall.Binary.decodeVoid: Cannot decode an uninhabited type"++encodeVoid :: Void -> Encoding+encodeVoid = absurd++instance Serialise (Expr Void Void) where+    encode = encodeExpressionInternal encodeVoid++    decode = decodeExpressionInternal decodeVoid++instance Serialise (Expr Void Import) where+    encode = encodeExpressionInternal encodeImport++    decode = decodeExpressionInternal decodeImport++-- | Encode a Dhall expression as a CBOR-encoded `ByteString`+encodeExpression :: Expr Void Import -> ByteString+encodeExpression = Serialise.serialise++-- | Decode a Dhall expression from a CBOR `Term`+decodeExpression+    :: Serialise (Expr s a) => ByteString -> Either DecodingFailure (Expr s a)+decodeExpression bytes =+    case decodeWithoutVersion <|> decodeWithVersion of+        Just expression -> Right expression+        Nothing         -> Left (CBORIsNotDhall bytes)+  where+    adapt (Right ("", x)) = Just x+    adapt  _              = Nothing++    decode' = decodeWith55799Tag decode++    -- This is the behavior specified by the standard+    decodeWithoutVersion = adapt (Read.deserialiseFromBytes decode' bytes)++    -- tag to ease the migration+    decodeWithVersion = adapt (Read.deserialiseFromBytes decodeWithTag bytes)+      where+        decodeWithTag = do+            2 <- Decoding.decodeListLen++            version <- Decoding.decodeString+++            -- "_" has never been a valid version string, and this ensures that+            -- we don't interpret `[ "_", 0 ]` as the expression `_` (encoded as+            -- `0`) tagged with a version string of `"_"`+            if (version == "_")+                then fail "Dhall.Binary.decodeExpression: \"_\" is not a valid version string"+                else return ()++            decode'++decodeWith55799Tag :: Decoder s a -> Decoder s a+decodeWith55799Tag decoder = do+    tokenType <- Decoding.peekTokenType++    case tokenType of+        TypeTag -> do+            w <- Decoding.decodeTag++            if w /= 55799+                then fail ("Dhall.Binary.decodeWith55799Tag: Unexpected tag: " <> show w)+                else return ()++            decoder+        _ -> do+            decoder++{-| This indicates that a given CBOR-encoded `ByteString` did not correspond to+    a valid Dhall expression+-}+newtype DecodingFailure = CBORIsNotDhall ByteString+    deriving (Eq)++instance Exception DecodingFailure++_ERROR :: String+_ERROR = "\ESC[1;31mError\ESC[0m"++instance Show DecodingFailure where+    show (CBORIsNotDhall bytes) =+            _ERROR <> ": Cannot decode CBOR to Dhall\n"+        <>  "\n"+        <>  "The following bytes do not encode a valid Dhall expression\n"+        <>  "\n"+        <>  "↳ 0x" <> concatMap toHex (Data.ByteString.Lazy.unpack bytes) <> "\n"+      where+        toHex = Printf.printf "%02x "

src/Dhall/Core.hs view

@@ -1,1306 +1,89 @@-{-# LANGUAGE BangPatterns       #-}-{-# LANGUAGE LambdaCase         #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE RankNTypes         #-}-{-# LANGUAGE RecordWildCards    #-}--{-| This module contains the core calculus for the Dhall language.--    Dhall is essentially a fork of the @morte@ compiler but with more built-in-    functionality, better error messages, and Haskell integration--}--module Dhall.Core (-    -- * Syntax-      Const(..)-    , Directory(..)-    , File(..)-    , FilePrefix(..)-    , Import(..)-    , ImportHashed(..)-    , ImportMode(..)-    , ImportType(..)-    , URL(..)-    , Scheme(..)-    , DhallDouble(..)-    , Var(..)-    , Binding(..)-    , makeBinding-    , Chunks(..)-    , Expr(..)--    -- * Normalization-    , alphaNormalize-    , normalize-    , normalizeWith-    , normalizeWithM-    , Normalizer-    , NormalizerM-    , ReifiedNormalizer (..)-    , judgmentallyEqual-    , subst-    , shift-    , isNormalized-    , isNormalizedWith-    , denote-    , renote-    , shallowDenote-    , freeIn--    -- * Pretty-printing-    , pretty--    -- * Optics-    , subExpressions-    , chunkExprs-    , bindingExprs--    -- * Let-blocks-    , multiLet-    , wrapInLets-    , MultiLet(..)--    -- * Miscellaneous-    , internalError-    , reservedIdentifiers-    , escapeText-    , pathCharacter-    , throws-    , Eval.textShow-    , censorExpression-    , censorText-    ) where--import Control.Applicative (empty)-import Control.Exception (Exception)-import Control.Monad.IO.Class (MonadIO(..))-import Data.Foldable-import Data.Functor.Identity (Identity(..))-import Data.Semigroup (Semigroup(..))-import Data.Sequence (ViewL(..), ViewR(..))-import Data.Text (Text)-import Data.Text.Prettyprint.Doc (Pretty)-import Data.Traversable-import Dhall.Src (Src(..))-import Dhall.Syntax-import Dhall.Pretty.Internal-import Instances.TH.Lift ()-import Lens.Family (over)-import Prelude hiding (succ)--import qualified Control.Exception-import qualified Dhall.Eval    as Eval-import qualified Data.Sequence-import qualified Data.Set-import qualified Data.Text-import qualified Dhall.Map-import qualified Dhall.Set--{-| Returns `True` if two expressions are α-equivalent and β-equivalent and-    `False` otherwise--    `judgmentallyEqual` can fail with an `error` if you compare ill-typed-    expressions--}-judgmentallyEqual :: Eq a => Expr s a -> Expr t a -> Bool-judgmentallyEqual = Eval.judgmentallyEqual-{-# INLINE judgmentallyEqual #-}--{-| `shift` is used by both normalization and type-checking to avoid variable-    capture by shifting variable indices--    For example, suppose that you were to normalize the following expression:--> λ(a : Type) → λ(x : a) → (λ(y : a) → λ(x : a) → y) x--    If you were to substitute @y@ with @x@ without shifting any variable-    indices, then you would get the following incorrect result:--> λ(a : Type) → λ(x : a) → λ(x : a) → x  -- Incorrect normalized form--    In order to substitute @x@ in place of @y@ we need to `shift` @x@ by @1@ in-    order to avoid being misinterpreted as the @x@ bound by the innermost-    lambda.  If we perform that `shift` then we get the correct result:--> λ(a : Type) → λ(x : a) → λ(x : a) → x@1--    As a more worked example, suppose that you were to normalize the following-    expression:-->     λ(a : Type)-> →   λ(f : a → a → a)-> →   λ(x : a)-> →   λ(x : a)-> →   (λ(x : a) → f x x@1) x@1--    The correct normalized result would be:-->     λ(a : Type)-> →   λ(f : a → a → a)-> →   λ(x : a)-> →   λ(x : a)-> →   f x@1 x--    The above example illustrates how we need to both increase and decrease-    variable indices as part of substitution:--    * We need to increase the index of the outer @x\@1@ to @x\@2@ before we-      substitute it into the body of the innermost lambda expression in order-      to avoid variable capture.  This substitution changes the body of the-      lambda expression to @(f x\@2 x\@1)@--    * We then remove the innermost lambda and therefore decrease the indices of-      both @x@s in @(f x\@2 x\@1)@ to @(f x\@1 x)@ in order to reflect that one-      less @x@ variable is now bound within that scope--    Formally, @(shift d (V x n) e)@ modifies the expression @e@ by adding @d@ to-    the indices of all variables named @x@ whose indices are greater than-    @(n + m)@, where @m@ is the number of bound variables of the same name-    within that scope--    In practice, @d@ is always @1@ or @-1@ because we either:--    * increment variables by @1@ to avoid variable capture during substitution-    * decrement variables by @1@ when deleting lambdas after substitution--    @n@ starts off at @0@ when substitution begins and increments every time we-    descend into a lambda or let expression that binds a variable of the same-    name in order to avoid shifting the bound variables by mistake.--}-shift :: Int -> Var -> Expr s a -> Expr s a-shift _ _ (Const a) = Const a-shift d (V x n) (Var (V x' n')) = Var (V x' n'')-  where-    n'' = if x == x' && n <= n' then n' + d else n'-shift d (V x n) (Lam x' _A b) = Lam x' _A' b'-  where-    _A' = shift d (V x n ) _A-    b'  = shift d (V x n') b-      where-        n' = if x == x' then n + 1 else n-shift d (V x n) (Pi x' _A _B) = Pi x' _A' _B'-  where-    _A' = shift d (V x n ) _A-    _B' = shift d (V x n') _B-      where-        n' = if x == x' then n + 1 else n-shift d v (App f a) = App f' a'-  where-    f' = shift d v f-    a' = shift d v a-shift d (V x n) (Let (Binding src0 f src1 mt src2 r) e) =-    Let (Binding src0 f src1 mt' src2 r') e'-  where-    e' = shift d (V x n') e-      where-        n' = if x == f then n + 1 else n--    mt' = fmap (fmap (shift d (V x n))) mt-    r'  =             shift d (V x n)  r-shift d v (Annot a b) = Annot a' b'-  where-    a' = shift d v a-    b' = shift d v b-shift _ _ Bool = Bool-shift _ _ (BoolLit a) = BoolLit a-shift d v (BoolAnd a b) = BoolAnd a' b'-  where-    a' = shift d v a-    b' = shift d v b-shift d v (BoolOr a b) = BoolOr a' b'-  where-    a' = shift d v a-    b' = shift d v b-shift d v (BoolEQ a b) = BoolEQ a' b'-  where-    a' = shift d v a-    b' = shift d v b-shift d v (BoolNE a b) = BoolNE a' b'-  where-    a' = shift d v a-    b' = shift d v b-shift d v (BoolIf a b c) = BoolIf a' b' c'-  where-    a' = shift d v a-    b' = shift d v b-    c' = shift d v c-shift _ _ Natural = Natural-shift _ _ (NaturalLit a) = NaturalLit a-shift _ _ NaturalFold = NaturalFold-shift _ _ NaturalBuild = NaturalBuild-shift _ _ NaturalIsZero = NaturalIsZero-shift _ _ NaturalEven = NaturalEven-shift _ _ NaturalOdd = NaturalOdd-shift _ _ NaturalToInteger = NaturalToInteger-shift _ _ NaturalShow = NaturalShow-shift _ _ NaturalSubtract = NaturalSubtract-shift d v (NaturalPlus a b) = NaturalPlus a' b'-  where-    a' = shift d v a-    b' = shift d v b-shift d v (NaturalTimes a b) = NaturalTimes a' b'-  where-    a' = shift d v a-    b' = shift d v b-shift _ _ Integer = Integer-shift _ _ (IntegerLit a) = IntegerLit a-shift _ _ IntegerShow = IntegerShow-shift _ _ IntegerToDouble = IntegerToDouble-shift _ _ Double = Double-shift _ _ (DoubleLit a) = DoubleLit a-shift _ _ DoubleShow = DoubleShow-shift _ _ Text = Text-shift d v (TextLit (Chunks a b)) = TextLit (Chunks a' b)-  where-    a' = fmap (fmap (shift d v)) a-shift d v (TextAppend a b) = TextAppend a' b'-  where-    a' = shift d v a-    b' = shift d v b-shift _ _ TextShow = TextShow-shift _ _ List = List-shift d v (ListLit a b) = ListLit a' b'-  where-    a' = fmap (shift d v) a-    b' = fmap (shift d v) b-shift _ _ ListBuild = ListBuild-shift d v (ListAppend a b) = ListAppend a' b'-  where-    a' = shift d v a-    b' = shift d v b-shift _ _ ListFold = ListFold-shift _ _ ListLength = ListLength-shift _ _ ListHead = ListHead-shift _ _ ListLast = ListLast-shift _ _ ListIndexed = ListIndexed-shift _ _ ListReverse = ListReverse-shift _ _ Optional = Optional-shift d v (Some a) = Some a'-  where-    a' = shift d v a-shift _ _ None = None-shift _ _ OptionalFold = OptionalFold-shift _ _ OptionalBuild = OptionalBuild-shift d v (Record a) = Record a'-  where-    a' = fmap (shift d v) a-shift d v (RecordLit a) = RecordLit a'-  where-    a' = fmap (shift d v) a-shift d v (Union a) = Union a'-  where-    a' = fmap (fmap (shift d v)) a-shift d v (Combine a b) = Combine a' b'-  where-    a' = shift d v a-    b' = shift d v b-shift d v (CombineTypes a b) = CombineTypes a' b'-  where-    a' = shift d v a-    b' = shift d v b-shift d v (Prefer a b) = Prefer a' b'-  where-    a' = shift d v a-    b' = shift d v b-shift d v (RecordCompletion a b) = RecordCompletion a' b'-  where-    a' = shift d v a-    b' = shift d v b-shift d v (Merge a b c) = Merge a' b' c'-  where-    a' =       shift d v  a-    b' =       shift d v  b-    c' = fmap (shift d v) c-shift d v (ToMap a b) = ToMap a' b'-  where-    a' =       shift d v  a-    b' = fmap (shift d v) b-shift d v (Field a b) = Field a' b-  where-    a' = shift d v a-shift d v (Assert a) = Assert a'-  where-    a' = shift d v a-shift d v (Equivalent a b) = Equivalent a' b'-  where-    a' = shift d v a-    b' = shift d v b-shift d v (Project a b) = Project a' b'-  where-    a' =       shift d v  a-    b' = fmap (shift d v) b-shift d v (Note a b) = Note a b'-  where-    b' = shift d v b-shift d v (ImportAlt a b) = ImportAlt a' b'-  where-    a' = shift d v a-    b' = shift d v b--- The Dhall compiler enforces that all embedded values are closed expressions--- and `shift` does nothing to a closed expression-shift _ _ (Embed p) = Embed p--{-| Substitute all occurrences of a variable with an expression--> subst x C B  ~  B[x := C]--}-subst :: Var -> Expr s a -> Expr s a -> Expr s a-subst _ _ (Const a) = Const a-subst (V x n) e (Lam y _A b) = Lam y _A' b'-  where-    _A' = subst (V x n )                  e  _A-    b'  = subst (V x n') (shift 1 (V y 0) e)  b-    n'  = if x == y then n + 1 else n-subst (V x n) e (Pi y _A _B) = Pi y _A' _B'-  where-    _A' = subst (V x n )                  e  _A-    _B' = subst (V x n') (shift 1 (V y 0) e) _B-    n'  = if x == y then n + 1 else n-subst v e (App f a) = App f' a'-  where-    f' = subst v e f-    a' = subst v e a-subst v e (Var v') = if v == v' then e else Var v'-subst (V x n) e (Let (Binding src0 f src1 mt src2 r) b) =-    Let (Binding src0 f src1 mt' src2 r') b'-  where-    b' = subst (V x n') (shift 1 (V f 0) e) b-      where-        n' = if x == f then n + 1 else n--    mt' = fmap (fmap (subst (V x n) e)) mt-    r'  =             subst (V x n) e  r-subst x e (Annot a b) = Annot a' b'-  where-    a' = subst x e a-    b' = subst x e b-subst _ _ Bool = Bool-subst _ _ (BoolLit a) = BoolLit a-subst x e (BoolAnd a b) = BoolAnd a' b'-  where-    a' = subst x e a-    b' = subst x e b-subst x e (BoolOr a b) = BoolOr a' b'-  where-    a' = subst x e a-    b' = subst x e b-subst x e (BoolEQ a b) = BoolEQ a' b'-  where-    a' = subst x e a-    b' = subst x e b-subst x e (BoolNE a b) = BoolNE a' b'-  where-    a' = subst x e a-    b' = subst x e b-subst x e (BoolIf a b c) = BoolIf a' b' c'-  where-    a' = subst x e a-    b' = subst x e b-    c' = subst x e c-subst _ _ Natural = Natural-subst _ _ (NaturalLit a) = NaturalLit a-subst _ _ NaturalFold = NaturalFold-subst _ _ NaturalBuild = NaturalBuild-subst _ _ NaturalIsZero = NaturalIsZero-subst _ _ NaturalEven = NaturalEven-subst _ _ NaturalOdd = NaturalOdd-subst _ _ NaturalToInteger = NaturalToInteger-subst _ _ NaturalShow = NaturalShow-subst _ _ NaturalSubtract = NaturalSubtract-subst x e (NaturalPlus a b) = NaturalPlus a' b'-  where-    a' = subst x e a-    b' = subst x e b-subst x e (NaturalTimes a b) = NaturalTimes a' b'-  where-    a' = subst x e a-    b' = subst x e b-subst _ _ Integer = Integer-subst _ _ (IntegerLit a) = IntegerLit a-subst _ _ IntegerShow = IntegerShow-subst _ _ IntegerToDouble = IntegerToDouble-subst _ _ Double = Double-subst _ _ (DoubleLit a) = DoubleLit a-subst _ _ DoubleShow = DoubleShow-subst _ _ Text = Text-subst x e (TextLit (Chunks a b)) = TextLit (Chunks a' b)-  where-    a' = fmap (fmap (subst x e)) a-subst x e (TextAppend a b) = TextAppend a' b'-  where-    a' = subst x e a-    b' = subst x e b-subst _ _ TextShow = TextShow-subst _ _ List = List-subst x e (ListLit a b) = ListLit a' b'-  where-    a' = fmap (subst x e) a-    b' = fmap (subst x e) b-subst x e (ListAppend a b) = ListAppend a' b'-  where-    a' = subst x e a-    b' = subst x e b-subst _ _ ListBuild = ListBuild-subst _ _ ListFold = ListFold-subst _ _ ListLength = ListLength-subst _ _ ListHead = ListHead-subst _ _ ListLast = ListLast-subst _ _ ListIndexed = ListIndexed-subst _ _ ListReverse = ListReverse-subst _ _ Optional = Optional-subst x e (Some a) = Some a'-  where-    a' = subst x e a-subst _ _ None = None-subst _ _ OptionalFold = OptionalFold-subst _ _ OptionalBuild = OptionalBuild-subst x e (Record kts) = Record kts'-  where-    kts' = fmap (subst x e) kts-subst x e (RecordLit kvs) = RecordLit kvs'-  where-    kvs' = fmap (subst x e) kvs-subst x e (Union kts) = Union kts'-  where-    kts' = fmap (fmap (subst x e)) kts-subst x e (Combine a b) = Combine a' b'-  where-    a' = subst x e a-    b' = subst x e b-subst x e (CombineTypes a b) = CombineTypes a' b'-  where-    a' = subst x e a-    b' = subst x e b-subst x e (Prefer a b) = Prefer a' b'-  where-    a' = subst x e a-    b' = subst x e b-subst x e (RecordCompletion a b) = RecordCompletion a' b'-  where-    a' = subst x e a-    b' = subst x e b-subst x e (Merge a b c) = Merge a' b' c'-  where-    a' =       subst x e  a-    b' =       subst x e  b-    c' = fmap (subst x e) c-subst x e (ToMap a b) = ToMap a' b'-  where-    a' =       subst x e  a-    b' = fmap (subst x e) b-subst x e (Field a b) = Field a' b-  where-    a' = subst x e a-subst x e (Project a b) = Project a' b'-  where-    a' =       subst x e  a-    b' = fmap (subst x e) b-subst x e (Assert a) = Assert a'-  where-    a' = subst x e a-subst x e (Equivalent a b) = Equivalent a' b'-  where-    a' = subst x e a-    b' = subst x e b-subst x e (Note a b) = Note a b'-  where-    b' = subst x e b-subst x e (ImportAlt a b) = ImportAlt a' b'-  where-    a' = subst x e a-    b' = subst x e b--- The Dhall compiler enforces that all embedded values are closed expressions--- and `subst` does nothing to a closed expression-subst _ _ (Embed p) = Embed p--{-| This function is used to determine whether folds like @Natural/fold@ or-    @List/fold@ should be lazy or strict in their accumulator based on the type-    of the accumulator--    If this function returns `True`, then they will be strict in their-    accumulator since we can guarantee an upper bound on the amount of work to-    normalize the accumulator on each step of the loop.  If this function-    returns `False` then they will be lazy in their accumulator and only-    normalize the final result at the end of the fold--}-boundedType :: Expr s a -> Bool-boundedType Bool             = True-boundedType Natural          = True-boundedType Integer          = True-boundedType Double           = True-boundedType Text             = True-boundedType (App List _)     = False-boundedType (App Optional t) = boundedType t-boundedType (Record kvs)     = all boundedType kvs-boundedType (Union kvs)      = all (all boundedType) kvs-boundedType _                = False--{-| α-normalize an expression by renaming all bound variables to @\"_\"@ and-    using De Bruijn indices to distinguish them-->>> alphaNormalize (Lam "a" (Const Type) (Lam "b" (Const Type) (Lam "x" "a" (Lam "y" "b" "x"))))-Lam "_" (Const Type) (Lam "_" (Const Type) (Lam "_" (Var (V "_" 1)) (Lam "_" (Var (V "_" 1)) (Var (V "_" 1)))))--    α-normalization does not affect free variables:-->>> alphaNormalize "x"-Var (V "x" 0)---}-alphaNormalize :: Expr s a -> Expr s a-alphaNormalize = Eval.alphaNormalize-{-# INLINE alphaNormalize #-}--{-| Reduce an expression to its normal form, performing beta reduction--    `normalize` does not type-check the expression.  You may want to type-check-    expressions before normalizing them since normalization can convert an-    ill-typed expression into a well-typed expression.--    `normalize` can also fail with `error` if you normalize an ill-typed-    expression--}-normalize :: Eq a => Expr s a -> Expr t a-normalize = Eval.normalize-{-# INLINE normalize #-}--{-| Reduce an expression to its normal form, performing beta reduction and applying-    any custom definitions.--    `normalizeWith` is designed to be used with function `typeWith`. The `typeWith`-    function allows typing of Dhall functions in a custom typing context whereas-    `normalizeWith` allows evaluating Dhall expressions in a custom context.--    To be more precise `normalizeWith` applies the given normalizer when it finds an-    application term that it cannot reduce by other means.--    Note that the context used in normalization will determine the properties of normalization.-    That is, if the functions in custom context are not total then the Dhall language, evaluated-    with those functions is not total either.--    `normalizeWith` can fail with an `error` if you normalize an ill-typed-    expression--}-normalizeWith :: Eq a => Maybe (ReifiedNormalizer a) -> Expr s a -> Expr t a-normalizeWith (Just ctx) t = runIdentity (normalizeWithM (getReifiedNormalizer ctx) t)-normalizeWith _          t = Eval.normalize t--{-| This function generalizes `normalizeWith` by allowing the custom normalizer-    to use an arbitrary `Monad`--    `normalizeWithM` can fail with an `error` if you normalize an ill-typed-    expression--}-normalizeWithM-    :: (Monad m, Eq a) => NormalizerM m a -> Expr s a -> m (Expr t a)-normalizeWithM ctx e0 = loop (denote e0)- where- loop e =  case e of-    Const k -> pure (Const k)-    Var v -> pure (Var v)-    Lam x _A b -> Lam x <$> _A' <*> b'-      where-        _A' = loop _A-        b'  = loop b-    Pi x _A _B -> Pi x <$> _A' <*> _B'-      where-        _A' = loop _A-        _B' = loop _B-    App f a -> do-      res <- ctx (App f a)-      case res of-          Just e1 -> loop e1-          Nothing -> do-              f' <- loop f-              a' <- loop a-              case f' of-                Lam x _A b₀ -> do--                    let a₂ = shift 1 (V x 0) a'-                    let b₁ = subst (V x 0) a₂ b₀-                    let b₂ = shift (-1) (V x 0) b₁--                    loop b₂-                _ -> do-                  case App f' a' of-                    -- build/fold fusion for `List`-                    App (App ListBuild _) (App (App ListFold _) e') -> loop e'--                    App NaturalFold (NaturalLit n) -> do-                        let natural = Var (V "natural" 0)-                        let go 0  x = x-                            go n' x = go (n'-1) (App (Var (V "succ" 0)) x)-                        let n' = go n (Var (V "zero" 0))-                        pure-                            (Lam "natural"-                                (Const Type)-                                (Lam "succ"-                                    (Pi "_" natural natural)-                                    (Lam "zero"-                                        natural-                                        n')))--                    -- build/fold fusion for `Natural`-                    App NaturalBuild (App NaturalFold e') -> loop e'--                    -- build/fold fusion for `Optional`-                    App (App OptionalBuild _) (App (App OptionalFold _) e') -> loop e'--                    App (App (App (App NaturalFold (NaturalLit n0)) t) succ') zero -> do-                      t' <- loop t-                      if boundedType t' then strict else lazy-                      where-                        strict =       strictLoop (fromIntegral n0 :: Integer)-                        lazy   = loop (  lazyLoop (fromIntegral n0 :: Integer))--                        strictLoop !0 = loop zero-                        strictLoop !n = App succ' <$> strictLoop (n - 1) >>= loop--                        lazyLoop !0 = zero-                        lazyLoop !n = App succ' (lazyLoop (n - 1))-                    App NaturalBuild g -> loop (App (App (App g Natural) succ) zero)-                      where-                        succ = Lam "n" Natural (NaturalPlus "n" (NaturalLit 1))--                        zero = NaturalLit 0-                    App NaturalIsZero (NaturalLit n) -> pure (BoolLit (n == 0))-                    App NaturalEven (NaturalLit n) -> pure (BoolLit (even n))-                    App NaturalOdd (NaturalLit n) -> pure (BoolLit (odd n))-                    App NaturalToInteger (NaturalLit n) -> pure (IntegerLit (toInteger n))-                    App NaturalShow (NaturalLit n) ->-                        pure (TextLit (Chunks [] (Data.Text.pack (show n))))-                    App (App NaturalSubtract (NaturalLit x)) (NaturalLit y)-                        | y >= x    -> pure (NaturalLit (subtract x y))-                        | otherwise -> pure (NaturalLit 0)-                    App (App NaturalSubtract (NaturalLit 0)) y -> pure y-                    App (App NaturalSubtract _) (NaturalLit 0) -> pure (NaturalLit 0)-                    App (App NaturalSubtract x) y | Eval.judgmentallyEqual x y -> pure (NaturalLit 0)-                    App IntegerShow (IntegerLit n)-                        | 0 <= n    -> pure (TextLit (Chunks [] ("+" <> Data.Text.pack (show n))))-                        | otherwise -> pure (TextLit (Chunks [] (Data.Text.pack (show n))))-                    -- `(read . show)` is used instead of `fromInteger` because `read` uses-                    -- the correct rounding rule.-                    -- See https://gitlab.haskell.org/ghc/ghc/issues/17231.-                    App IntegerToDouble (IntegerLit n) -> pure (DoubleLit ((DhallDouble . read . show) n))-                    App DoubleShow (DoubleLit (DhallDouble n)) ->-                        pure (TextLit (Chunks [] (Data.Text.pack (show n))))-                    App (App OptionalBuild _A₀) g ->-                        loop (App (App (App g optional) just) nothing)-                      where-                        optional = App Optional _A₀--                        just = Lam "a" _A₀ (Some "a")--                        nothing = App None _A₀-                    App (App ListBuild _A₀) g -> loop (App (App (App g list) cons) nil)-                      where-                        _A₁ = shift 1 "a" _A₀--                        list = App List _A₀--                        cons =-                            Lam "a" _A₀-                                (Lam "as"-                                    (App List _A₁)-                                    (ListAppend (ListLit Nothing (pure "a")) "as")-                                )--                        nil = ListLit (Just (App List _A₀)) empty-                    App (App ListFold t) (ListLit _ xs) -> do-                        t' <- loop t-                        let list = Var (V "list" 0)-                        let lam term =-                                Lam "list" (Const Type)-                                    (Lam "cons" (Pi "_" t' (Pi "_" list list))-                                        (Lam "nil" list term))-                        term <- foldrM-                            (\x acc -> do-                                x' <- loop x-                                pure (App (App (Var (V "cons" 0)) x') acc))-                            (Var (V "nil" 0))-                            xs-                        pure (lam term)-                    App (App (App (App (App ListFold _) (ListLit _ xs)) t) cons) nil -> do-                      t' <- loop t-                      if boundedType t' then strict else lazy-                      where-                        strict =       foldr strictCons strictNil xs-                        lazy   = loop (foldr   lazyCons   lazyNil xs)--                        strictNil = loop nil-                        lazyNil   =      nil--                        strictCons y ys = do-                          App (App cons y) <$> ys >>= loop-                        lazyCons   y ys =       App (App cons y) ys-                    App (App ListLength _) (ListLit _ ys) ->-                        pure (NaturalLit (fromIntegral (Data.Sequence.length ys)))-                    App (App ListHead t) (ListLit _ ys) -> loop o-                      where-                        o = case Data.Sequence.viewl ys of-                                y :< _ -> Some y-                                _      -> App None t-                    App (App ListLast t) (ListLit _ ys) -> loop o-                      where-                        o = case Data.Sequence.viewr ys of-                                _ :> y -> Some y-                                _      -> App None t-                    App (App ListIndexed _A₀) (ListLit _ as₀) -> loop (ListLit t as₁)-                      where-                        as₁ = Data.Sequence.mapWithIndex adapt as₀--                        _A₂ = Record (Dhall.Map.fromList kts)-                          where-                            kts = [ ("index", Natural)-                                  , ("value", _A₀)-                                  ]--                        t | null as₀  = Just (App List _A₂)-                          | otherwise = Nothing--                        adapt n a_ =-                            RecordLit (Dhall.Map.fromList kvs)-                          where-                            kvs = [ ("index", NaturalLit (fromIntegral n))-                                  , ("value", a_)-                                  ]-                    App (App ListReverse _) (ListLit t xs) ->-                        loop (ListLit t (Data.Sequence.reverse xs))--                    App (App OptionalFold t0) x0 -> do-                        t1 <- loop t0-                        let optional = Var (V "optional" 0)-                        let lam term = (Lam "optional"-                                           (Const Type)-                                           (Lam "some"-                                               (Pi "_" t1 optional)-                                               (Lam "none" optional term)))-                        x1 <- loop x0-                        pure $ case x1 of-                            App None _ -> lam (Var (V "none" 0))-                            Some x'    -> lam (App (Var (V "some" 0)) x')-                            _          -> App (App OptionalFold t1) x1--                    App TextShow (TextLit (Chunks [] oldText)) ->-                        loop (TextLit (Chunks [] newText))-                      where-                        newText = Eval.textShow oldText-                    _ -> do-                        res2 <- ctx (App f' a')-                        case res2 of-                            Nothing -> pure (App f' a')-                            Just app' -> loop app'-    Let (Binding _ f _ _ _ r) b -> loop b''-      where-        r'  = shift   1  (V f 0) r-        b'  = subst (V f 0) r' b-        b'' = shift (-1) (V f 0) b'-    Annot x _ -> loop x-    Bool -> pure Bool-    BoolLit b -> pure (BoolLit b)-    BoolAnd x y -> decide <$> loop x <*> loop y-      where-        decide (BoolLit True )  r              = r-        decide (BoolLit False)  _              = BoolLit False-        decide  l              (BoolLit True ) = l-        decide  _              (BoolLit False) = BoolLit False-        decide  l               r-            | Eval.judgmentallyEqual l r = l-            | otherwise                  = BoolAnd l r-    BoolOr x y -> decide <$> loop x <*> loop y-      where-        decide (BoolLit False)  r              = r-        decide (BoolLit True )  _              = BoolLit True-        decide  l              (BoolLit False) = l-        decide  _              (BoolLit True ) = BoolLit True-        decide  l               r-            | Eval.judgmentallyEqual l r = l-            | otherwise                  = BoolOr l r-    BoolEQ x y -> decide <$> loop x <*> loop y-      where-        decide (BoolLit True )  r              = r-        decide  l              (BoolLit True ) = l-        decide  l               r-            | Eval.judgmentallyEqual l r = BoolLit True-            | otherwise                  = BoolEQ l r-    BoolNE x y -> decide <$> loop x <*> loop y-      where-        decide (BoolLit False)  r              = r-        decide  l              (BoolLit False) = l-        decide  l               r-            | Eval.judgmentallyEqual l r = BoolLit False-            | otherwise                  = BoolNE l r-    BoolIf bool true false -> decide <$> loop bool <*> loop true <*> loop false-      where-        decide (BoolLit True )  l              _              = l-        decide (BoolLit False)  _              r              = r-        decide  b              (BoolLit True) (BoolLit False) = b-        decide  b               l              r-            | Eval.judgmentallyEqual l r = l-            | otherwise                  = BoolIf b l r-    Natural -> pure Natural-    NaturalLit n -> pure (NaturalLit n)-    NaturalFold -> pure NaturalFold-    NaturalBuild -> pure NaturalBuild-    NaturalIsZero -> pure NaturalIsZero-    NaturalEven -> pure NaturalEven-    NaturalOdd -> pure NaturalOdd-    NaturalToInteger -> pure NaturalToInteger-    NaturalShow -> pure NaturalShow-    NaturalSubtract -> pure NaturalSubtract-    NaturalPlus x y -> decide <$> loop x <*> loop y-      where-        decide (NaturalLit 0)  r             = r-        decide  l             (NaturalLit 0) = l-        decide (NaturalLit m) (NaturalLit n) = NaturalLit (m + n)-        decide  l              r             = NaturalPlus l r-    NaturalTimes x y -> decide <$> loop x <*> loop y-      where-        decide (NaturalLit 1)  r             = r-        decide  l             (NaturalLit 1) = l-        decide (NaturalLit 0)  _             = NaturalLit 0-        decide  _             (NaturalLit 0) = NaturalLit 0-        decide (NaturalLit m) (NaturalLit n) = NaturalLit (m * n)-        decide  l              r             = NaturalTimes l r-    Integer -> pure Integer-    IntegerLit n -> pure (IntegerLit n)-    IntegerShow -> pure IntegerShow-    IntegerToDouble -> pure IntegerToDouble-    Double -> pure Double-    DoubleLit n -> pure (DoubleLit n)-    DoubleShow -> pure DoubleShow-    Text -> pure Text-    TextLit (Chunks xys z) -> do-        chunks' <- mconcat <$> chunks-        case chunks' of-            Chunks [("", x)] "" -> pure x-            c                   -> pure (TextLit c)-      where-        chunks =-          ((++ [Chunks [] z]) . concat) <$> traverse process xys--        process (x, y) = do-          y' <- loop y-          case y' of-            TextLit c -> pure [Chunks [] x, c]-            _         -> pure [Chunks [(x, y')] mempty]-    TextAppend x y -> loop (TextLit (Chunks [("", x), ("", y)] ""))-    TextShow -> pure TextShow-    List -> pure List-    ListLit t es-        | Data.Sequence.null es -> ListLit <$> t' <*> pure Data.Sequence.empty-        | otherwise             -> ListLit Nothing <$> es'-      where-        t'  = traverse loop t-        es' = traverse loop es-    ListAppend x y -> decide <$> loop x <*> loop y-      where-        decide (ListLit _ m)  r            | Data.Sequence.null m = r-        decide  l            (ListLit _ n) | Data.Sequence.null n = l-        decide (ListLit t m) (ListLit _ n)                        = ListLit t (m <> n)-        decide  l             r                                   = ListAppend l r-    ListBuild -> pure ListBuild-    ListFold -> pure ListFold-    ListLength -> pure ListLength-    ListHead -> pure ListHead-    ListLast -> pure ListLast-    ListIndexed -> pure ListIndexed-    ListReverse -> pure ListReverse-    Optional -> pure Optional-    Some a -> Some <$> a'-      where-        a' = loop a-    None -> pure None-    OptionalFold -> pure OptionalFold-    OptionalBuild -> pure OptionalBuild-    Record kts -> Record . Dhall.Map.sort <$> kts'-      where-        kts' = traverse loop kts-    RecordLit kvs -> RecordLit . Dhall.Map.sort <$> kvs'-      where-        kvs' = traverse loop kvs-    Union kts -> Union . Dhall.Map.sort <$> kts'-      where-        kts' = traverse (traverse loop) kts-    Combine x y -> decide <$> loop x <*> loop y-      where-        decide (RecordLit m) r | Data.Foldable.null m =-            r-        decide l (RecordLit n) | Data.Foldable.null n =-            l-        decide (RecordLit m) (RecordLit n) =-            RecordLit (Dhall.Map.unionWith decide m n)-        decide l r =-            Combine l r-    CombineTypes x y -> decide <$> loop x <*> loop y-      where-        decide (Record m) r | Data.Foldable.null m =-            r-        decide l (Record n) | Data.Foldable.null n =-            l-        decide (Record m) (Record n) =-            Record (Dhall.Map.unionWith decide m n)-        decide l r =-            CombineTypes l r-    Prefer x y -> decide <$> loop x <*> loop y-      where-        decide (RecordLit m) r | Data.Foldable.null m =-            r-        decide l (RecordLit n) | Data.Foldable.null n =-            l-        decide (RecordLit m) (RecordLit n) =-            RecordLit (Dhall.Map.union n m)-        decide l r | Eval.judgmentallyEqual l r =-            l-        decide l r =-            Prefer l r-    RecordCompletion x y -> do-        loop (Annot (Prefer (Field x "default") y) (Field x "Type"))-    Merge x y t      -> do-        x' <- loop x-        y' <- loop y-        case x' of-            RecordLit kvsX ->-                case y' of-                    Field (Union ktsY) kY ->-                        case Dhall.Map.lookup kY ktsY of-                            Just Nothing ->-                                case Dhall.Map.lookup kY kvsX of-                                    Just vX -> return vX-                                    Nothing -> Merge x' y' <$> t'-                            _ ->-                                Merge x' y' <$> t'-                    App (Field (Union ktsY) kY) vY ->-                        case Dhall.Map.lookup kY ktsY of-                            Just (Just _) ->-                                case Dhall.Map.lookup kY kvsX of-                                    Just vX -> loop (App vX vY)-                                    Nothing -> Merge x' y' <$> t'-                            _ ->-                                Merge x' y' <$> t'-                    _ -> Merge x' y' <$> t'-            _ -> Merge x' y' <$> t'-      where-        t' = traverse loop t-    ToMap x t        -> do-        x' <- loop x-        t' <- traverse loop t-        case x' of-            RecordLit kvsX -> do-                let entry (key, value) =-                        RecordLit-                            (Dhall.Map.fromList-                                [ ("mapKey"  , TextLit (Chunks [] key))-                                , ("mapValue", value                  )-                                ]-                            )--                let keyValues = Data.Sequence.fromList (map entry (Dhall.Map.toList kvsX))--                let listType = case t' of-                        Just _ | null keyValues ->-                            t'-                        _ ->-                            Nothing--                return (ListLit listType keyValues)-            _ -> do-                return (ToMap x' t')-    Field r x        -> do-        let singletonRecordLit v = RecordLit (Dhall.Map.singleton x v)--        r' <- loop r-        case r' of-            RecordLit kvs ->-                case Dhall.Map.lookup x kvs of-                    Just v  -> pure v-                    Nothing -> Field <$> (RecordLit <$> traverse loop kvs) <*> pure x-            Project r_ _ -> loop (Field r_ x)-            Prefer (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of-                Just v -> pure (Field (Prefer (singletonRecordLit v) r_) x)-                Nothing -> loop (Field r_ x)-            Prefer l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of-                Just v -> pure v-                Nothing -> loop (Field l x)-            Combine (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of-                Just v -> pure (Field (Combine (singletonRecordLit v) r_) x)-                Nothing -> loop (Field r_ x)-            Combine l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of-                Just v -> pure (Field (Combine l (singletonRecordLit v)) x)-                Nothing -> loop (Field l x)-            _ -> pure (Field r' x)-    Project x (Left fields)-> do-        x' <- loop x-        let fieldsSet = Dhall.Set.toSet fields-        case x' of-            RecordLit kvs ->-                pure (RecordLit (Dhall.Map.restrictKeys kvs fieldsSet))-            Project y _ ->-                loop (Project y (Left fields))-            Prefer l (RecordLit rKvs) -> do-                let rKs = Dhall.Map.keysSet rKvs-                let l' = Project l (Left (Dhall.Set.fromSet (Data.Set.difference fieldsSet rKs)))-                let r' = RecordLit (Dhall.Map.restrictKeys rKvs fieldsSet)-                loop (Prefer l' r')-            _ | null fields -> pure (RecordLit mempty)-              | otherwise   -> pure (Project x' (Left (Dhall.Set.sort fields)))-    Project r (Right e1) -> do-        e2 <- loop e1--        case e2 of-            Record kts -> do-                loop (Project r (Left (Dhall.Set.fromSet (Dhall.Map.keysSet kts))))-            _ -> do-                r' <- loop r-                pure (Project r' (Right e2))-    Assert t -> do-        t' <- loop t--        pure (Assert t')-    Equivalent l r -> do-        l' <- loop l-        r' <- loop r--        pure (Equivalent l' r')-    Note _ e' -> loop e'-    ImportAlt l _r -> loop l-    Embed a -> pure (Embed a)---- | Use this to wrap you embedded functions (see `normalizeWith`) to make them---   polymorphic enough to be used.-type NormalizerM m a = forall s. Expr s a -> m (Maybe (Expr s a))---- | An variation on `NormalizerM` for pure normalizers-type Normalizer a = NormalizerM Identity a---- | A reified 'Normalizer', which can be stored in structures without--- running into impredicative polymorphism.-newtype ReifiedNormalizer a = ReifiedNormalizer-  { getReifiedNormalizer :: Normalizer a }---- | Check if an expression is in a normal form given a context of evaluation.---   Unlike `isNormalized`, this will fully normalize and traverse through the expression.------   It is much more efficient to use `isNormalized`.------  `isNormalizedWith` can fail with an `error` if you check an ill-typed---  expression-isNormalizedWith :: (Eq s, Eq a) => Normalizer a -> Expr s a -> Bool-isNormalizedWith ctx e = e == normalizeWith (Just (ReifiedNormalizer ctx)) e---- | Quickly check if an expression is in normal form------ Given a well-typed expression @e@, @'isNormalized' e@ is equivalent to--- @e == 'normalize' e@.------ Given an ill-typed expression, 'isNormalized' may fail with an error, or--- evaluate to either False or True!-isNormalized :: Eq a => Expr s a -> Bool-isNormalized e0 = loop (denote e0)-  where-    loop e = case e of-      Const _ -> True-      Var _ -> True-      Lam _ a b -> loop a && loop b-      Pi _ a b -> loop a && loop b-      App f a -> loop f && loop a && case App f a of-          App (Lam _ _ _) _ -> False--          -- build/fold fusion for `List`-          App (App ListBuild _) (App (App ListFold _) _) -> False--          -- build/fold fusion for `Natural`-          App NaturalBuild (App NaturalFold _) -> False--          -- build/fold fusion for `Optional`-          App (App OptionalBuild _) (App (App OptionalFold _) _) -> False--          App (App (App (App NaturalFold (NaturalLit _)) _) _) _ -> False-          App NaturalFold (NaturalLit _) -> False-          App NaturalBuild _ -> False-          App NaturalIsZero (NaturalLit _) -> False-          App NaturalEven (NaturalLit _) -> False-          App NaturalOdd (NaturalLit _) -> False-          App NaturalShow (NaturalLit _) -> False-          App (App NaturalSubtract (NaturalLit _)) (NaturalLit _) -> False-          App (App NaturalSubtract (NaturalLit 0)) _ -> False-          App (App NaturalSubtract _) (NaturalLit 0) -> False-          App (App NaturalSubtract x) y -> not (Eval.judgmentallyEqual x y)-          App NaturalToInteger (NaturalLit _) -> False-          App IntegerShow (IntegerLit _) -> False-          App IntegerToDouble (IntegerLit _) -> False-          App DoubleShow (DoubleLit _) -> False-          App (App OptionalBuild _) _ -> False-          App (App ListBuild _) _ -> False-          App (App ListFold _) (ListLit _ _) -> False-          App (App ListLength _) (ListLit _ _) -> False-          App (App ListHead _) (ListLit _ _) -> False-          App (App ListLast _) (ListLit _ _) -> False-          App (App ListIndexed _) (ListLit _ _) -> False-          App (App ListReverse _) (ListLit _ _) -> False-          App (App OptionalFold _) (Some _) -> False-          App (App OptionalFold _) (App None _) -> False-          App TextShow (TextLit (Chunks [] _)) ->-              False-          _ -> True-      Let _ _ -> False-      Annot _ _ -> False-      Bool -> True-      BoolLit _ -> True-      BoolAnd x y -> loop x && loop y && decide x y-        where-          decide (BoolLit _)  _          = False-          decide  _          (BoolLit _) = False-          decide  l           r          = not (Eval.judgmentallyEqual l r)-      BoolOr x y -> loop x && loop y && decide x y-        where-          decide (BoolLit _)  _          = False-          decide  _          (BoolLit _) = False-          decide  l           r          = not (Eval.judgmentallyEqual l r)-      BoolEQ x y -> loop x && loop y && decide x y-        where-          decide (BoolLit True)  _             = False-          decide  _             (BoolLit True) = False-          decide  l              r             = not (Eval.judgmentallyEqual l r)-      BoolNE x y -> loop x && loop y && decide x y-        where-          decide (BoolLit False)  _               = False-          decide  _              (BoolLit False ) = False-          decide  l               r               = not (Eval.judgmentallyEqual l r)-      BoolIf x y z ->-          loop x && loop y && loop z && decide x y z-        where-          decide (BoolLit _)  _              _              = False-          decide  _          (BoolLit True) (BoolLit False) = False-          decide  _           l              r              = not (Eval.judgmentallyEqual l r)-      Natural -> True-      NaturalLit _ -> True-      NaturalFold -> True-      NaturalBuild -> True-      NaturalIsZero -> True-      NaturalEven -> True-      NaturalOdd -> True-      NaturalShow -> True-      NaturalSubtract -> True-      NaturalToInteger -> True-      NaturalPlus x y -> loop x && loop y && decide x y-        where-          decide (NaturalLit 0)  _             = False-          decide  _             (NaturalLit 0) = False-          decide (NaturalLit _) (NaturalLit _) = False-          decide  _              _             = True-      NaturalTimes x y -> loop x && loop y && decide x y-        where-          decide (NaturalLit 0)  _             = False-          decide  _             (NaturalLit 0) = False-          decide (NaturalLit 1)  _             = False-          decide  _             (NaturalLit 1) = False-          decide (NaturalLit _) (NaturalLit _) = False-          decide  _              _             = True-      Integer -> True-      IntegerLit _ -> True-      IntegerShow -> True-      IntegerToDouble -> True-      Double -> True-      DoubleLit _ -> True-      DoubleShow -> True-      Text -> True-      TextLit (Chunks [("", _)] "") -> False-      TextLit (Chunks xys _) -> all (all check) xys-        where-          check y = loop y && case y of-              TextLit _ -> False-              _         -> True-      TextAppend _ _ -> False-      TextShow -> True-      List -> True-      ListLit t es -> all loop t && all loop es-      ListAppend x y -> loop x && loop y && decide x y-        where-          decide (ListLit _ m)  _            | Data.Sequence.null m = False-          decide  _            (ListLit _ n) | Data.Sequence.null n = False-          decide (ListLit _ _) (ListLit _ _)                        = False-          decide  _             _                                   = True-      ListBuild -> True-      ListFold -> True-      ListLength -> True-      ListHead -> True-      ListLast -> True-      ListIndexed -> True-      ListReverse -> True-      Optional -> True-      Some a -> loop a-      None -> True-      OptionalFold -> True-      OptionalBuild -> True-      Record kts -> Dhall.Map.isSorted kts && all loop kts-      RecordLit kvs -> Dhall.Map.isSorted kvs && all loop kvs-      Union kts -> Dhall.Map.isSorted kts && all (all loop) kts-      Combine x y -> loop x && loop y && decide x y-        where-          decide (RecordLit m) _ | Data.Foldable.null m = False-          decide _ (RecordLit n) | Data.Foldable.null n = False-          decide (RecordLit _) (RecordLit _) = False-          decide  _ _ = True-      CombineTypes x y -> loop x && loop y && decide x y-        where-          decide (Record m) _ | Data.Foldable.null m = False-          decide _ (Record n) | Data.Foldable.null n = False-          decide (Record _) (Record _) = False-          decide  _ _ = True-      Prefer x y -> loop x && loop y && decide x y-        where-          decide (RecordLit m) _ | Data.Foldable.null m = False-          decide _ (RecordLit n) | Data.Foldable.null n = False-          decide (RecordLit _) (RecordLit _) = False-          decide l r = not (Eval.judgmentallyEqual l r)-      RecordCompletion _ _ -> False-      Merge x y t -> loop x && loop y && all loop t-      ToMap x t -> case x of-          RecordLit _ -> False-          _ -> loop x && all loop t-      Field r k -> case r of-          RecordLit _ -> False-          Project _ _ -> False-          Prefer (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r-          Prefer _ (RecordLit _) -> False-          Combine (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r-          Combine _ (RecordLit m) -> Dhall.Map.keys m == [k] && loop r-          _ -> loop r-      Project r p -> loop r &&-          case p of-              Left s -> case r of-                  RecordLit _ -> False-                  Project _ _ -> False-                  Prefer _ (RecordLit _) -> False-                  _ -> not (Dhall.Set.null s) && Dhall.Set.isSorted s-              Right e' -> case e' of-                  Record _ -> False-                  _ -> loop e'-      Assert t -> loop t-      Equivalent l r -> loop l && loop r-      Note _ e' -> loop e'-      ImportAlt _ _ -> False-      Embed _ -> True--{-| Detect if the given variable is free within the given expression-->>> "x" `freeIn` "x"-True->>> "x" `freeIn` "y"-False->>> "x" `freeIn` Lam "x" (Const Type) "x"-False--}-freeIn :: Eq a => Var -> Expr s a -> Bool-variable@(V var i) `freeIn` expression =-    Dhall.Core.subst variable (Var (V var (i + 1))) strippedExpression-      /= strippedExpression-  where-    denote' :: Expr t b -> Expr () b-    denote' = denote--    strippedExpression = denote' expression+{-# LANGUAGE RankNTypes         #-}+{-# LANGUAGE RecordWildCards    #-}++{-| This module contains the core calculus for the Dhall language.++    Dhall is essentially a fork of the @morte@ compiler but with more built-in+    functionality, better error messages, and Haskell integration+-}++module Dhall.Core (+    -- * Syntax+      Const(..)+    , Directory(..)+    , File(..)+    , FilePrefix(..)+    , Import(..)+    , ImportHashed(..)+    , ImportMode(..)+    , ImportType(..)+    , URL(..)+    , Scheme(..)+    , DhallDouble(..)+    , Var(..)+    , Binding(..)+    , makeBinding+    , Chunks(..)+    , Expr(..)++    -- * Normalization+    , alphaNormalize+    , normalize+    , normalizeWith+    , normalizeWithM+    , Normalizer+    , NormalizerM+    , ReifiedNormalizer (..)+    , judgmentallyEqual+    , subst+    , shift+    , isNormalized+    , isNormalizedWith+    , denote+    , renote+    , shallowDenote+    , freeIn++    -- * Pretty-printing+    , pretty++    -- * Optics+    , subExpressions+    , chunkExprs+    , bindingExprs++    -- * Let-blocks+    , multiLet+    , wrapInLets+    , MultiLet(..)++    -- * Miscellaneous+    , internalError+    , reservedIdentifiers+    , escapeText+    , pathCharacter+    , throws+    , Eval.textShow+    , censorExpression+    , censorText+    ) where++import Control.Exception (Exception)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Semigroup (Semigroup(..))+import Data.Text (Text)+import Data.Text.Prettyprint.Doc (Pretty)+import Dhall.Normalize+import Dhall.Src (Src(..))+import Dhall.Syntax+import Dhall.Pretty.Internal+import Instances.TH.Lift ()+import Lens.Family (over)+import Prelude hiding (succ)++import qualified Control.Exception+import qualified Dhall.Eval    as Eval+import qualified Data.Text  -- | Pretty-print a value pretty :: Pretty a => a -> Text

src/Dhall/Diff.hs view

@@ -25,8 +25,7 @@ import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty) import Data.Void (Void)-import Dhall.Core (Binding(..), Chunks (..), Const(..), DhallDouble(..), Expr(..), Var(..))-import Dhall.Binary (ToTerm)+import Dhall.Syntax (Binding(..), Chunks (..), Const(..), DhallDouble(..), Expr(..), Var(..)) import Dhall.Map (Map) import Dhall.Set (Set) import Dhall.Pretty.Internal (Ann)@@ -37,7 +36,7 @@ import qualified Data.Set import qualified Data.Text import qualified Data.Text.Prettyprint.Doc  as Pretty-import qualified Dhall.Core+import qualified Dhall.Normalize import qualified Dhall.Map import qualified Dhall.Set import qualified Dhall.Pretty.Internal      as Internal@@ -156,11 +155,11 @@ rparen = token Internal.rparen  -- | Render the difference between the normal form of two expressions-diffNormalized :: (Eq a, Pretty a, ToTerm a) => Expr s a -> Expr s a -> Diff+diffNormalized :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff diffNormalized l0 r0 = Dhall.Diff.diff l1 r1   where-    l1 = Dhall.Core.alphaNormalize (Dhall.Core.normalize l0)-    r1 = Dhall.Core.alphaNormalize (Dhall.Core.normalize r0)+    l1 = Dhall.Normalize.alphaNormalize (Dhall.Normalize.normalize l0)+    r1 = Dhall.Normalize.alphaNormalize (Dhall.Normalize.normalize r0)  diffPrimitive :: Eq a => (a -> Diff) -> a -> a -> Diff diffPrimitive f l r@@ -362,15 +361,23 @@ diffList     :: (Eq a, Pretty a)     => Seq (Expr Void a) -> Seq (Expr Void a) -> Diff-diffList l r = bracketed (foldMap diffPart parts)+diffList l r = bracketed (loop parts₀)   where     -- Sections of the list that are only in left, only in right, or in both-    parts =-        Algo.Diff.getGroupedDiffBy ((same .) . diff) (toList l) (toList r)+    parts₀ = Algo.Diff.getGroupedDiffBy equal (toList l) (toList r) +    equal a b = same (diff a b)+     -- Render each element of a list using an extra rendering function f     prettyElems f = map (f . token . Internal.prettyExpr) +    loop [] =+        mempty+    loop (Algo.Diff.First as : Algo.Diff.Second bs : parts)+        | length as == length bs = zipWith diff as bs <> loop parts+    loop (part : parts) =+        diffPart part <> loop parts+     diffPart part =       case part of         -- Only present in left@@ -1136,6 +1143,18 @@ diffPrimitiveExpression l@Integer r =     mismatch l r diffPrimitiveExpression l r@Integer =+    mismatch l r+diffPrimitiveExpression IntegerClamp IntegerClamp =+    "…"+diffPrimitiveExpression l@IntegerClamp r =+    mismatch l r+diffPrimitiveExpression l r@IntegerClamp =+    mismatch l r+diffPrimitiveExpression IntegerNegate IntegerNegate =+    "…"+diffPrimitiveExpression l@IntegerNegate r =+    mismatch l r+diffPrimitiveExpression l r@IntegerNegate =     mismatch l r diffPrimitiveExpression IntegerShow IntegerShow =     "…"

src/Dhall/Eval.hs view

@@ -133,15 +133,6 @@   -- ^ Don't store any information   | Typed !Text (Val a)   -- ^ Store the original name and type of the variable bound by the `Lam`-  | NaturalFoldCl (Val a)-  -- ^ The original function was a @Natural/fold@.  We need to preserve this-  --   information in order to implement @Natural/{build,fold}@ fusion-  | ListFoldCl (Val a)-  -- ^ The original function was a @List/fold@.  We need to preserve this-  --   information in order to implement @List/{build,fold}@ fusion-  | OptionalFoldCl (Val a)-  -- ^ The original function was an @Optional/fold@.  We need to preserve this-  --   information in order to implement @Optional/{build,fold}@ fusion   | NaturalSubtractZero   -- ^ The original function was a @Natural/subtract 0@.  We need to preserve   --   this information in case the @Natural/subtract@ ends up not being fully@@ -192,6 +183,8 @@      | VInteger     | VIntegerLit !Integer+    | VIntegerClamp !(Val a)+    | VIntegerNegate !(Val a)     | VIntegerShow !(Val a)     | VIntegerToDouble !(Val a) @@ -468,14 +461,12 @@                         go  acc m = go (vApp succ acc) (m - 1)                     in  go zero (fromIntegral n :: Integer)                 n ->-                    VHLam (NaturalFoldCl n) $ \natural ->+                    VPrim $ \natural ->                     VPrim $ \succ ->                     VPrim $ \zero ->                     VNaturalFold n natural succ zero         NaturalBuild ->             VPrim $ \case-                VHLam (NaturalFoldCl x) _ ->-                    x                 VPrimVar ->                     VNaturalBuild VPrimVar                 t ->       t@@ -526,6 +517,16 @@             VInteger         IntegerLit n ->             VIntegerLit n+        IntegerClamp ->+            VPrim $ \case+                VIntegerLit n+                    | 0 <= n    -> VNaturalLit (fromInteger n)+                    | otherwise -> VNaturalLit 0+                n -> VIntegerClamp n+        IntegerNegate ->+            VPrim $ \case+                VIntegerLit n -> VIntegerLit (negate n)+                n             -> VIntegerNegate n         IntegerShow ->             VPrim $ \case                 VIntegerLit n@@ -568,8 +569,6 @@         ListBuild ->             VPrim $ \a ->             VPrim $ \case-                VHLam (ListFoldCl x) _ ->-                    x                 VPrimVar ->                     VListBuild a VPrimVar                 t ->       t@@ -588,7 +587,7 @@                     VHLam (Typed "nil"  list) $ \nil ->                     foldr' (\x b -> cons `vApp` x `vApp` b) nil as                 as ->-                    VHLam (ListFoldCl as) $ \t ->+                    VPrim $ \t ->                     VPrim $ \c ->                     VPrim $ \n ->                     VListFold a as t c n@@ -620,14 +619,14 @@                 VListLit _ as ->                     let a' =                             if null as-                            then Just (VList (VRecord (Map.fromList [("index", VNatural), ("value", a)])))+                            then Just (VList (VRecord (Map.unorderedFromList [("index", VNatural), ("value", a)])))                             else Nothing                          as' =                             Sequence.mapWithIndex                                 (\i t ->                                     VRecordLit-                                        (Map.fromList+                                        (Map.unorderedFromList                                             [ ("index", VNaturalLit (fromIntegral i))                                             , ("value", t)                                             ]@@ -667,14 +666,13 @@                     VHLam (Typed "none" optional) $ \_none ->                     some `vApp` t                 opt ->-                    VHLam (OptionalFoldCl opt) $ \o ->+                    VPrim $ \o ->                     VPrim $ \s ->                     VPrim $ \n ->                     VOptionalFold a opt o s n         OptionalBuild ->             VPrim $ \ ~a ->             VPrim $ \case-                VHLam (OptionalFoldCl x) _ -> x                 VPrimVar -> VOptionalBuild a VPrimVar                 t ->       t                     `vApp` VOptional a@@ -703,17 +701,17 @@         ToMap x ma ->             case (eval env x, fmap (eval env) ma) of                 (VRecordLit m, ma'@(Just _)) | null m ->-                    VListLit ma' (Sequence.empty)+                    VListLit ma' Sequence.empty                 (VRecordLit m, _) ->                     let entry (k, v) =                             VRecordLit-                                (Map.fromList+                                (Map.unorderedFromList                                     [ ("mapKey", VTextLit $ VChunks [] k)                                     , ("mapValue", v)                                     ]                                 ) -                        s = (Sequence.fromList . map entry . Map.toList) m+                        s = (Sequence.fromList . map entry . Map.toAscList) m                      in  VListLit Nothing s                 (x', ma') ->@@ -761,7 +759,7 @@ eqMapsBy :: Ord k => (v -> v -> Bool) -> Map k v -> Map k v -> Bool eqMapsBy f mL mR =     Map.size mL == Map.size mR-    && eqListBy eq (Map.toList mL) (Map.toList mR)+    && eqListBy eq (Map.toAscList mL) (Map.toAscList mR)   where     eq (kL, vL) (kR, vR) = kL == kR && f vL vR {-# INLINE eqMapsBy #-}@@ -864,6 +862,10 @@             True         (VIntegerLit t, VIntegerLit t') ->             t == t'+        (VIntegerClamp t, VIntegerClamp t') ->+            conv env t t'+        (VIntegerNegate t, VIntegerNegate t') ->+            conv env t t'         (VIntegerShow t, VIntegerShow t') ->             conv env t t'         (VIntegerToDouble t, VIntegerToDouble t') ->@@ -998,9 +1000,6 @@             case i of                 Typed (fresh -> (x, v)) a -> Lam x (quote env a) (quoteBind x (t v))                 Prim                      -> quote env (t VPrimVar)-                NaturalFoldCl{}           -> quote env (t VPrimVar)-                ListFoldCl{}              -> quote env (t VPrimVar)-                OptionalFoldCl{}          -> quote env (t VPrimVar)                 NaturalSubtractZero       -> App NaturalSubtract (NaturalLit 0)          VPi a (freshClosure -> (x, v, b)) ->@@ -1049,6 +1048,10 @@             Integer         VIntegerLit n ->             IntegerLit n+        VIntegerClamp t ->+            IntegerClamp `qApp` t+        VIntegerNegate t ->+            IntegerNegate `qApp` t         VIntegerShow t ->             IntegerShow `qApp` t         VIntegerToDouble t ->@@ -1225,6 +1228,10 @@                 Integer             IntegerLit n ->                 IntegerLit n+            IntegerClamp ->+                IntegerClamp+            IntegerNegate ->+                IntegerNegate             IntegerShow ->                 IntegerShow             IntegerToDouble ->

src/Dhall/Format.hs view

@@ -13,8 +13,8 @@  import Control.Exception (Exception) import Data.Monoid ((<>))-import Dhall.Pretty (CharacterSet(..), annToAnsiStyle, layoutOpts)-import Dhall.Util (Censor, Input(..))+import Dhall.Pretty (CharacterSet(..), annToAnsiStyle)+import Dhall.Util (Censor, Input(..), Header(..))  import qualified Data.Text.Prettyprint.Doc                 as Pretty import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal@@ -23,6 +23,7 @@ import qualified Data.Text.IO import qualified Dhall.Pretty import qualified Dhall.Util+import qualified System.AtomicWrite.Writer.LazyText        as AtomicWrite.LazyText import qualified System.Console.ANSI import qualified System.IO @@ -50,50 +51,49 @@ format     :: Format     -> IO ()-format (Format {..}) =+format (Format {..}) = do+    let layoutHeaderAndExpr (Header header, expr) =+            Dhall.Pretty.layout+                (   Pretty.pretty header+                <>  Dhall.Pretty.prettyCharacterSet characterSet expr +                <>  "\n")++    let layoutInput input = do+            headerAndExpr <- Dhall.Util.getExpressionAndHeader censor input++            return (layoutHeaderAndExpr headerAndExpr)+     case formatMode of-        Modify {..} ->+        Modify {..} -> do+            docStream <- layoutInput inplace+             case inplace of                 InputFile file -> do-                    (header, expr) <- Dhall.Util.getExpressionAndHeader censor (InputFile file)--                    let doc =   Pretty.pretty header-                            <>  Pretty.unAnnotate (Dhall.Pretty.prettyCharacterSet characterSet expr)-                            <>  "\n"+                    AtomicWrite.LazyText.atomicWriteFile+                        file+                        (Pretty.Text.renderLazy docStream) -                    System.IO.withFile file System.IO.WriteMode (\handle -> do-                        Pretty.Terminal.renderIO handle (Pretty.layoutSmart layoutOpts doc))                 StandardInput -> do-                    (header, expr) <- Dhall.Util.getExpressionAndHeader censor StandardInput--                    let doc =   Pretty.pretty header-                            <>  Dhall.Pretty.prettyCharacterSet characterSet expr-                            <>  "\n"-                     supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout -                    if supportsANSI-                      then-                        Pretty.Terminal.renderIO-                          System.IO.stdout-                          (fmap annToAnsiStyle (Pretty.layoutSmart layoutOpts doc))-                      else-                        Pretty.Terminal.renderIO-                          System.IO.stdout-                          (Pretty.layoutSmart layoutOpts (Pretty.unAnnotate doc))+                    Pretty.Terminal.renderIO+                        System.IO.stdout+                        (if supportsANSI+                            then (fmap annToAnsiStyle docStream)+                            else (Pretty.unAnnotateS docStream))+         Check {..} -> do             originalText <- case path of                 InputFile file -> Data.Text.IO.readFile file                 StandardInput  -> Data.Text.IO.getContents -            (header, expr) <- Dhall.Util.getExpressionAndHeader censor path--            let doc =   Pretty.pretty header-                    <>  Pretty.unAnnotate (Dhall.Pretty.prettyCharacterSet characterSet expr)-                    <>  "\n"+            docStream <- case path of+                InputFile _    -> layoutInput path+                StandardInput  -> do+                    headerAndExpr <- Dhall.Util.getExpressionAndHeaderFromStdinText censor originalText+                    return (layoutHeaderAndExpr headerAndExpr) -            let formattedText =-                    Pretty.Text.renderStrict (Pretty.layoutSmart layoutOpts doc)+            let formattedText = Pretty.Text.renderStrict docStream              if originalText == formattedText                 then return ()

src/Dhall/Freeze.hs view

@@ -14,13 +14,11 @@     , Intent(..)     ) where -import Control.Exception (SomeException) import Data.Monoid ((<>)) import Data.Text-import Data.Void (Void)-import Dhall.Core (Expr(..), Import(..), ImportHashed(..), ImportType(..)) import Dhall.Parser (Src)-import Dhall.Pretty (CharacterSet, annToAnsiStyle, layoutOpts, prettyCharacterSet)+import Dhall.Pretty (CharacterSet)+import Dhall.Syntax (Expr(..), Import(..), ImportHashed(..), ImportType(..)) import Dhall.Util (Censor, Input(..)) import System.Console.ANSI (hSupportsANSI) @@ -28,12 +26,14 @@ import qualified Control.Monad.Trans.State.Strict          as State import qualified Data.Text.Prettyprint.Doc                 as Pretty import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty-import qualified Data.Text.IO+import qualified Data.Text.Prettyprint.Doc.Render.Text     as Pretty.Text import qualified Dhall.Core import qualified Dhall.Import import qualified Dhall.Optics+import qualified Dhall.Pretty import qualified Dhall.TypeCheck import qualified Dhall.Util+import qualified System.AtomicWrite.Writer.LazyText        as AtomicWrite.LazyText import qualified System.FilePath import qualified System.IO @@ -54,15 +54,7 @@      let status = Dhall.Import.emptyStatus directory -    let download =-            State.evalStateT (Dhall.Import.loadWith (Embed import_)) status--    -- Try again without the semantic integrity check if decoding fails-    let handler :: SomeException -> IO (Expr Src Void)-        handler _ = do-            State.evalStateT (Dhall.Import.loadWith (Embed unprotectedImport)) status--    expression <- Control.Exception.handle handler download+    expression <- State.evalStateT (Dhall.Import.loadWith (Embed unprotectedImport)) status      case Dhall.TypeCheck.typeOf expression of         Left  exception -> Control.Exception.throwIO exception@@ -72,7 +64,7 @@             Dhall.Core.alphaNormalize (Dhall.Core.normalize expression)      -- make sure the frozen import is present in the semantic cache-    Dhall.Import.writeExpressionToSemanticCache expression+    Dhall.Import.writeExpressionToSemanticCache (Dhall.Core.denote expression)      let expressionHash = Dhall.Import.hashExpression normalizedExpression @@ -97,20 +89,23 @@ writeExpr inplace (header, expr) characterSet = do     let doc =  Pretty.pretty header             <> Dhall.Pretty.prettyCharacterSet characterSet expr+            <> "\n" -    let unAnnotated = Pretty.layoutSmart layoutOpts (Pretty.unAnnotate doc)+    let stream = Dhall.Pretty.layout doc +    let unAnnotated = Pretty.unAnnotateS stream+     case inplace of-        InputFile f ->-            System.IO.withFile f System.IO.WriteMode (\handle -> do-                Pretty.renderIO handle unAnnotated-                Data.Text.IO.hPutStrLn handle "" )+        InputFile file ->+            AtomicWrite.LazyText.atomicWriteFile+                file+                (Pretty.Text.renderLazy unAnnotated)          StandardInput -> do             supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout             if supportsANSI                then-                 Pretty.renderIO System.IO.stdout (annToAnsiStyle <$> Pretty.layoutSmart layoutOpts doc)+                 Pretty.renderIO System.IO.stdout (Dhall.Pretty.annToAnsiStyle <$> stream)                else                  Pretty.renderIO System.IO.stdout unAnnotated @@ -145,7 +140,8 @@             StandardInput  -> "."             InputFile file -> System.FilePath.takeDirectory file -    (header, parsedExpression) <- Dhall.Util.getExpressionAndHeader censor inplace+    (Dhall.Util.Header header, parsedExpression) <-+        Dhall.Util.getExpressionAndHeader censor inplace      let freezeScope =             case scope of

src/Dhall/Import.hs view

@@ -138,7 +138,6 @@     ) where  import Control.Applicative (Alternative(..))-import Codec.CBOR.Term (Term(..)) import Control.Exception (Exception, SomeException, IOException, toException) import Control.Monad (when) import Control.Monad.Catch (throwM, MonadCatch(catch), handle)@@ -158,7 +157,7 @@ import Data.Typeable (Typeable) import System.FilePath ((</>)) import Dhall.Binary (StandardVersion(..))-import Dhall.Core+import Dhall.Syntax     ( Expr(..)     , Chunks(..)     , Directory(..)@@ -173,24 +172,25 @@     , chunkExprs     ) #ifdef WITH_HTTP-import Dhall.Import.HTTP hiding (HTTPHeader)+import Dhall.Import.HTTP #endif import Dhall.Import.Types  import Dhall.Parser (Parser(..), ParseError(..), Src(..), SourcedException(..)) 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.Trans.Maybe        as Maybe-import qualified Control.Monad.Trans.State.Strict as State+import qualified Control.Monad.Trans.Maybe                   as Maybe+import qualified Control.Monad.Trans.State.Strict            as State import qualified Data.ByteString import qualified Data.ByteString.Lazy import qualified Data.CaseInsensitive import qualified Data.Foldable-import qualified Data.List.NonEmpty               as NonEmpty-import qualified Data.Map.Strict                  as Map+import qualified Data.List.NonEmpty                          as NonEmpty import qualified Data.Text.Encoding-import qualified Data.Text                        as Text+import qualified Data.Text                                   as Text import qualified Data.Text.IO import qualified Dhall.Binary import qualified Dhall.Core@@ -199,11 +199,12 @@ import qualified Dhall.Parser import qualified Dhall.Pretty.Internal import qualified Dhall.TypeCheck+import qualified System.AtomicWrite.Writer.ByteString.Binary as AtomicWrite.Binary import qualified System.Environment import qualified System.Info import qualified System.IO-import qualified System.Directory                 as Directory-import qualified System.FilePath                  as FilePath+import qualified System.Directory                            as Directory+import qualified System.FilePath                             as FilePath import qualified Text.Megaparsec import qualified Text.Parser.Combinators import qualified Text.Parser.Token@@ -478,11 +479,12 @@ loadImport :: Chained -> StateT Status IO ImportSemantics loadImport import_ = do     Status {..} <- State.get-    case Map.lookup import_ _cache of++    case Dhall.Map.lookup import_ _cache of         Just importSemantics -> return importSemantics         Nothing -> do             importSemantics <- loadImportWithSemanticCache import_-            zoom cache (State.modify (Map.insert import_ importSemantics))+            zoom cache (State.modify (Dhall.Map.insert import_ importSemantics))             return importSemantics  -- | Load an import from the 'semantic cache'. Defers to@@ -504,6 +506,7 @@     case mCached of         Just bytesStrict -> do             let actualHash = Dhall.Crypto.sha256Hash bytesStrict+             if semanticHash == actualHash                 then return ()                 else do@@ -511,13 +514,11 @@                     throwMissingImport (Imported _stack (HashMismatch {expectedHash = semanticHash, ..}))              let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict-            term <- case Codec.Serialise.deserialiseOrFail bytesLazy of-                Left err -> throwMissingImport (Imported _stack err)-                Right t -> return t-            importSemantics <- case Dhall.Binary.decodeExpression term of-                Left err -> throwMissingImport (Imported _stack err)-                Right sem -> return sem +            importSemantics <- case Dhall.Binary.decodeExpression bytesLazy of+                Left  err -> throwMissingImport (Imported _stack err)+                Right e   -> return e+             return (ImportSemantics {..})          Nothing -> do@@ -544,7 +545,7 @@  -- | Ensure that the given expression is present in the semantic cache. The --   given expression should be alpha-beta-normal.-writeExpressionToSemanticCache :: Expr Src Void -> IO ()+writeExpressionToSemanticCache :: Expr Void Void -> IO () writeExpressionToSemanticCache expression = writeToSemanticCache hash bytes   where     bytes = encodeExpression NoVersion expression@@ -554,7 +555,7 @@ writeToSemanticCache hash bytes = do     _ <- Maybe.runMaybeT $ do         cacheFile <- getCacheFile "dhall" hash-        liftIO (Data.ByteString.writeFile cacheFile bytes)+        liftIO (AtomicWrite.Binary.atomicWriteFile cacheFile bytes)     return ()  -- Check the "semi-semantic" disk cache, otherwise typecheck and normalise from@@ -592,18 +593,14 @@     -- Check the semi-semantic cache. See     -- https://github.com/dhall-lang/dhall-haskell/issues/1098 for the reasoning     -- behind semi-semantic caching.-    let semisemanticHash = computeSemisemanticHash resolvedExpr+    let semisemanticHash = computeSemisemanticHash (Dhall.Core.denote resolvedExpr)     mCached <- lift $ fetchFromSemisemanticCache semisemanticHash      importSemantics <- case mCached of         Just bytesStrict -> do             let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict -            term <- case Codec.Serialise.deserialiseOrFail bytesLazy of-                Left err -> throwMissingImport (Imported _stack err)-                Right t -> return t--            importSemantics <- case Dhall.Binary.decodeExpression term of+            importSemantics <- case Dhall.Binary.decodeExpression bytesLazy of                 Left err -> throwMissingImport (Imported _stack err)                 Right sem -> return sem @@ -659,7 +656,7 @@ -- AST (without normalising or type-checking it first). See -- https://github.com/dhall-lang/dhall-haskell/issues/1098 for further -- discussion.-computeSemisemanticHash :: Expr Src Void -> Dhall.Crypto.SHA256Digest+computeSemisemanticHash :: Expr Void Void -> Dhall.Crypto.SHA256Digest computeSemisemanticHash resolvedExpr = hashExpression resolvedExpr  -- Fetch encoded normal form from "semi-semantic cache"@@ -673,7 +670,7 @@ writeToSemisemanticCache semisemanticHash bytes = do     _ <- Maybe.runMaybeT $ do         cacheFile <- getCacheFile "dhall-haskell" semisemanticHash-        liftIO (Data.ByteString.writeFile cacheFile bytes)+        liftIO (AtomicWrite.Binary.atomicWriteFile cacheFile bytes)     return ()  -- Fetch source code directly from disk/network@@ -988,7 +985,7 @@     let local (Chained (Import (ImportHashed _ (Remote  {})) _)) = False         local (Chained (Import (ImportHashed _ (Local   {})) _)) = True         local (Chained (Import (ImportHashed _ (Env     {})) _)) = True-        local (Chained (Import (ImportHashed _ (Missing {})) _)) = True+        local (Chained (Import (ImportHashed _ (Missing {})) _)) = False      let referentiallySane = not (local child) || local parent @@ -1012,7 +1009,7 @@     ImportSemantics {..} <- loadImport child     zoom stack (State.put _stack) -    return importSemantics+    return (Dhall.Core.renote importSemantics)    ImportAlt a b -> loadWith a `catch` handler₀     where@@ -1052,6 +1049,8 @@   NaturalTimes a b     -> NaturalTimes <$> loadWith a <*> loadWith b   Integer              -> pure Integer   IntegerLit a         -> pure (IntegerLit a)+  IntegerClamp         -> pure IntegerClamp+  IntegerNegate        -> pure IntegerNegate   IntegerShow          -> pure IntegerShow   IntegerToDouble      -> pure IntegerToDouble   Double               -> pure Double@@ -1107,33 +1106,30 @@         (emptyStatus rootDirectory) { _semanticCacheMode = semanticCacheMode }  encodeExpression-    :: forall s-    .  StandardVersion+    :: StandardVersion     -- ^ `NoVersion` means to encode without the version tag-    -> Expr s Void+    -> Expr Void Void     -> Data.ByteString.ByteString encodeExpression _standardVersion expression = bytesStrict   where-    intermediateExpression :: Expr s Import+    intermediateExpression :: Expr Void Import     intermediateExpression = fmap absurd expression -    term :: Term-    term = Dhall.Binary.encodeExpression intermediateExpression--    taggedTerm :: Term-    taggedTerm =+    encoding =         case _standardVersion of-            NoVersion -> term-            s         -> TList [ TString v, term ]+            NoVersion ->+                Codec.Serialise.encode intermediateExpression+            s ->+                    Encoding.encodeListLen 2+                <>  Encoding.encodeString v+                <>  Codec.Serialise.encode intermediateExpression               where                 v = Dhall.Binary.renderStandardVersion s -    bytesLazy = Codec.Serialise.serialise taggedTerm--    bytesStrict = Data.ByteString.Lazy.toStrict bytesLazy+    bytesStrict = Write.toStrictByteString encoding  -- | Hash a fully resolved expression-hashExpression :: Expr s Void -> Dhall.Crypto.SHA256Digest+hashExpression :: Expr Void Void -> Dhall.Crypto.SHA256Digest hashExpression expression =     Dhall.Crypto.sha256Hash (encodeExpression NoVersion expression) @@ -1143,7 +1139,7 @@     In other words, the output of this function can be pasted into Dhall     source code to add an integrity check to an import -}-hashExpressionToCode :: Expr s Void -> Text+hashExpressionToCode :: Expr Void Void -> Text hashExpressionToCode expr =     "sha256:" <> Text.pack (show (hashExpression expr))

src/Dhall/Import/Types.hs view

@@ -1,5 +1,7 @@+{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-}+ {-# OPTIONS_GHC -Wall #-}  module Dhall.Import.Types where@@ -8,7 +10,7 @@ import Control.Monad.Trans.State.Strict (StateT) import Data.Dynamic import Data.List.NonEmpty (NonEmpty)-import Data.Map (Map)+import Dhall.Map (Map) import Data.Semigroup ((<>)) import Data.Text.Prettyprint.Doc (Pretty(..)) import Data.Void (Void)@@ -25,12 +27,15 @@   , ReifiedNormalizer(..)   , URL   )+#ifdef WITH_HTTP+import Dhall.Import.Manager (Manager)+#endif import Dhall.Parser (Src) import Lens.Family (LensLike') import System.FilePath (isRelative, splitDirectories)  import qualified Dhall.Context-import qualified Data.Map      as Map+import qualified Dhall.Map     as Map import qualified Data.Text  -- | A fully 'chained' import, i.e. if it contains a relative path that path is@@ -49,7 +54,7 @@  -- | An import that has been fully interpeted data ImportSemantics = ImportSemantics-    { importSemantics :: Expr Src Void+    { importSemantics :: Expr Void Void     -- ^ The fully resolved import, typechecked and beta-normal.     } @@ -75,6 +80,13 @@     -- ^ Cache of imported expressions with their node id in order to avoid     --   importing the same expression twice with different values +#ifdef WITH_HTTP+    , _manager :: Maybe Manager+#else+    , _manager :: Maybe Void+#endif+    -- ^ Used to cache the `Manager` when making multiple requests+     , _remote :: URL -> StateT Status IO Data.Text.Text     -- ^ The remote resolver, fetches the content at the given URL. @@ -95,6 +107,8 @@     _graph = []      _cache = Map.empty++    _manager = Nothing      _normalizer = Nothing

src/Dhall/Lint.hs view

@@ -1,4 +1,7 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards     #-}+{-# LANGUAGE RecordWildCards   #-}  -- | This module contains the implementation of the @dhall lint@ command @@ -6,11 +9,26 @@     ( -- * Lint       lint     , removeUnusedBindings+    , fixAssert+    , fixParentPath     ) where  import Control.Applicative ((<|>))-import Dhall.Core (Binding(..), Expr(..), Import, Var(..), subExpressions) +import Dhall.Syntax+    ( Binding(..)+    , Directory(..)+    , Expr(..)+    , File(..)+    , FilePrefix(..)+    , Import(..)+    , ImportHashed(..)+    , ImportType(..)+    , Var(..)+    , subExpressions+    )++import qualified Data.List.NonEmpty as NonEmpty import qualified Dhall.Core import qualified Dhall.Optics import qualified Lens.Family@@ -22,12 +40,13 @@     * removes unused @let@ bindings with 'removeUnusedBindings'.     * fixes @let a = x ≡ y@ to be @let a = assert : x ≡ y@     * consolidates nested @let@ bindings to use a multiple-@let@ binding with 'removeLetInLet'+    * fixes paths of the form @.\/..\/foo@ to @..\/foo@ -} lint :: Expr s Import -> Expr t Import lint =       Dhall.Optics.rewriteOf         subExpressions-        (\e -> fixAsserts e <|> removeUnusedBindings e)+        (\e -> fixAssert e <|> removeUnusedBindings e <|> fixParentPath e)     . removeLetInLet  -- | Remove unused `Let` bindings.@@ -40,12 +59,41 @@         Just (Dhall.Core.shift (-1) (V a 0) d) removeUnusedBindings _ = Nothing --- Fix `Let` bindings  that the user probably meant to be `assert`s-fixAsserts :: Expr s a -> Maybe (Expr s a)-fixAsserts (Let (Binding { value = Equivalent x y, ..}) body) =+-- | Fix `Let` bindings  that the user probably meant to be `assert`s+fixAssert :: Expr s a -> Maybe (Expr s a)+fixAssert (Let (Binding { value = Equivalent x y, ..}) body) =     Just (Let (Binding { value = Assert (Equivalent x y), .. }) body)-fixAsserts _ =+fixAssert (Let binding (Equivalent x y)) =+    Just (Let binding (Assert (Equivalent x y)))+fixAssert _ =     Nothing++-- | This transforms @.\/..\/foo@ into @..\/foo@+fixParentPath :: Expr s Import -> Maybe (Expr s Import)+fixParentPath (Embed oldImport) = do+    let Import{..} = oldImport++    let ImportHashed{..} = importHashed++    case importType of+        Local Here File{ directory = Directory { components }, .. }+            | Just nonEmpty <- NonEmpty.nonEmpty components+            , NonEmpty.last nonEmpty == ".." -> do+                let newDirectory =+                        Directory { components = NonEmpty.init nonEmpty }++                let newImportType =+                        Local Parent File{ directory = newDirectory, .. }++                let newImportHashed =+                        ImportHashed { importType = newImportType, .. }++                let newImport = Import { importHashed = newImportHashed, .. }++                Just (Embed newImport)+        _ ->+            Nothing+fixParentPath _  = Nothing  isOrContainsAssert :: Expr s a -> Bool isOrContainsAssert (Assert _) = True

src/Dhall/Main.hs view

@@ -32,9 +32,9 @@ import Dhall.Freeze (Intent(..), Scope(..)) import Dhall.Import (Imported(..), Depends(..), SemanticCacheMode(..), _semanticCacheMode) import Dhall.Parser (Src)-import Dhall.Pretty (Ann, CharacterSet(..), annToAnsiStyle, layoutOpts)+import Dhall.Pretty (Ann, CharacterSet(..), annToAnsiStyle) import Dhall.TypeCheck (Censored(..), DetailedTypeError(..), TypeError)-import Dhall.Util (Censor(..), Input(..), Output(..))+import Dhall.Util (Censor(..), Header (..), Input(..), Output(..)) import Dhall.Version (dhallVersionString) import Options.Applicative (Parser, ParserInfo) import System.Exit (ExitCode, exitFailure)@@ -44,17 +44,18 @@ import qualified Codec.CBOR.JSON import qualified Codec.CBOR.Read import qualified Codec.CBOR.Write-import qualified Codec.Serialise import qualified Control.Exception import qualified Control.Monad.Trans.State.Strict          as State import qualified Data.Aeson import qualified Data.Aeson.Encode.Pretty import qualified Data.ByteString.Lazy import qualified Data.ByteString.Lazy.Char8+import qualified Data.Map import qualified Data.Text import qualified Data.Text.IO import qualified Data.Text.Prettyprint.Doc                 as Pretty import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty+import qualified Data.Text.Prettyprint.Doc.Render.Text     as Pretty.Text import qualified Dhall import qualified Dhall.Binary import qualified Dhall.Core@@ -64,6 +65,7 @@ import qualified Dhall.Import import qualified Dhall.Import.Types import qualified Dhall.Lint+import qualified Dhall.Map import qualified Dhall.Tags import qualified Dhall.Pretty import qualified Dhall.Repl@@ -71,12 +73,13 @@ import qualified Dhall.Util import qualified GHC.IO.Encoding import qualified Options.Applicative+import qualified System.AtomicWrite.Writer.LazyText        as AtomicWrite.LazyText import qualified System.Console.ANSI import qualified System.Exit                               as Exit import qualified System.IO import qualified System.FilePath import qualified Text.Dot-import qualified Data.Map+import qualified Text.Pretty.Simple  -- | Top-level program options data Options = Options@@ -130,6 +133,7 @@     | Encode { file :: Input, json :: Bool }     | Decode { file :: Input, json :: Bool }     | Text { file :: Input }+    | SyntaxTree { file :: Input }  data ResolveMode     = Dot@@ -158,11 +162,12 @@         f True  = Censor         f False = NoCensor -subcommand :: String -> String -> Parser a -> Parser a-subcommand name description parser =+subcommand' :: Bool -> String -> String -> Parser a -> Parser a+subcommand' internal name description parser =     Options.Applicative.hsubparser         (   Options.Applicative.command name parserInfo         <>  Options.Applicative.metavar name+        <>  if internal then Options.Applicative.internal else mempty         )   where     parserInfo =@@ -171,6 +176,12 @@             <>  Options.Applicative.progDesc description             ) +subcommand :: String -> String -> Parser a -> Parser a+subcommand = subcommand' False++internalSubcommand :: String -> String -> Parser a -> Parser a+internalSubcommand = subcommand' True+ parseMode :: Parser Mode parseMode =         subcommand@@ -229,6 +240,10 @@             "text"             "Render a Dhall expression that evaluates to a Text literal"             (Text <$> parseFile)+    <|> internalSubcommand+            "haskell-syntax-tree"+            "Output the parsed syntax tree (for debugging)"+            (SyntaxTree <$> parseFile)     <|> (   Default         <$> parseFile         <*> parseOutput@@ -308,7 +323,7 @@           Options.Applicative.flag' (Just ListTransitiveDependencies)               (   Options.Applicative.long "transitive-dependencies"               <>  Options.Applicative.help-                    "List transitive import dependencies"+                    "List transitive import dependencies in post-order"               )         <|> pure Nothing @@ -470,7 +485,7 @@      let renderDoc :: Handle -> Doc Ann -> IO ()         renderDoc h doc = do-            let stream = Pretty.layoutSmart layoutOpts doc+            let stream = Dhall.Pretty.layout doc              supportsANSI <- System.Console.ANSI.hSupportsANSI h             let ansiStream =@@ -487,6 +502,12 @@              renderDoc h doc +    let writeDocToFile :: FilePath -> Doc ann -> IO ()+        writeDocToFile file doc = do+            let stream = Dhall.Pretty.layout (doc <> "\n")++            AtomicWrite.LazyText.atomicWriteFile file (Pretty.Text.renderLazy stream)+     when (not $ ignoreSemanticCache mode) Dhall.Import.warnAboutMissingCaches      handle $ case mode of@@ -521,8 +542,11 @@              case output of                 StandardOutput -> render System.IO.stdout annotatedExpression+                 OutputFile file_ ->-                    System.IO.withFile file_ System.IO.WriteMode $ \h -> render h annotatedExpression+                    writeDocToFile+                        file_+                        (Dhall.Pretty.prettyCharacterSet characterSet annotatedExpression)          Resolve { resolveMode = Just Dot, ..} -> do             expression <- getExpression file@@ -571,7 +595,8 @@                           .   Dhall.Core.importType                           .   Dhall.Core.importHashed                           .   Dhall.Import.chainedImport )-                 .   Data.Map.keys+                 .   reverse+                 .   Dhall.Map.keys                  $   _cache          Resolve { resolveMode = Nothing, ..} -> do@@ -650,32 +675,22 @@             Data.Text.IO.putStrLn (Dhall.Import.hashExpressionToCode normalizedExpression)          Lint {..} -> do-            (header, expression) <- getExpressionAndHeader inplace--            case inplace of-                InputFile file -> do-                    let lintedExpression = Dhall.Lint.lint expression--                    let doc =   Pretty.pretty header-                            <>  Dhall.Pretty.prettyCharacterSet characterSet lintedExpression+            (Header header, expression) <- getExpressionAndHeader inplace -                    System.IO.withFile file System.IO.WriteMode (\h -> do-                        renderDoc h doc )+            let lintedExpression = Dhall.Lint.lint expression -                StandardInput -> do-                    let lintedExpression = Dhall.Lint.lint expression+            let doc =   Pretty.pretty header+                    <>  Dhall.Pretty.prettyCharacterSet characterSet lintedExpression -                    let doc =   Pretty.pretty header-                            <>  Dhall.Pretty.prettyCharacterSet characterSet lintedExpression+            case inplace of+                InputFile file -> writeDocToFile file doc -                    renderDoc System.IO.stdout doc+                StandardInput -> renderDoc System.IO.stdout doc          Encode {..} -> do             expression <- getExpression file -            let term = Dhall.Binary.encodeExpression expression--            let bytes = Codec.Serialise.serialise term+            let bytes = Dhall.Binary.encodeExpression (Dhall.Core.denote expression)              if json                 then do@@ -696,7 +711,7 @@                     InputFile f   -> Data.ByteString.Lazy.readFile f                     StandardInput -> Data.ByteString.Lazy.getContents -            term <- do+            expression <- do                 if json                     then do                         value <- case Data.Aeson.eitherDecode' bytes of@@ -705,15 +720,14 @@                          let encoding = Codec.CBOR.JSON.encodeValue value -                        let cborBytes = Codec.CBOR.Write.toLazyByteString encoding-                        Dhall.Core.throws (Codec.Serialise.deserialiseOrFail cborBytes)+                        let cborgBytes = Codec.CBOR.Write.toLazyByteString encoding++                        Dhall.Core.throws (Dhall.Binary.decodeExpression cborgBytes)                     else do-                        Dhall.Core.throws (Codec.Serialise.deserialiseOrFail bytes)+                        Dhall.Core.throws (Dhall.Binary.decodeExpression bytes) -            expression <- Dhall.Core.throws (Dhall.Binary.decodeExpression term)-                :: IO (Expr Src Import) -            let doc = Dhall.Pretty.prettyCharacterSet characterSet expression+            let doc = Dhall.Pretty.prettyCharacterSet characterSet (Dhall.Core.renote expression :: Expr Src Import)              renderDoc System.IO.stdout doc @@ -731,13 +745,13 @@                 Dhall.Core.TextLit (Dhall.Core.Chunks [] text) -> do                     Data.Text.IO.putStr text                 _ -> do-                    let invalidTypeExpected :: Expr Void Void-                        invalidTypeExpected = Dhall.Core.Text+                    let invalidDecoderExpected :: Expr Void Void+                        invalidDecoderExpected = Dhall.Core.Text -                    let invalidTypeExpression :: Expr Void Void-                        invalidTypeExpression = normalizedExpression+                    let invalidDecoderExpression :: Expr Void Void+                        invalidDecoderExpression = normalizedExpression -                    Control.Exception.throwIO (Dhall.InvalidType {..})+                    Control.Exception.throwIO (Dhall.InvalidDecoder {..})          Tags {..} -> do             tags <- Dhall.Tags.generate input suffixes followSymlinks@@ -747,7 +761,14 @@                     System.IO.withFile file System.IO.WriteMode (`Data.Text.IO.hPutStr` tags)                  StandardOutput -> Data.Text.IO.putStrLn tags-            ++        SyntaxTree {..} -> do+            expression <- getExpression file++            let denoted :: Expr Void Import+                denoted = Dhall.Core.denote expression++            Text.Pretty.Simple.pPrintNoColor denoted  -- | Entry point for the @dhall@ executable main :: IO ()

src/Dhall/Map.hs view

@@ -13,6 +13,7 @@       Map        -- * Construction+    , empty     , singleton     , fromList     , fromListWithKey@@ -33,6 +34,7 @@     , delete     , filter     , restrictKeys+    , withoutKeys     , mapMaybe        -- * Query@@ -58,6 +60,7 @@        -- * Conversions     , toList+    , toAscList     , toMap     , keys     , keysSet@@ -124,6 +127,9 @@   length m = size m   {-# INLINABLE length #-} +  null (Map m _) = null m+  {-# INLINABLE null #-}+ instance Ord k => Traversable (Map k) where   traverse f m = traverseWithKey (\_ v -> f v) m   {-# INLINABLE traverse #-}@@ -161,6 +167,10 @@      toList = Dhall.Map.toList +-- | Create an empty `Map`+empty :: Ord k => Map k v+empty = mempty+ {-| Create a `Map` from a single key-value pair  >>> singleton "A" 1@@ -369,6 +379,23 @@     ks' = filterKeys (\k -> Data.Set.member k s) ks {-# INLINABLE restrictKeys #-} +{-| Remove all keys in a @"Data.Set".'Set'@ from a 'Map'++>>> withoutKeys (fromList [("A",1),("B",2)]) (Data.Set.fromList ["A"])+fromList [("B",2)]+-}+withoutKeys :: Ord k => Map k a -> Data.Set.Set k -> Map k a+withoutKeys (Map m ks) s = Map m' ks'+  where+#if MIN_VERSION_containers(0,5,8)+    m' = Data.Map.withoutKeys m s+#else+    m' = Data.Map.filterWithKey (\k _ -> Data.Set.notMember k s) m+#endif++    ks' = filterKeys (\k -> Data.Set.notMember k s) ks+{-# INLINABLE withoutKeys #-}+ {-| Transform all values in a `Map` using the supplied function, deleting the     key if the function returns `Nothing` @@ -630,6 +657,12 @@ toList (Map m Sorted)        = Data.Map.toList m toList (Map m (Original ks)) = fmap (\k -> (k, m Data.Map.! k)) ks {-# INLINABLE toList #-}++{-| Convert a `Map` to a list of key-value pairs in ascending order of keys+-}+toAscList :: Map k v -> [(k, v)]+toAscList (Map m _) = Data.Map.toAscList m+{-# INLINABLE toAscList #-}  {-| Convert a @"Dhall.Map".`Map`@ to a @"Data.Map".`Data.Map.Map`@

+ src/Dhall/Normalize.hs view

@@ -0,0 +1,1239 @@+{-# LANGUAGE BangPatterns       #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RankNTypes         #-}++module Dhall.Normalize (+      alphaNormalize+    , normalize+    , normalizeWith+    , normalizeWithM+    , Normalizer+    , NormalizerM+    , ReifiedNormalizer (..)+    , judgmentallyEqual+    , subst+    , shift+    , isNormalized+    , isNormalizedWith+    , freeIn+    ) where++import Control.Applicative (empty)+import Data.Foldable+import Data.Functor.Identity (Identity(..))+import Data.Semigroup (Semigroup(..))+import Data.Sequence (ViewL(..), ViewR(..))+import Data.Traversable+import Dhall.Syntax (Expr(..), Var(..), Binding(Binding), Chunks(..), DhallDouble(..), Const(..))+import Instances.TH.Lift ()+import Prelude hiding (succ)++import qualified Data.Sequence+import qualified Data.Set+import qualified Data.Text+import qualified Dhall.Eval    as Eval+import qualified Dhall.Map+import qualified Dhall.Set+import qualified Dhall.Syntax  as Syntax++{-| Returns `True` if two expressions are α-equivalent and β-equivalent and+    `False` otherwise++    `judgmentallyEqual` can fail with an `error` if you compare ill-typed+    expressions+-}+judgmentallyEqual :: Eq a => Expr s a -> Expr t a -> Bool+judgmentallyEqual = Eval.judgmentallyEqual+{-# INLINE judgmentallyEqual #-}++{-| `shift` is used by both normalization and type-checking to avoid variable+    capture by shifting variable indices++    For example, suppose that you were to normalize the following expression:++> λ(a : Type) → λ(x : a) → (λ(y : a) → λ(x : a) → y) x++    If you were to substitute @y@ with @x@ without shifting any variable+    indices, then you would get the following incorrect result:++> λ(a : Type) → λ(x : a) → λ(x : a) → x  -- Incorrect normalized form++    In order to substitute @x@ in place of @y@ we need to `shift` @x@ by @1@ in+    order to avoid being misinterpreted as the @x@ bound by the innermost+    lambda.  If we perform that `shift` then we get the correct result:++> λ(a : Type) → λ(x : a) → λ(x : a) → x@1++    As a more worked example, suppose that you were to normalize the following+    expression:++>     λ(a : Type)+> →   λ(f : a → a → a)+> →   λ(x : a)+> →   λ(x : a)+> →   (λ(x : a) → f x x@1) x@1++    The correct normalized result would be:++>     λ(a : Type)+> →   λ(f : a → a → a)+> →   λ(x : a)+> →   λ(x : a)+> →   f x@1 x++    The above example illustrates how we need to both increase and decrease+    variable indices as part of substitution:++    * We need to increase the index of the outer @x\@1@ to @x\@2@ before we+      substitute it into the body of the innermost lambda expression in order+      to avoid variable capture.  This substitution changes the body of the+      lambda expression to @(f x\@2 x\@1)@++    * We then remove the innermost lambda and therefore decrease the indices of+      both @x@s in @(f x\@2 x\@1)@ to @(f x\@1 x)@ in order to reflect that one+      less @x@ variable is now bound within that scope++    Formally, @(shift d (V x n) e)@ modifies the expression @e@ by adding @d@ to+    the indices of all variables named @x@ whose indices are greater than+    @(n + m)@, where @m@ is the number of bound variables of the same name+    within that scope++    In practice, @d@ is always @1@ or @-1@ because we either:++    * increment variables by @1@ to avoid variable capture during substitution+    * decrement variables by @1@ when deleting lambdas after substitution++    @n@ starts off at @0@ when substitution begins and increments every time we+    descend into a lambda or let expression that binds a variable of the same+    name in order to avoid shifting the bound variables by mistake.+-}+shift :: Int -> Var -> Expr s a -> Expr s a+shift _ _ (Const a) = Const a+shift d (V x n) (Var (V x' n')) = Var (V x' n'')+  where+    n'' = if x == x' && n <= n' then n' + d else n'+shift d (V x n) (Lam x' _A b) = Lam x' _A' b'+  where+    _A' = shift d (V x n ) _A+    b'  = shift d (V x n') b+      where+        n' = if x == x' then n + 1 else n+shift d (V x n) (Pi x' _A _B) = Pi x' _A' _B'+  where+    _A' = shift d (V x n ) _A+    _B' = shift d (V x n') _B+      where+        n' = if x == x' then n + 1 else n+shift d v (App f a) = App f' a'+  where+    f' = shift d v f+    a' = shift d v a+shift d (V x n) (Let (Binding src0 f src1 mt src2 r) e) =+    Let (Binding src0 f src1 mt' src2 r') e'+  where+    e' = shift d (V x n') e+      where+        n' = if x == f then n + 1 else n++    mt' = fmap (fmap (shift d (V x n))) mt+    r'  =             shift d (V x n)  r+shift d v (Annot a b) = Annot a' b'+  where+    a' = shift d v a+    b' = shift d v b+shift _ _ Bool = Bool+shift _ _ (BoolLit a) = BoolLit a+shift d v (BoolAnd a b) = BoolAnd a' b'+  where+    a' = shift d v a+    b' = shift d v b+shift d v (BoolOr a b) = BoolOr a' b'+  where+    a' = shift d v a+    b' = shift d v b+shift d v (BoolEQ a b) = BoolEQ a' b'+  where+    a' = shift d v a+    b' = shift d v b+shift d v (BoolNE a b) = BoolNE a' b'+  where+    a' = shift d v a+    b' = shift d v b+shift d v (BoolIf a b c) = BoolIf a' b' c'+  where+    a' = shift d v a+    b' = shift d v b+    c' = shift d v c+shift _ _ Natural = Natural+shift _ _ (NaturalLit a) = NaturalLit a+shift _ _ NaturalFold = NaturalFold+shift _ _ NaturalBuild = NaturalBuild+shift _ _ NaturalIsZero = NaturalIsZero+shift _ _ NaturalEven = NaturalEven+shift _ _ NaturalOdd = NaturalOdd+shift _ _ NaturalToInteger = NaturalToInteger+shift _ _ NaturalShow = NaturalShow+shift _ _ NaturalSubtract = NaturalSubtract+shift d v (NaturalPlus a b) = NaturalPlus a' b'+  where+    a' = shift d v a+    b' = shift d v b+shift d v (NaturalTimes a b) = NaturalTimes a' b'+  where+    a' = shift d v a+    b' = shift d v b+shift _ _ Integer = Integer+shift _ _ (IntegerLit a) = IntegerLit a+shift _ _ IntegerClamp = IntegerClamp+shift _ _ IntegerNegate = IntegerNegate+shift _ _ IntegerShow = IntegerShow+shift _ _ IntegerToDouble = IntegerToDouble+shift _ _ Double = Double+shift _ _ (DoubleLit a) = DoubleLit a+shift _ _ DoubleShow = DoubleShow+shift _ _ Text = Text+shift d v (TextLit (Chunks a b)) = TextLit (Chunks a' b)+  where+    a' = fmap (fmap (shift d v)) a+shift d v (TextAppend a b) = TextAppend a' b'+  where+    a' = shift d v a+    b' = shift d v b+shift _ _ TextShow = TextShow+shift _ _ List = List+shift d v (ListLit a b) = ListLit a' b'+  where+    a' = fmap (shift d v) a+    b' = fmap (shift d v) b+shift _ _ ListBuild = ListBuild+shift d v (ListAppend a b) = ListAppend a' b'+  where+    a' = shift d v a+    b' = shift d v b+shift _ _ ListFold = ListFold+shift _ _ ListLength = ListLength+shift _ _ ListHead = ListHead+shift _ _ ListLast = ListLast+shift _ _ ListIndexed = ListIndexed+shift _ _ ListReverse = ListReverse+shift _ _ Optional = Optional+shift d v (Some a) = Some a'+  where+    a' = shift d v a+shift _ _ None = None+shift _ _ OptionalFold = OptionalFold+shift _ _ OptionalBuild = OptionalBuild+shift d v (Record a) = Record a'+  where+    a' = fmap (shift d v) a+shift d v (RecordLit a) = RecordLit a'+  where+    a' = fmap (shift d v) a+shift d v (Union a) = Union a'+  where+    a' = fmap (fmap (shift d v)) a+shift d v (Combine a b) = Combine a' b'+  where+    a' = shift d v a+    b' = shift d v b+shift d v (CombineTypes a b) = CombineTypes a' b'+  where+    a' = shift d v a+    b' = shift d v b+shift d v (Prefer a b) = Prefer a' b'+  where+    a' = shift d v a+    b' = shift d v b+shift d v (RecordCompletion a b) = RecordCompletion a' b'+  where+    a' = shift d v a+    b' = shift d v b+shift d v (Merge a b c) = Merge a' b' c'+  where+    a' =       shift d v  a+    b' =       shift d v  b+    c' = fmap (shift d v) c+shift d v (ToMap a b) = ToMap a' b'+  where+    a' =       shift d v  a+    b' = fmap (shift d v) b+shift d v (Field a b) = Field a' b+  where+    a' = shift d v a+shift d v (Assert a) = Assert a'+  where+    a' = shift d v a+shift d v (Equivalent a b) = Equivalent a' b'+  where+    a' = shift d v a+    b' = shift d v b+shift d v (Project a b) = Project a' b'+  where+    a' =       shift d v  a+    b' = fmap (shift d v) b+shift d v (Note a b) = Note a b'+  where+    b' = shift d v b+shift d v (ImportAlt a b) = ImportAlt a' b'+  where+    a' = shift d v a+    b' = shift d v b+-- The Dhall compiler enforces that all embedded values are closed expressions+-- and `shift` does nothing to a closed expression+shift _ _ (Embed p) = Embed p++{-| Substitute all occurrences of a variable with an expression++> subst x C B  ~  B[x := C]+-}+subst :: Var -> Expr s a -> Expr s a -> Expr s a+subst _ _ (Const a) = Const a+subst (V x n) e (Lam y _A b) = Lam y _A' b'+  where+    _A' = subst (V x n )                  e  _A+    b'  = subst (V x n') (shift 1 (V y 0) e)  b+    n'  = if x == y then n + 1 else n+subst (V x n) e (Pi y _A _B) = Pi y _A' _B'+  where+    _A' = subst (V x n )                  e  _A+    _B' = subst (V x n') (shift 1 (V y 0) e) _B+    n'  = if x == y then n + 1 else n+subst v e (App f a) = App f' a'+  where+    f' = subst v e f+    a' = subst v e a+subst v e (Var v') = if v == v' then e else Var v'+subst (V x n) e (Let (Binding src0 f src1 mt src2 r) b) =+    Let (Binding src0 f src1 mt' src2 r') b'+  where+    b' = subst (V x n') (shift 1 (V f 0) e) b+      where+        n' = if x == f then n + 1 else n++    mt' = fmap (fmap (subst (V x n) e)) mt+    r'  =             subst (V x n) e  r+subst x e (Annot a b) = Annot a' b'+  where+    a' = subst x e a+    b' = subst x e b+subst _ _ Bool = Bool+subst _ _ (BoolLit a) = BoolLit a+subst x e (BoolAnd a b) = BoolAnd a' b'+  where+    a' = subst x e a+    b' = subst x e b+subst x e (BoolOr a b) = BoolOr a' b'+  where+    a' = subst x e a+    b' = subst x e b+subst x e (BoolEQ a b) = BoolEQ a' b'+  where+    a' = subst x e a+    b' = subst x e b+subst x e (BoolNE a b) = BoolNE a' b'+  where+    a' = subst x e a+    b' = subst x e b+subst x e (BoolIf a b c) = BoolIf a' b' c'+  where+    a' = subst x e a+    b' = subst x e b+    c' = subst x e c+subst _ _ Natural = Natural+subst _ _ (NaturalLit a) = NaturalLit a+subst _ _ NaturalFold = NaturalFold+subst _ _ NaturalBuild = NaturalBuild+subst _ _ NaturalIsZero = NaturalIsZero+subst _ _ NaturalEven = NaturalEven+subst _ _ NaturalOdd = NaturalOdd+subst _ _ NaturalToInteger = NaturalToInteger+subst _ _ NaturalShow = NaturalShow+subst _ _ NaturalSubtract = NaturalSubtract+subst x e (NaturalPlus a b) = NaturalPlus a' b'+  where+    a' = subst x e a+    b' = subst x e b+subst x e (NaturalTimes a b) = NaturalTimes a' b'+  where+    a' = subst x e a+    b' = subst x e b+subst _ _ Integer = Integer+subst _ _ (IntegerLit a) = IntegerLit a+subst _ _ IntegerClamp = IntegerClamp+subst _ _ IntegerNegate = IntegerNegate+subst _ _ IntegerShow = IntegerShow+subst _ _ IntegerToDouble = IntegerToDouble+subst _ _ Double = Double+subst _ _ (DoubleLit a) = DoubleLit a+subst _ _ DoubleShow = DoubleShow+subst _ _ Text = Text+subst x e (TextLit (Chunks a b)) = TextLit (Chunks a' b)+  where+    a' = fmap (fmap (subst x e)) a+subst x e (TextAppend a b) = TextAppend a' b'+  where+    a' = subst x e a+    b' = subst x e b+subst _ _ TextShow = TextShow+subst _ _ List = List+subst x e (ListLit a b) = ListLit a' b'+  where+    a' = fmap (subst x e) a+    b' = fmap (subst x e) b+subst x e (ListAppend a b) = ListAppend a' b'+  where+    a' = subst x e a+    b' = subst x e b+subst _ _ ListBuild = ListBuild+subst _ _ ListFold = ListFold+subst _ _ ListLength = ListLength+subst _ _ ListHead = ListHead+subst _ _ ListLast = ListLast+subst _ _ ListIndexed = ListIndexed+subst _ _ ListReverse = ListReverse+subst _ _ Optional = Optional+subst x e (Some a) = Some a'+  where+    a' = subst x e a+subst _ _ None = None+subst _ _ OptionalFold = OptionalFold+subst _ _ OptionalBuild = OptionalBuild+subst x e (Record kts) = Record kts'+  where+    kts' = fmap (subst x e) kts+subst x e (RecordLit kvs) = RecordLit kvs'+  where+    kvs' = fmap (subst x e) kvs+subst x e (Union kts) = Union kts'+  where+    kts' = fmap (fmap (subst x e)) kts+subst x e (Combine a b) = Combine a' b'+  where+    a' = subst x e a+    b' = subst x e b+subst x e (CombineTypes a b) = CombineTypes a' b'+  where+    a' = subst x e a+    b' = subst x e b+subst x e (Prefer a b) = Prefer a' b'+  where+    a' = subst x e a+    b' = subst x e b+subst x e (RecordCompletion a b) = RecordCompletion a' b'+  where+    a' = subst x e a+    b' = subst x e b+subst x e (Merge a b c) = Merge a' b' c'+  where+    a' =       subst x e  a+    b' =       subst x e  b+    c' = fmap (subst x e) c+subst x e (ToMap a b) = ToMap a' b'+  where+    a' =       subst x e  a+    b' = fmap (subst x e) b+subst x e (Field a b) = Field a' b+  where+    a' = subst x e a+subst x e (Project a b) = Project a' b'+  where+    a' =       subst x e  a+    b' = fmap (subst x e) b+subst x e (Assert a) = Assert a'+  where+    a' = subst x e a+subst x e (Equivalent a b) = Equivalent a' b'+  where+    a' = subst x e a+    b' = subst x e b+subst x e (Note a b) = Note a b'+  where+    b' = subst x e b+subst x e (ImportAlt a b) = ImportAlt a' b'+  where+    a' = subst x e a+    b' = subst x e b+-- The Dhall compiler enforces that all embedded values are closed expressions+-- and `subst` does nothing to a closed expression+subst _ _ (Embed p) = Embed p++{-| This function is used to determine whether folds like @Natural/fold@ or+    @List/fold@ should be lazy or strict in their accumulator based on the type+    of the accumulator++    If this function returns `True`, then they will be strict in their+    accumulator since we can guarantee an upper bound on the amount of work to+    normalize the accumulator on each step of the loop.  If this function+    returns `False` then they will be lazy in their accumulator and only+    normalize the final result at the end of the fold+-}+boundedType :: Expr s a -> Bool+boundedType Bool             = True+boundedType Natural          = True+boundedType Integer          = True+boundedType Double           = True+boundedType Text             = True+boundedType (App List _)     = False+boundedType (App Optional t) = boundedType t+boundedType (Record kvs)     = all boundedType kvs+boundedType (Union kvs)      = all (all boundedType) kvs+boundedType _                = False++{-| α-normalize an expression by renaming all bound variables to @\"_\"@ and+    using De Bruijn indices to distinguish them++>>> alphaNormalize (Lam "a" (Const Type) (Lam "b" (Const Type) (Lam "x" "a" (Lam "y" "b" "x"))))+Lam "_" (Const Type) (Lam "_" (Const Type) (Lam "_" (Var (V "_" 1)) (Lam "_" (Var (V "_" 1)) (Var (V "_" 1)))))++    α-normalization does not affect free variables:++>>> alphaNormalize "x"+Var (V "x" 0)++-}+alphaNormalize :: Expr s a -> Expr s a+alphaNormalize = Eval.alphaNormalize+{-# INLINE alphaNormalize #-}++{-| Reduce an expression to its normal form, performing beta reduction++    `normalize` does not type-check the expression.  You may want to type-check+    expressions before normalizing them since normalization can convert an+    ill-typed expression into a well-typed expression.++    `normalize` can also fail with `error` if you normalize an ill-typed+    expression+-}+normalize :: Eq a => Expr s a -> Expr t a+normalize = Eval.normalize+{-# INLINE normalize #-}++{-| Reduce an expression to its normal form, performing beta reduction and applying+    any custom definitions.++    `normalizeWith` is designed to be used with function `typeWith`. The `typeWith`+    function allows typing of Dhall functions in a custom typing context whereas+    `normalizeWith` allows evaluating Dhall expressions in a custom context.++    To be more precise `normalizeWith` applies the given normalizer when it finds an+    application term that it cannot reduce by other means.++    Note that the context used in normalization will determine the properties of normalization.+    That is, if the functions in custom context are not total then the Dhall language, evaluated+    with those functions is not total either.++    `normalizeWith` can fail with an `error` if you normalize an ill-typed+    expression+-}+normalizeWith :: Eq a => Maybe (ReifiedNormalizer a) -> Expr s a -> Expr t a+normalizeWith (Just ctx) t = runIdentity (normalizeWithM (getReifiedNormalizer ctx) t)+normalizeWith _          t = Eval.normalize t++{-| This function generalizes `normalizeWith` by allowing the custom normalizer+    to use an arbitrary `Monad`++    `normalizeWithM` can fail with an `error` if you normalize an ill-typed+    expression+-}+normalizeWithM+    :: (Monad m, Eq a) => NormalizerM m a -> Expr s a -> m (Expr t a)+normalizeWithM ctx e0 = loop (Syntax.denote e0)+ where+ loop e =  case e of+    Const k -> pure (Const k)+    Var v -> pure (Var v)+    Lam x _A b -> Lam x <$> _A' <*> b'+      where+        _A' = loop _A+        b'  = loop b+    Pi x _A _B -> Pi x <$> _A' <*> _B'+      where+        _A' = loop _A+        _B' = loop _B+    App f a -> do+      res <- ctx (App f a)+      case res of+          Just e1 -> loop e1+          Nothing -> do+              f' <- loop f+              a' <- loop a+              case f' of+                Lam x _A b₀ -> do++                    let a₂ = shift 1 (V x 0) a'+                    let b₁ = subst (V x 0) a₂ b₀+                    let b₂ = shift (-1) (V x 0) b₁++                    loop b₂+                _ -> do+                  case App f' a' of+                    App NaturalFold (NaturalLit n) -> do+                        let natural = Var (V "natural" 0)+                        let go 0  x = x+                            go n' x = go (n'-1) (App (Var (V "succ" 0)) x)+                        let n' = go n (Var (V "zero" 0))+                        pure+                            (Lam "natural"+                                (Const Type)+                                (Lam "succ"+                                    (Pi "_" natural natural)+                                    (Lam "zero"+                                        natural+                                        n')))++                    App (App (App (App NaturalFold (NaturalLit n0)) t) succ') zero -> do+                      t' <- loop t+                      if boundedType t' then strict else lazy+                      where+                        strict =       strictLoop (fromIntegral n0 :: Integer)+                        lazy   = loop (  lazyLoop (fromIntegral n0 :: Integer))++                        strictLoop !0 = loop zero+                        strictLoop !n = App succ' <$> strictLoop (n - 1) >>= loop++                        lazyLoop !0 = zero+                        lazyLoop !n = App succ' (lazyLoop (n - 1))+                    App NaturalBuild g -> loop (App (App (App g Natural) succ) zero)+                      where+                        succ = Lam "n" Natural (NaturalPlus "n" (NaturalLit 1))++                        zero = NaturalLit 0+                    App NaturalIsZero (NaturalLit n) -> pure (BoolLit (n == 0))+                    App NaturalEven (NaturalLit n) -> pure (BoolLit (even n))+                    App NaturalOdd (NaturalLit n) -> pure (BoolLit (odd n))+                    App NaturalToInteger (NaturalLit n) -> pure (IntegerLit (toInteger n))+                    App NaturalShow (NaturalLit n) ->+                        pure (TextLit (Chunks [] (Data.Text.pack (show n))))+                    App (App NaturalSubtract (NaturalLit x)) (NaturalLit y)+                        | y >= x    -> pure (NaturalLit (subtract x y))+                        | otherwise -> pure (NaturalLit 0)+                    App (App NaturalSubtract (NaturalLit 0)) y -> pure y+                    App (App NaturalSubtract _) (NaturalLit 0) -> pure (NaturalLit 0)+                    App (App NaturalSubtract x) y | Eval.judgmentallyEqual x y -> pure (NaturalLit 0)+                    App IntegerClamp (IntegerLit n)+                        | 0 <= n -> pure (NaturalLit (fromInteger n))+                        | otherwise -> pure (NaturalLit 0)+                    App IntegerNegate (IntegerLit n) ->+                        pure (IntegerLit (negate n))+                    App IntegerShow (IntegerLit n)+                        | 0 <= n    -> pure (TextLit (Chunks [] ("+" <> Data.Text.pack (show n))))+                        | otherwise -> pure (TextLit (Chunks [] (Data.Text.pack (show n))))+                    -- `(read . show)` is used instead of `fromInteger` because `read` uses+                    -- the correct rounding rule.+                    -- See https://gitlab.haskell.org/ghc/ghc/issues/17231.+                    App IntegerToDouble (IntegerLit n) -> pure (DoubleLit ((DhallDouble . read . show) n))+                    App DoubleShow (DoubleLit (DhallDouble n)) ->+                        pure (TextLit (Chunks [] (Data.Text.pack (show n))))+                    App (App OptionalBuild _A₀) g ->+                        loop (App (App (App g optional) just) nothing)+                      where+                        optional = App Optional _A₀++                        just = Lam "a" _A₀ (Some "a")++                        nothing = App None _A₀+                    App (App ListBuild _A₀) g -> loop (App (App (App g list) cons) nil)+                      where+                        _A₁ = shift 1 "a" _A₀++                        list = App List _A₀++                        cons =+                            Lam "a" _A₀+                                (Lam "as"+                                    (App List _A₁)+                                    (ListAppend (ListLit Nothing (pure "a")) "as")+                                )++                        nil = ListLit (Just (App List _A₀)) empty+                    App (App ListFold t) (ListLit _ xs) -> do+                        t' <- loop t+                        let list = Var (V "list" 0)+                        let lam term =+                                Lam "list" (Const Type)+                                    (Lam "cons" (Pi "_" t' (Pi "_" list list))+                                        (Lam "nil" list term))+                        term <- foldrM+                            (\x acc -> do+                                x' <- loop x+                                pure (App (App (Var (V "cons" 0)) x') acc))+                            (Var (V "nil" 0))+                            xs+                        pure (lam term)+                    App (App (App (App (App ListFold _) (ListLit _ xs)) t) cons) nil -> do+                      t' <- loop t+                      if boundedType t' then strict else lazy+                      where+                        strict =       foldr strictCons strictNil xs+                        lazy   = loop (foldr   lazyCons   lazyNil xs)++                        strictNil = loop nil+                        lazyNil   =      nil++                        strictCons y ys = do+                          App (App cons y) <$> ys >>= loop+                        lazyCons   y ys =       App (App cons y) ys+                    App (App ListLength _) (ListLit _ ys) ->+                        pure (NaturalLit (fromIntegral (Data.Sequence.length ys)))+                    App (App ListHead t) (ListLit _ ys) -> loop o+                      where+                        o = case Data.Sequence.viewl ys of+                                y :< _ -> Some y+                                _      -> App None t+                    App (App ListLast t) (ListLit _ ys) -> loop o+                      where+                        o = case Data.Sequence.viewr ys of+                                _ :> y -> Some y+                                _      -> App None t+                    App (App ListIndexed _A₀) (ListLit _ as₀) -> loop (ListLit t as₁)+                      where+                        as₁ = Data.Sequence.mapWithIndex adapt as₀++                        _A₂ = Record (Dhall.Map.fromList kts)+                          where+                            kts = [ ("index", Natural)+                                  , ("value", _A₀)+                                  ]++                        t | null as₀  = Just (App List _A₂)+                          | otherwise = Nothing++                        adapt n a_ =+                            RecordLit (Dhall.Map.fromList kvs)+                          where+                            kvs = [ ("index", NaturalLit (fromIntegral n))+                                  , ("value", a_)+                                  ]+                    App (App ListReverse _) (ListLit t xs) ->+                        loop (ListLit t (Data.Sequence.reverse xs))++                    App (App OptionalFold t0) x0 -> do+                        t1 <- loop t0+                        let optional = Var (V "optional" 0)+                        let lam term = (Lam "optional"+                                           (Const Type)+                                           (Lam "some"+                                               (Pi "_" t1 optional)+                                               (Lam "none" optional term)))+                        x1 <- loop x0+                        pure $ case x1 of+                            App None _ -> lam (Var (V "none" 0))+                            Some x'    -> lam (App (Var (V "some" 0)) x')+                            _          -> App (App OptionalFold t1) x1++                    App TextShow (TextLit (Chunks [] oldText)) ->+                        loop (TextLit (Chunks [] newText))+                      where+                        newText = Eval.textShow oldText+                    _ -> do+                        res2 <- ctx (App f' a')+                        case res2 of+                            Nothing -> pure (App f' a')+                            Just app' -> loop app'+    Let (Binding _ f _ _ _ r) b -> loop b''+      where+        r'  = shift   1  (V f 0) r+        b'  = subst (V f 0) r' b+        b'' = shift (-1) (V f 0) b'+    Annot x _ -> loop x+    Bool -> pure Bool+    BoolLit b -> pure (BoolLit b)+    BoolAnd x y -> decide <$> loop x <*> loop y+      where+        decide (BoolLit True )  r              = r+        decide (BoolLit False)  _              = BoolLit False+        decide  l              (BoolLit True ) = l+        decide  _              (BoolLit False) = BoolLit False+        decide  l               r+            | Eval.judgmentallyEqual l r = l+            | otherwise                  = BoolAnd l r+    BoolOr x y -> decide <$> loop x <*> loop y+      where+        decide (BoolLit False)  r              = r+        decide (BoolLit True )  _              = BoolLit True+        decide  l              (BoolLit False) = l+        decide  _              (BoolLit True ) = BoolLit True+        decide  l               r+            | Eval.judgmentallyEqual l r = l+            | otherwise                  = BoolOr l r+    BoolEQ x y -> decide <$> loop x <*> loop y+      where+        decide (BoolLit True )  r              = r+        decide  l              (BoolLit True ) = l+        decide  l               r+            | Eval.judgmentallyEqual l r = BoolLit True+            | otherwise                  = BoolEQ l r+    BoolNE x y -> decide <$> loop x <*> loop y+      where+        decide (BoolLit False)  r              = r+        decide  l              (BoolLit False) = l+        decide  l               r+            | Eval.judgmentallyEqual l r = BoolLit False+            | otherwise                  = BoolNE l r+    BoolIf bool true false -> decide <$> loop bool <*> loop true <*> loop false+      where+        decide (BoolLit True )  l              _              = l+        decide (BoolLit False)  _              r              = r+        decide  b              (BoolLit True) (BoolLit False) = b+        decide  b               l              r+            | Eval.judgmentallyEqual l r = l+            | otherwise                  = BoolIf b l r+    Natural -> pure Natural+    NaturalLit n -> pure (NaturalLit n)+    NaturalFold -> pure NaturalFold+    NaturalBuild -> pure NaturalBuild+    NaturalIsZero -> pure NaturalIsZero+    NaturalEven -> pure NaturalEven+    NaturalOdd -> pure NaturalOdd+    NaturalToInteger -> pure NaturalToInteger+    NaturalShow -> pure NaturalShow+    NaturalSubtract -> pure NaturalSubtract+    NaturalPlus x y -> decide <$> loop x <*> loop y+      where+        decide (NaturalLit 0)  r             = r+        decide  l             (NaturalLit 0) = l+        decide (NaturalLit m) (NaturalLit n) = NaturalLit (m + n)+        decide  l              r             = NaturalPlus l r+    NaturalTimes x y -> decide <$> loop x <*> loop y+      where+        decide (NaturalLit 1)  r             = r+        decide  l             (NaturalLit 1) = l+        decide (NaturalLit 0)  _             = NaturalLit 0+        decide  _             (NaturalLit 0) = NaturalLit 0+        decide (NaturalLit m) (NaturalLit n) = NaturalLit (m * n)+        decide  l              r             = NaturalTimes l r+    Integer -> pure Integer+    IntegerLit n -> pure (IntegerLit n)+    IntegerClamp -> pure IntegerClamp+    IntegerNegate -> pure IntegerNegate+    IntegerShow -> pure IntegerShow+    IntegerToDouble -> pure IntegerToDouble+    Double -> pure Double+    DoubleLit n -> pure (DoubleLit n)+    DoubleShow -> pure DoubleShow+    Text -> pure Text+    TextLit (Chunks xys z) -> do+        chunks' <- mconcat <$> chunks+        case chunks' of+            Chunks [("", x)] "" -> pure x+            c                   -> pure (TextLit c)+      where+        chunks =+          ((++ [Chunks [] z]) . concat) <$> traverse process xys++        process (x, y) = do+          y' <- loop y+          case y' of+            TextLit c -> pure [Chunks [] x, c]+            _         -> pure [Chunks [(x, y')] mempty]+    TextAppend x y -> loop (TextLit (Chunks [("", x), ("", y)] ""))+    TextShow -> pure TextShow+    List -> pure List+    ListLit t es+        | Data.Sequence.null es -> ListLit <$> t' <*> pure Data.Sequence.empty+        | otherwise             -> ListLit Nothing <$> es'+      where+        t'  = traverse loop t+        es' = traverse loop es+    ListAppend x y -> decide <$> loop x <*> loop y+      where+        decide (ListLit _ m)  r            | Data.Sequence.null m = r+        decide  l            (ListLit _ n) | Data.Sequence.null n = l+        decide (ListLit t m) (ListLit _ n)                        = ListLit t (m <> n)+        decide  l             r                                   = ListAppend l r+    ListBuild -> pure ListBuild+    ListFold -> pure ListFold+    ListLength -> pure ListLength+    ListHead -> pure ListHead+    ListLast -> pure ListLast+    ListIndexed -> pure ListIndexed+    ListReverse -> pure ListReverse+    Optional -> pure Optional+    Some a -> Some <$> a'+      where+        a' = loop a+    None -> pure None+    OptionalFold -> pure OptionalFold+    OptionalBuild -> pure OptionalBuild+    Record kts -> Record . Dhall.Map.sort <$> kts'+      where+        kts' = traverse loop kts+    RecordLit kvs -> RecordLit . Dhall.Map.sort <$> kvs'+      where+        kvs' = traverse loop kvs+    Union kts -> Union . Dhall.Map.sort <$> kts'+      where+        kts' = traverse (traverse loop) kts+    Combine x y -> decide <$> loop x <*> loop y+      where+        decide (RecordLit m) r | Data.Foldable.null m =+            r+        decide l (RecordLit n) | Data.Foldable.null n =+            l+        decide (RecordLit m) (RecordLit n) =+            RecordLit (Dhall.Map.unionWith decide m n)+        decide l r =+            Combine l r+    CombineTypes x y -> decide <$> loop x <*> loop y+      where+        decide (Record m) r | Data.Foldable.null m =+            r+        decide l (Record n) | Data.Foldable.null n =+            l+        decide (Record m) (Record n) =+            Record (Dhall.Map.unionWith decide m n)+        decide l r =+            CombineTypes l r+    Prefer x y -> decide <$> loop x <*> loop y+      where+        decide (RecordLit m) r | Data.Foldable.null m =+            r+        decide l (RecordLit n) | Data.Foldable.null n =+            l+        decide (RecordLit m) (RecordLit n) =+            RecordLit (Dhall.Map.union n m)+        decide l r | Eval.judgmentallyEqual l r =+            l+        decide l r =+            Prefer l r+    RecordCompletion x y -> do+        loop (Annot (Prefer (Field x "default") y) (Field x "Type"))+    Merge x y t      -> do+        x' <- loop x+        y' <- loop y+        case x' of+            RecordLit kvsX ->+                case y' of+                    Field (Union ktsY) kY ->+                        case Dhall.Map.lookup kY ktsY of+                            Just Nothing ->+                                case Dhall.Map.lookup kY kvsX of+                                    Just vX -> return vX+                                    Nothing -> Merge x' y' <$> t'+                            _ ->+                                Merge x' y' <$> t'+                    App (Field (Union ktsY) kY) vY ->+                        case Dhall.Map.lookup kY ktsY of+                            Just (Just _) ->+                                case Dhall.Map.lookup kY kvsX of+                                    Just vX -> loop (App vX vY)+                                    Nothing -> Merge x' y' <$> t'+                            _ ->+                                Merge x' y' <$> t'+                    _ -> Merge x' y' <$> t'+            _ -> Merge x' y' <$> t'+      where+        t' = traverse loop t+    ToMap x t        -> do+        x' <- loop x+        t' <- traverse loop t+        case x' of+            RecordLit kvsX -> do+                let entry (key, value) =+                        RecordLit+                            (Dhall.Map.fromList+                                [ ("mapKey"  , TextLit (Chunks [] key))+                                , ("mapValue", value                  )+                                ]+                            )++                let keyValues = Data.Sequence.fromList (map entry (Dhall.Map.toList kvsX))++                let listType = case t' of+                        Just _ | null keyValues ->+                            t'+                        _ ->+                            Nothing++                return (ListLit listType keyValues)+            _ -> do+                return (ToMap x' t')+    Field r x        -> do+        let singletonRecordLit v = RecordLit (Dhall.Map.singleton x v)++        r' <- loop r+        case r' of+            RecordLit kvs ->+                case Dhall.Map.lookup x kvs of+                    Just v  -> pure v+                    Nothing -> Field <$> (RecordLit <$> traverse loop kvs) <*> pure x+            Project r_ _ -> loop (Field r_ x)+            Prefer (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of+                Just v -> pure (Field (Prefer (singletonRecordLit v) r_) x)+                Nothing -> loop (Field r_ x)+            Prefer l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of+                Just v -> pure v+                Nothing -> loop (Field l x)+            Combine (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of+                Just v -> pure (Field (Combine (singletonRecordLit v) r_) x)+                Nothing -> loop (Field r_ x)+            Combine l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of+                Just v -> pure (Field (Combine l (singletonRecordLit v)) x)+                Nothing -> loop (Field l x)+            _ -> pure (Field r' x)+    Project x (Left fields)-> do+        x' <- loop x+        let fieldsSet = Dhall.Set.toSet fields+        case x' of+            RecordLit kvs ->+                pure (RecordLit (Dhall.Map.restrictKeys kvs fieldsSet))+            Project y _ ->+                loop (Project y (Left fields))+            Prefer l (RecordLit rKvs) -> do+                let rKs = Dhall.Map.keysSet rKvs+                let l' = Project l (Left (Dhall.Set.fromSet (Data.Set.difference fieldsSet rKs)))+                let r' = RecordLit (Dhall.Map.restrictKeys rKvs fieldsSet)+                loop (Prefer l' r')+            _ | null fields -> pure (RecordLit mempty)+              | otherwise   -> pure (Project x' (Left (Dhall.Set.sort fields)))+    Project r (Right e1) -> do+        e2 <- loop e1++        case e2 of+            Record kts -> do+                loop (Project r (Left (Dhall.Set.fromSet (Dhall.Map.keysSet kts))))+            _ -> do+                r' <- loop r+                pure (Project r' (Right e2))+    Assert t -> do+        t' <- loop t++        pure (Assert t')+    Equivalent l r -> do+        l' <- loop l+        r' <- loop r++        pure (Equivalent l' r')+    Note _ e' -> loop e'+    ImportAlt l _r -> loop l+    Embed a -> pure (Embed a)++-- | Use this to wrap you embedded functions (see `normalizeWith`) to make them+--   polymorphic enough to be used.+type NormalizerM m a = forall s. Expr s a -> m (Maybe (Expr s a))++-- | An variation on `NormalizerM` for pure normalizers+type Normalizer a = NormalizerM Identity a++-- | A reified 'Normalizer', which can be stored in structures without+-- running into impredicative polymorphism.+newtype ReifiedNormalizer a = ReifiedNormalizer+  { getReifiedNormalizer :: Normalizer a }++-- | Check if an expression is in a normal form given a context of evaluation.+--   Unlike `isNormalized`, this will fully normalize and traverse through the expression.+--+--   It is much more efficient to use `isNormalized`.+--+--  `isNormalizedWith` can fail with an `error` if you check an ill-typed+--  expression+isNormalizedWith :: (Eq s, Eq a) => Normalizer a -> Expr s a -> Bool+isNormalizedWith ctx e = e == normalizeWith (Just (ReifiedNormalizer ctx)) e++-- | Quickly check if an expression is in normal form+--+-- Given a well-typed expression @e@, @'isNormalized' e@ is equivalent to+-- @e == 'normalize' e@.+--+-- Given an ill-typed expression, 'isNormalized' may fail with an error, or+-- evaluate to either False or True!+isNormalized :: Eq a => Expr s a -> Bool+isNormalized e0 = loop (Syntax.denote e0)+  where+    loop e = case e of+      Const _ -> True+      Var _ -> True+      Lam _ a b -> loop a && loop b+      Pi _ a b -> loop a && loop b+      App f a -> loop f && loop a && case App f a of+          App (Lam _ _ _) _ -> False+          App (App (App (App NaturalFold (NaturalLit _)) _) _) _ -> False+          App NaturalFold (NaturalLit _) -> False+          App NaturalBuild _ -> False+          App NaturalIsZero (NaturalLit _) -> False+          App NaturalEven (NaturalLit _) -> False+          App NaturalOdd (NaturalLit _) -> False+          App NaturalShow (NaturalLit _) -> False+          App (App NaturalSubtract (NaturalLit _)) (NaturalLit _) -> False+          App (App NaturalSubtract (NaturalLit 0)) _ -> False+          App (App NaturalSubtract _) (NaturalLit 0) -> False+          App (App NaturalSubtract x) y -> not (Eval.judgmentallyEqual x y)+          App NaturalToInteger (NaturalLit _) -> False+          App IntegerNegate (IntegerLit _) -> False+          App IntegerClamp (IntegerLit _) -> False+          App IntegerShow (IntegerLit _) -> False+          App IntegerToDouble (IntegerLit _) -> False+          App DoubleShow (DoubleLit _) -> False+          App (App OptionalBuild _) _ -> False+          App (App ListBuild _) _ -> False+          App (App ListFold _) (ListLit _ _) -> False+          App (App ListLength _) (ListLit _ _) -> False+          App (App ListHead _) (ListLit _ _) -> False+          App (App ListLast _) (ListLit _ _) -> False+          App (App ListIndexed _) (ListLit _ _) -> False+          App (App ListReverse _) (ListLit _ _) -> False+          App (App OptionalFold _) (Some _) -> False+          App (App OptionalFold _) (App None _) -> False+          App TextShow (TextLit (Chunks [] _)) ->+              False+          _ -> True+      Let _ _ -> False+      Annot _ _ -> False+      Bool -> True+      BoolLit _ -> True+      BoolAnd x y -> loop x && loop y && decide x y+        where+          decide (BoolLit _)  _          = False+          decide  _          (BoolLit _) = False+          decide  l           r          = not (Eval.judgmentallyEqual l r)+      BoolOr x y -> loop x && loop y && decide x y+        where+          decide (BoolLit _)  _          = False+          decide  _          (BoolLit _) = False+          decide  l           r          = not (Eval.judgmentallyEqual l r)+      BoolEQ x y -> loop x && loop y && decide x y+        where+          decide (BoolLit True)  _             = False+          decide  _             (BoolLit True) = False+          decide  l              r             = not (Eval.judgmentallyEqual l r)+      BoolNE x y -> loop x && loop y && decide x y+        where+          decide (BoolLit False)  _               = False+          decide  _              (BoolLit False ) = False+          decide  l               r               = not (Eval.judgmentallyEqual l r)+      BoolIf x y z ->+          loop x && loop y && loop z && decide x y z+        where+          decide (BoolLit _)  _              _              = False+          decide  _          (BoolLit True) (BoolLit False) = False+          decide  _           l              r              = not (Eval.judgmentallyEqual l r)+      Natural -> True+      NaturalLit _ -> True+      NaturalFold -> True+      NaturalBuild -> True+      NaturalIsZero -> True+      NaturalEven -> True+      NaturalOdd -> True+      NaturalShow -> True+      NaturalSubtract -> True+      NaturalToInteger -> True+      NaturalPlus x y -> loop x && loop y && decide x y+        where+          decide (NaturalLit 0)  _             = False+          decide  _             (NaturalLit 0) = False+          decide (NaturalLit _) (NaturalLit _) = False+          decide  _              _             = True+      NaturalTimes x y -> loop x && loop y && decide x y+        where+          decide (NaturalLit 0)  _             = False+          decide  _             (NaturalLit 0) = False+          decide (NaturalLit 1)  _             = False+          decide  _             (NaturalLit 1) = False+          decide (NaturalLit _) (NaturalLit _) = False+          decide  _              _             = True+      Integer -> True+      IntegerLit _ -> True+      IntegerClamp -> True+      IntegerNegate -> True+      IntegerShow -> True+      IntegerToDouble -> True+      Double -> True+      DoubleLit _ -> True+      DoubleShow -> True+      Text -> True+      TextLit (Chunks [("", _)] "") -> False+      TextLit (Chunks xys _) -> all (all check) xys+        where+          check y = loop y && case y of+              TextLit _ -> False+              _         -> True+      TextAppend _ _ -> False+      TextShow -> True+      List -> True+      ListLit t es -> all loop t && all loop es+      ListAppend x y -> loop x && loop y && decide x y+        where+          decide (ListLit _ m)  _            | Data.Sequence.null m = False+          decide  _            (ListLit _ n) | Data.Sequence.null n = False+          decide (ListLit _ _) (ListLit _ _)                        = False+          decide  _             _                                   = True+      ListBuild -> True+      ListFold -> True+      ListLength -> True+      ListHead -> True+      ListLast -> True+      ListIndexed -> True+      ListReverse -> True+      Optional -> True+      Some a -> loop a+      None -> True+      OptionalFold -> True+      OptionalBuild -> True+      Record kts -> Dhall.Map.isSorted kts && all loop kts+      RecordLit kvs -> Dhall.Map.isSorted kvs && all loop kvs+      Union kts -> Dhall.Map.isSorted kts && all (all loop) kts+      Combine x y -> loop x && loop y && decide x y+        where+          decide (RecordLit m) _ | Data.Foldable.null m = False+          decide _ (RecordLit n) | Data.Foldable.null n = False+          decide (RecordLit _) (RecordLit _) = False+          decide  _ _ = True+      CombineTypes x y -> loop x && loop y && decide x y+        where+          decide (Record m) _ | Data.Foldable.null m = False+          decide _ (Record n) | Data.Foldable.null n = False+          decide (Record _) (Record _) = False+          decide  _ _ = True+      Prefer x y -> loop x && loop y && decide x y+        where+          decide (RecordLit m) _ | Data.Foldable.null m = False+          decide _ (RecordLit n) | Data.Foldable.null n = False+          decide (RecordLit _) (RecordLit _) = False+          decide l r = not (Eval.judgmentallyEqual l r)+      RecordCompletion _ _ -> False+      Merge x y t -> loop x && loop y && all loop t+      ToMap x t -> case x of+          RecordLit _ -> False+          _ -> loop x && all loop t+      Field r k -> case r of+          RecordLit _ -> False+          Project _ _ -> False+          Prefer (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r+          Prefer _ (RecordLit _) -> False+          Combine (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r+          Combine _ (RecordLit m) -> Dhall.Map.keys m == [k] && loop r+          _ -> loop r+      Project r p -> loop r &&+          case p of+              Left s -> case r of+                  RecordLit _ -> False+                  Project _ _ -> False+                  Prefer _ (RecordLit _) -> False+                  _ -> not (Dhall.Set.null s) && Dhall.Set.isSorted s+              Right e' -> case e' of+                  Record _ -> False+                  _ -> loop e'+      Assert t -> loop t+      Equivalent l r -> loop l && loop r+      Note _ e' -> loop e'+      ImportAlt _ _ -> False+      Embed _ -> True++{-| Detect if the given variable is free within the given expression++>>> "x" `freeIn` "x"+True+>>> "x" `freeIn` "y"+False+>>> "x" `freeIn` Lam "x" (Const Type) "x"+False+-}+freeIn :: Eq a => Var -> Expr s a -> Bool+variable@(V var i) `freeIn` expression =+    subst variable (Var (V var (i + 1))) strippedExpression+      /= strippedExpression+  where+    denote' :: Expr t b -> Expr () b+    denote' = Syntax.denote++    strippedExpression = denote' expression

src/Dhall/Parser.hs view

@@ -8,11 +8,13 @@       exprFromText     , exprAndHeaderFromText     , censor+    , createHeader      -- * Parsers     , expr, exprA      -- * Types+    , Header(..)     , Src(..)     , SourcedException(..)     , ParseError(..)@@ -23,7 +25,7 @@ import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import Data.Void (Void)-import Dhall.Core+import Dhall.Syntax import Dhall.Src (Src(..)) import Prelude hiding (const, pi) import Text.Megaparsec (ParseErrorBundle(..), PosState(..))@@ -34,7 +36,7 @@ import qualified Text.Megaparsec  import Dhall.Parser.Combinators-import Dhall.Parser.Token+import Dhall.Parser.Token hiding (text) import Dhall.Parser.Expression  -- | Parser for a top-level Dhall expression@@ -48,11 +50,7 @@  -- | A parsing error data ParseError = ParseError {-#if MIN_VERSION_megaparsec(7, 0, 0)       unwrap :: Text.Megaparsec.ParseErrorBundle Text Void-#else-      unwrap :: Text.Megaparsec.ParseError Char Void-#endif     , input  :: Text     } @@ -76,11 +74,7 @@  instance Show ParseError where     show (ParseError {..}) =-#if MIN_VERSION_megaparsec(7, 0, 0)       "\n\ESC[1;31mError\ESC[0m: Invalid input\n\n" <> Text.Megaparsec.errorBundlePretty unwrap-#else-      "\n\ESC[1;31mError\ESC[0m: Invalid input\n\n" <> Text.Megaparsec.parseErrorPretty unwrap-#endif  instance Exception ParseError @@ -92,6 +86,17 @@   -> Either ParseError (Expr Src Import) exprFromText delta text = fmap snd (exprAndHeaderFromText delta text) +-- | A header corresponds to the leading comment at the top of a Dhall file.+--+-- The header includes comment characters but is stripped of leading spaces and+-- trailing newlines+newtype Header = Header Text deriving Show++-- | Create a header with stripped leading spaces and trailing newlines+createHeader :: Text -> Header+createHeader =+    Header . Data.Text.dropWhile Data.Char.isSpace . Data.Text.dropWhileEnd (/= '\n')+ {-| Like `exprFromText` but also returns the leading comments and whitespace     (i.e. header) up to the last newline before the code begins @@ -108,10 +113,10 @@     :: String -- ^ User-friendly name describing the input expression,               --   used in parsing error messages     -> Text   -- ^ Input expression to parse-    -> Either ParseError (Text, Expr Src Import)+    -> Either ParseError (Header, Expr Src Import) exprAndHeaderFromText delta text = case result of     Left errInfo   -> Left (ParseError { unwrap = errInfo, input = text })-    Right (txt, r) -> Right (stripHeader txt, r)+    Right (txt, r) -> Right (createHeader txt, r)   where     parser = do         (bytes, _) <- Text.Megaparsec.match whitespace@@ -120,5 +125,3 @@         return (bytes, r)      result = Text.Megaparsec.parse (unParser parser) delta text--    stripHeader = Data.Text.dropWhile Data.Char.isSpace . Data.Text.dropWhileEnd (/= '\n')

src/Dhall/Parser/Combinators.hs view

@@ -24,15 +24,11 @@ import qualified Data.Char import qualified Data.Set import qualified Data.Text-import qualified Data.Text.Prettyprint.Doc               as Pretty import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty import qualified Dhall.Map import qualified Dhall.Pretty import qualified Dhall.Set import qualified Text.Megaparsec-#if !MIN_VERSION_megaparsec(7, 0, 0)-import qualified Text.Megaparsec.Char as Text.Megaparsec (satisfy)-#endif import qualified Text.Megaparsec.Char import qualified Text.Parser.Char import qualified Text.Parser.Combinators@@ -49,7 +45,7 @@         <>  "\n"         <>  "\n"         <>  Pretty.renderString-                (Pretty.layoutPretty Dhall.Pretty.layoutOpts (pretty source))+                (Dhall.Pretty.layout (pretty source))  -- | Doesn't force the 'Text' part laxSrcEq :: Src -> Src -> Bool@@ -127,9 +123,13 @@     -- {-# INLINE mplus #-}  instance Text.Megaparsec.MonadParsec Void Text Parser where+#if MIN_VERSION_megaparsec(8, 0, 0)+    parseError e = Parser (Text.Megaparsec.parseError e)+#else     failure u e    = Parser (Text.Megaparsec.failure u e)      fancyFailure e = Parser (Text.Megaparsec.fancyFailure e)+#endif      label l (Parser p) = Parser (Text.Megaparsec.label l p) @@ -197,11 +197,7 @@    notChar = Text.Megaparsec.Char.char -#if MIN_VERSION_megaparsec(7, 0, 0)   anyChar = Text.Megaparsec.anySingle-#else-  anyChar = Text.Megaparsec.Char.anyChar-#endif    string = fmap Data.Text.unpack . Text.Megaparsec.Char.string . fromString

src/Dhall/Parser/Expression.hs view

@@ -10,11 +10,12 @@  import Control.Applicative (Alternative(..), optional) import Data.ByteArray.Encoding (Base(..))+import Data.Foldable (foldl') import Data.Functor (void) import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup (Semigroup(..)) import Data.Text (Text)-import Dhall.Core+import Dhall.Syntax import Dhall.Src (Src(..)) import Prelude hiding (const, pi) import Text.Parser.Combinators (choice, try, (<?>))@@ -31,10 +32,6 @@ import qualified Data.Text.Encoding import qualified Dhall.Crypto import qualified Text.Megaparsec-#if !MIN_VERSION_megaparsec(7, 0, 0)-import qualified Text.Megaparsec.Char    as Text.Megaparsec-#endif-import qualified Text.Parser.Char  import Dhall.Parser.Combinators import Dhall.Parser.Token@@ -43,31 +40,19 @@ getSourcePos :: Text.Megaparsec.MonadParsec e s m =>                 m Text.Megaparsec.SourcePos getSourcePos =-#if MIN_VERSION_megaparsec(7, 0, 0)     Text.Megaparsec.getSourcePos-#else-    Text.Megaparsec.getPosition-#endif {-# INLINE getSourcePos #-}  -- | Get the current source offset (in tokens) getOffset :: Text.Megaparsec.MonadParsec e s m => m Int-#if MIN_VERSION_megaparsec(7, 0, 0) getOffset = Text.Megaparsec.stateOffset <$> Text.Megaparsec.getParserState-#else-getOffset = Text.Megaparsec.stateTokensProcessed <$> Text.Megaparsec.getParserState-#endif {-# INLINE getOffset #-}  -- | Set the current source offset setOffset :: Text.Megaparsec.MonadParsec e s m => Int -> m ()-#if MIN_VERSION_megaparsec(7, 0, 0)-setOffset o = Text.Megaparsec.updateParserState $ \(Text.Megaparsec.State s _ pst) ->-  Text.Megaparsec.State s o pst-#else-setOffset o = Text.Megaparsec.updateParserState $ \(Text.Megaparsec.State s p _ stw) ->-  Text.Megaparsec.State s p o stw-#endif+setOffset o = Text.Megaparsec.updateParserState $ \state ->+    state+        { Text.Megaparsec.stateOffset = o } {-# INLINE setOffset #-}  {-| Wrap a `Parser` to still match the same text but return only the `Src`@@ -129,9 +114,7 @@ parsers :: Parser a -> Parsers a parsers embedded = Parsers {..}   where-    completeExpression_ = do-        whitespace-        expression+    completeExpression_ = whitespace *> expression <* whitespace      expression =         noted@@ -147,53 +130,65 @@       where         alternative0 = do             _lambda+            whitespace             _openParens+            whitespace             a <- label+            whitespace             _colon+            nonemptyWhitespace             b <- expression+            whitespace             _closeParens+            whitespace             _arrow+            whitespace             c <- expression             return (Lam a b c)          alternative1 = do-            _if+            try (_if *> nonemptyWhitespace)             a <- expression-            _then+            whitespace+            try (_then *> nonemptyWhitespace)             b <- expression-            _else+            whitespace+            try (_else *> nonemptyWhitespace)             c <- expression             return (BoolIf a b c)          alternative2 = do             let binding = do-                    _letOnly--                    src0 <- src nonemptyWhitespace+                    src0 <- try (_let *> src nonemptyWhitespace) -                    c <- labelOnly+                    c <- label                      src1 <- src whitespace                      d <- optional (do-                        _colonOnly+                        _colon                          src2 <- src nonemptyWhitespace                          e <- expression++                        whitespace+                         return (Just src2, e) ) -                    _equalOnly+                    _equal                      src3 <- src whitespace                      f <- expression +                    whitespace+                     return (Binding (Just src0) c (Just src1) d (Just src3) f)              as <- Data.List.NonEmpty.some1 binding -            _in+            try (_in *> nonemptyWhitespace)              b <- expression @@ -214,22 +209,27 @@             --     (Let y …             --       (Note …             --         (Let z …-            return (Dhall.Core.wrapInLets as b)+            return (Dhall.Syntax.wrapInLets as b)          alternative3 = do-            _forall-            _openParens+            try (_forall *> whitespace *> _openParens)+            whitespace             a <- label+            whitespace             _colon+            nonemptyWhitespace             b <- expression+            whitespace             _closeParens+            whitespace             _arrow+            whitespace             c <- expression             return (Pi a b c)          alternative4 = do-            _assert-            _colon+            try (_assert *> whitespace *> _colon)+            nonemptyWhitespace             a <- expression             return (Assert a) @@ -238,81 +238,78 @@              let alternative4A = do                     _arrow+                    whitespace                     b <- expression+                    whitespace                     return (Pi "_" a b)              let alternative4B = do                     _colon-+                    nonemptyWhitespace                     b <- expression-                     case shallowDenote a of-                        ListLit _ [] ->+                        ListLit Nothing [] ->                             return (ListLit (Just b) [])-                        Merge c d _ ->+                        Merge c d Nothing ->                             return (Merge c d (Just b))-                        ToMap c _ ->+                        ToMap c Nothing ->                             return (ToMap c (Just b))                         _ -> return (Annot a b)              alternative4A <|> alternative4B <|> pure a -    operatorExpression = precedence0Expression+    operatorExpression =+        foldr makeOperatorExpression applicationExpression operatorParsers -    makeOperatorExpression subExpression operatorParser =+    makeOperatorExpression operatorParser subExpression =             noted (do                 a <- subExpression-                b <- Text.Megaparsec.many $ do-                    op <- operatorParser-                    r  <- subExpression -                    return (\l -> l `op` r)-                return (foldl (\x f -> f x) a b) )--    precedence0Operator =-                ImportAlt   <$ _importAlt-            <|> BoolOr      <$ _or-            <|> TextAppend  <$ _textAppend-            <|> NaturalPlus <$ _plus-            <|> ListAppend  <$ _listAppend--    precedence1Operator =-                BoolAnd     <$ _and-            <|> Combine     <$ _combine--    precedence2Operator =-                CombineTypes <$ _combineTypes-            <|> Prefer       <$ _prefer-            <|> NaturalTimes <$ _times-            <|> BoolEQ       <$ _doubleEqual+                whitespace -    precedence3Operator-            =   BoolNE     <$ _notEqual-            <|> Equivalent <$ _equivalent+                b <- Text.Megaparsec.many $ do+                    op <- operatorParser -    precedence0Expression =-            makeOperatorExpression precedence1Expression precedence0Operator+                    r  <- subExpression -    precedence1Expression =-            makeOperatorExpression precedence2Expression precedence1Operator+                    whitespace -    precedence2Expression =-            makeOperatorExpression precedence3Expression precedence2Operator+                    return (\l -> l `op` r)+                return (foldl' (\x f -> f x) a b)) -    precedence3Expression =-            makeOperatorExpression applicationExpression precedence3Operator+    operatorParsers :: [Parser (Expr s a -> Expr s a -> Expr s a)]+    operatorParsers =+        [ ImportAlt    <$ _importAlt    <* nonemptyWhitespace+        , BoolOr       <$ _or           <* whitespace+        , NaturalPlus  <$ _plus         <* nonemptyWhitespace+        , TextAppend   <$ _textAppend   <* whitespace+        , ListAppend   <$ _listAppend   <* whitespace+        , BoolAnd      <$ _and          <* whitespace+        , Combine      <$ _combine      <* whitespace+        , Prefer       <$ _prefer       <* whitespace+        , CombineTypes <$ _combineTypes <* whitespace+        , NaturalTimes <$ _times        <* whitespace+        , BoolEQ       <$ _doubleEqual  <* whitespace+        , BoolNE       <$ _notEqual     <* whitespace+        , Equivalent   <$ _equivalent   <* whitespace+        ]      applicationExpression = do-            f <-    (do _Some; return Some)+            f <-    (Some <$ try (_Some <* nonemptyWhitespace))                 <|> return id             a <- noted importExpression_-            b <- Text.Megaparsec.many (noted importExpression_)-            return (foldl app (f a) b)+            bs <- Text.Megaparsec.many . try $ do+                (sep, _) <- Text.Megaparsec.match nonemptyWhitespace+                b <- importExpression_+                return (sep, b)+            return (foldl' app (f a) bs)           where-            app nL@(Note (Src before _ bytesL) _) nR@(Note (Src _ after bytesR) _) =-                Note (Src before after (bytesL <> bytesR)) (App nL nR)-            app nL nR =-                App nL nR+            app a (sep, b)+                | Note (Src left _ bytesL) _ <- a+                , Note (Src _ right bytesR) _ <- b+                = Note (Src left right (bytesL <> sep <> bytesR)) (App a b)+            app a (_, b) =+                App a b      importExpression_ = noted (choice [ alternative0, alternative1 ])           where@@ -326,8 +323,10 @@         a <- selectorExpression          mb <- optional (do-            _doubleColon+            try (whitespace *> _doubleColon) +            whitespace+             selectorExpression )          case mb of@@ -337,7 +336,7 @@     selectorExpression = noted (do             a <- primitiveExpression -            let recordType = _openParens *> expression <* _closeParens+            let recordType = _openParens *> whitespace *> expression <* whitespace <* _closeParens              let field               x  e = Field   e  x             let projectBySet        xs e = Project e (Left  xs)@@ -348,8 +347,8 @@                     <|> fmap projectBySet        labels                     <|> fmap projectByExpression recordType -            b <- Text.Megaparsec.many (try (do _dot; alternatives))-            return (foldl (\e k -> k e) a b) )+            b <- Text.Megaparsec.many (try (whitespace *> _dot *> whitespace *> alternatives))+            return (foldl' (\e k -> k e) a b) )      primitiveExpression =             noted@@ -365,8 +364,7 @@                     , alternative08                     , alternative37                     , alternative09--                    , builtin <?> "built-in expression"+                    , builtin                     ]                 )             <|> alternative38@@ -392,26 +390,31 @@             alternative04 = (do                 _openBrace -                _ <- optional _comma+                whitespace +                _ <- optional (_comma *> whitespace)+                 a <- recordTypeOrLiteral +                whitespace+                 _closeBrace -                return a ) <?> "record type or literal"+                return a ) <?> "literal"              alternative05 = unionType              alternative06 = listLiteral              alternative07 = do-                _merge+                try (_merge *> nonemptyWhitespace)                 a <- importExpression_+                nonemptyWhitespace                 b <- importExpression_ <?> "second argument to ❰merge❱"                 return (Merge a b Nothing)              alternative08 = do-                _toMap+                try (_toMap *> nonemptyWhitespace)                 a <- importExpression_                 return (ToMap a Nothing) @@ -453,7 +456,9 @@                             ]                     'I' ->                         choice-                            [ IntegerShow      <$ _IntegerShow+                            [ IntegerClamp     <$ _IntegerClamp+                            , IntegerNegate    <$ _IntegerNegate+                            , IntegerShow      <$ _IntegerShow                             , IntegerToDouble  <$ _IntegerToDouble                             , Integer          <$ _Integer                             ]@@ -499,7 +504,9 @@              alternative38 = do                 _openParens+                whitespace                 a <- expression+                whitespace                 _closeParens                 return a @@ -512,9 +519,9 @@                 ]           where             interpolation = do-                _ <- Text.Parser.Char.text "${"+                _ <- text "${"                 e <- completeExpression_-                _ <- Text.Parser.Char.char '}'+                _ <- char '}'                 return (Chunks [(mempty, e)] mempty)              unescapedCharacterFast = do@@ -528,11 +535,11 @@                     ) && c /= '$'              unescapedCharacterSlow = do-                _ <- Text.Parser.Char.char '$'+                _ <- char '$'                 return (Chunks [] "$")              escapedCharacter = do-                _ <- Text.Parser.Char.char '\\'+                _ <- char '\\'                 c <- choice                     [ quotationMark                     , dollarSign@@ -547,53 +554,60 @@                     ]                 return (Chunks [] (Data.Text.singleton c))               where-                quotationMark = Text.Parser.Char.char '"'+                quotationMark = char '"' -                dollarSign = Text.Parser.Char.char '$'+                dollarSign = char '$' -                backSlash = Text.Parser.Char.char '\\'+                backSlash = char '\\' -                forwardSlash = Text.Parser.Char.char '/'+                forwardSlash = char '/' -                backSpace = do _ <- Text.Parser.Char.char 'b'; return '\b'+                backSpace = do _ <- char 'b'; return '\b' -                formFeed = do _ <- Text.Parser.Char.char 'f'; return '\f'+                formFeed = do _ <- char 'f'; return '\f' -                lineFeed = do _ <- Text.Parser.Char.char 'n'; return '\n'+                lineFeed = do _ <- char 'n'; return '\n' -                carriageReturn = do _ <- Text.Parser.Char.char 'r'; return '\r'+                carriageReturn = do _ <- char 'r'; return '\r' -                tab = do _ <- Text.Parser.Char.char 't'; return '\t'+                tab = do _ <- char 't'; return '\t'                  unicode = do-                    _  <- Text.Parser.Char.char 'u';+                    _  <- char 'u';                      let toNumber = Data.List.foldl' (\x y -> x * 16 + y) 0 -                    let fourCharacterEscapeSequence =-                            fmap toNumber (Control.Monad.replicateM 4 hexNumber)+                    let fourCharacterEscapeSequence = do+                            ns <- Control.Monad.replicateM 4 hexNumber+                            +                            let number = toNumber ns +                            Control.Monad.guard (validCodepoint number)+                                <|> fail "Invalid Unicode code point"++                            return number+                     let bracedEscapeSequence = do-                            _  <- Text.Parser.Char.char '{'+                            _  <- char '{'                             ns <- some hexNumber                              let number = toNumber ns -                            Control.Monad.guard (number <= 0x10FFFF && validCodepoint (Char.chr number))+                            Control.Monad.guard (number <= 0x10FFFD && validCodepoint number)                                 <|> fail "Invalid Unicode code point" -                            _  <- Text.Parser.Char.char '}'+                            _  <- char '}' -                            return (toNumber ns)+                            return number                      n <- bracedEscapeSequence <|> fourCharacterEscapeSequence                      return (Char.chr n)      doubleQuotedLiteral = do-            _      <- Text.Parser.Char.char '"'+            _      <- char '"'             chunks <- Text.Megaparsec.many doubleQuotedChunk-            _      <- Text.Parser.Char.char '"'+            _      <- char '"'             return (mconcat chunks)      singleQuoteContinue =@@ -614,19 +628,19 @@                     return ("''" <> b)                  interpolation = do-                    _ <- Text.Parser.Char.text "${"+                    _ <- text "${"                     a <- completeExpression_-                    _ <- Text.Parser.Char.char '}'+                    _ <- char '}'                     b <- singleQuoteContinue                     return (Chunks [(mempty, a)] mempty <> b)                  escapeInterpolation = do-                    _ <- Text.Parser.Char.text "''${"+                    _ <- text "''${"                     b <- singleQuoteContinue                     return ("${" <> b)                  endLiteral = do-                    _ <- Text.Parser.Char.text "''"+                    _ <- text "''"                     return mempty                  unescapedCharacterFast = do@@ -650,25 +664,22 @@                     return (Chunks [] a <> b)                  tab = do-                    _ <- Text.Parser.Char.char '\t'+                    _ <- char '\t' <?> "tab"                     b <- singleQuoteContinue                     return ("\t" <> b)      singleQuoteLiteral = do-            _ <- Text.Parser.Char.text "''"+            _ <- text "''"             _ <- endOfLine             a <- singleQuoteContinue              return (toDoubleQuoted a)           where-            endOfLine =-                    void (Text.Parser.Char.char '\n'  )-                <|> void (Text.Parser.Char.text "\r\n")+            endOfLine = (void (char '\n') <|> void (text "\r\n")) <?> "newline"      textLiteral = (do             literal <- doubleQuotedLiteral <|> singleQuoteLiteral-            whitespace-            return (TextLit literal) ) <?> "text literal"+            return (TextLit literal) ) <?> "literal"      recordTypeOrLiteral =             choice@@ -688,28 +699,70 @@     nonEmptyRecordTypeOrLiteral = do             a <- anyLabel +            whitespace+             let nonEmptyRecordType = do                     _colon++                    nonemptyWhitespace+                     b <- expression++                    whitespace+                     e <- Text.Megaparsec.many (do                         _comma++                        whitespace+                         c <- anyLabel++                        whitespace+                         _colon++                        nonemptyWhitespace+                         d <- expression++                        whitespace+                         return (c, d) )+                     m <- toMap ((a, b) : e)+                     return (Record m)              let nonEmptyRecordLiteral = do                     _equal++                    whitespace+                     b <- expression++                    whitespace+                     e <- Text.Megaparsec.many (do                         _comma++                        whitespace+                         c <- anyLabel++                        whitespace+                         _equal++                        whitespace+                         d <- expression++                        whitespace+                         return (c, d) )+                     m <- toMap ((a, b) : e)+                     return (RecordLit m)              nonEmptyRecordType <|> nonEmptyRecordLiteral@@ -717,48 +770,53 @@     unionType = (do             _openAngle -            _ <- optional _bar+            whitespace +            _ <- optional (_bar *> whitespace)+             let unionTypeEntry = do                     a <- anyLabel-                    b <- optional (do _colon; expression)+                    whitespace+                    b <- optional (_colon *> nonemptyWhitespace *> expression <* whitespace)                     return (a, b) -            kvs <- Text.Megaparsec.sepBy unionTypeEntry _bar+            kvs <- Text.Megaparsec.sepBy unionTypeEntry (_bar *> whitespace)              m <- toMap kvs              _closeAngle -            return (Union m) ) <?> "union type"+            return (Union m) ) <?> "literal"      listLiteral = (do             _openBracket -            _ <- optional _comma+            whitespace -            a <- Text.Megaparsec.sepBy expression _comma+            _ <- optional (_comma *> whitespace) +            a <- Text.Megaparsec.sepBy (expression <* whitespace) (_comma *> whitespace)+             _closeBracket-            return (ListLit Nothing (Data.Sequence.fromList a)) ) <?> "list literal" +            return (ListLit Nothing (Data.Sequence.fromList a)) ) <?> "literal"+ {-| Parse an environment variable import      This corresponds to the @env@ rule from the official grammar -} env :: Parser ImportType env = do-    _ <- Text.Parser.Char.text "env:"+    _ <- text "env:"     a <- (alternative0 <|> alternative1)-    whitespace     return (Env a)   where     alternative0 = bashEnvironmentVariable      alternative1 = do-        _ <- Text.Parser.Char.char '"'+        _ <- char '"'         a <- posixEnvironmentVariable-        _ <- Text.Parser.Char.char '"'+        _ <- char '"'         return a  -- | Parse a local import without trailing whitespace@@ -801,7 +859,6 @@ local :: Parser ImportType local = do     a <- localOnly-    whitespace     return a  {-| Parse an HTTP(S) import@@ -811,9 +868,8 @@ http :: Parser ImportType http = do     url <- httpRaw-    whitespace     headers <- optional (do-        _using+        try (whitespace *> _using *> nonemptyWhitespace)         importExpression import_ )     return (Remote (url { headers })) @@ -845,10 +901,9 @@ -} importHash_ :: Parser Dhall.Crypto.SHA256Digest importHash_ = do-    _ <- Text.Parser.Char.text "sha256:"-    text <- count 64 (satisfy hexdig <?> "hex digit")-    whitespace-    let strictBytes16 = Data.Text.Encoding.encodeUtf8 text+    _ <- text "sha256:"+    t <- count 64 (satisfy hexdig <?> "hex digit")+    let strictBytes16 = Data.Text.Encoding.encodeUtf8 t     strictBytes <- case Data.ByteArray.Encoding.convertFromBase Base16 strictBytes16 of         Left  string      -> fail string         Right strictBytes -> return (strictBytes :: Data.ByteString.ByteString)@@ -863,7 +918,7 @@ importHashed_ :: Parser ImportHashed importHashed_ = do     importType <- importType_-    hash       <- optional importHash_+    hash       <- optional (try (nonemptyWhitespace *> importHash_))     return (ImportHashed {..})  {-| Parse an `Import`@@ -877,7 +932,8 @@     return (Import {..}) ) <?> "import"   where     alternative = do-      _as+      try (whitespace *> _as *> nonemptyWhitespace)+       (_Text >> pure RawText) <|> (_Location >> pure Location)  -- | Same as @Data.Text.splitOn@, except always returning a `NonEmpty` result

src/Dhall/Parser/Token.hs view

@@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}+ -- | 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 (@@ -9,8 +10,9 @@     bashEnvironmentVariable,     posixEnvironmentVariable,     ComponentType(..),+    text,+    char,     file_,-    labelOnly,     label,     anyLabel,     labels,@@ -26,7 +28,6 @@     _if,     _then,     _else,-    _letOnly,     _let,     _in,     _as,@@ -44,6 +45,8 @@     _NaturalToInteger,     _NaturalShow,     _NaturalSubtract,+    _IntegerClamp,+    _IntegerNegate,     _IntegerShow,     _IntegerToDouble,     _DoubleShow,@@ -70,7 +73,6 @@     _Kind,     _Sort,     _Location,-    _equalOnly,     _equal,     _or,     _plus,@@ -91,7 +93,6 @@     _comma,     _openParens,     _closeParens,-    _colonOnly,     _colon,     _at,     _equivalent,@@ -109,10 +110,11 @@ import           Dhall.Parser.Combinators  import Control.Applicative (Alternative(..), optional)+import Data.Bits ((.&.)) import Data.Functor (void) import Data.Semigroup (Semigroup(..)) import Data.Text (Text)-import Dhall.Core+import Dhall.Syntax import Dhall.Set (Set) import Prelude hiding (const, pi) import Text.Parser.Combinators (choice, try, (<?>))@@ -134,12 +136,14 @@  import qualified Text.Parser.Token --- | Returns `True` if the given `Char` is a valid Unicode codepoint-validCodepoint :: Char -> Bool+-- | Returns `True` if the given `Int` is a valid Unicode codepoint+validCodepoint :: Int -> Bool validCodepoint c =-    not (category == Char.Surrogate || category == Char.NotAssigned)+    not (category == Char.Surrogate +      || c .&. 0xFFFE == 0xFFFE +      || c .&. 0xFFFF == 0xFFFF)   where-    category = Char.generalCategory c+    category = Char.generalCategory (Char.chr c)  {-| Parse 0 or more whitespace characters (including comments) @@ -176,8 +180,8 @@  signPrefix :: Num a => Parser (a -> a) signPrefix = (do-    let positive = fmap (\_ -> id    ) (Text.Parser.Char.char '+')-    let negative = fmap (\_ -> negate) (Text.Parser.Char.char '-')+    let positive = fmap (\_ -> id    ) (char '+')+    let negative = fmap (\_ -> negate) (char '-')     positive <|> negative ) <?> "sign"  {-| Parse a `Double` literal@@ -188,7 +192,7 @@ doubleLiteral = (do     sign <- signPrefix <|> pure id     a <- Text.Parser.Token.double-    return (sign a) ) <?> "double literal"+    return (sign a) ) <?> "literal"  {-| Parse a signed @Infinity@ @@ -197,10 +201,10 @@ -} doubleInfinity :: Parser Double doubleInfinity = (do-    let negative = fmap (\_ -> negate) (Text.Parser.Char.char '-')+    let negative = fmap (\_ -> negate) (char '-')     sign <- negative <|> pure id-    a <- Text.Parser.Char.text "Infinity" >> whitespace >> return (1.0/0.0)-    return (sign a) ) <?> "double infinity"+    a <- text "Infinity" >> return (1.0/0.0)+    return (sign a) ) <?> "literal"  {-| Parse an `Integer` literal @@ -210,8 +214,7 @@ integerLiteral = (do     sign <- signPrefix     a <- Text.Megaparsec.Char.Lexer.decimal-    whitespace-    return (sign a) ) <?> "integer literal"+    return (sign a) ) <?> "literal"  {-| Parse a `Natural` literal  @@ -220,8 +223,7 @@ naturalLiteral :: Parser Natural naturalLiteral = (do     a <- Text.Megaparsec.Char.Lexer.decimal-    whitespace-    return a ) <?> "natural literal"+    return a ) <?> "literal"  {-| Parse an identifier (i.e. a variable or built-in) @@ -233,10 +235,11 @@ identifier = do     x <- label -    let indexed = do-            _ <- Text.Parser.Char.char '@'-            n <- Text.Megaparsec.Char.Lexer.decimal+    let indexed = try $ do             whitespace+            _at+            whitespace+            n <- Text.Megaparsec.Char.Lexer.decimal             return n      n <- indexed <|> pure 0@@ -246,7 +249,7 @@ whitespaceChunk =     choice         [ void (Dhall.Parser.Combinators.takeWhile1 predicate)-        , void (Text.Parser.Char.text "\r\n")+        , void (Text.Parser.Char.text "\r\n" <?> "newline")         , lineComment         , blockComment         ] <?> "whitespace"@@ -277,7 +280,7 @@  lineComment :: Parser () lineComment = do-    _ <- Text.Parser.Char.text "--"+    _ <- text "--"      let predicate c = ('\x20' <= c && c <= '\x10FFFF') || c == '\t' @@ -288,12 +291,13 @@     return ()   where     endOfLine =-            void (Text.Parser.Char.char '\n'  )+        (   void (Text.Parser.Char.char '\n'  )         <|> void (Text.Parser.Char.text "\r\n")+        ) <?> "newline"  blockComment :: Parser () blockComment = do-    _ <- Text.Parser.Char.text "{-"+    _ <- text "{-"     blockCommentContinue  blockCommentChunk :: Parser ()@@ -316,12 +320,12 @@       where         predicate c = '\x20' <= c && c <= '\x10FFFF' || c == '\n' || c == '\t' -    endOfLine = void (Text.Parser.Char.text "\r\n")+    endOfLine = void (Text.Parser.Char.text "\r\n" <?> "newline")  blockCommentContinue :: Parser () blockCommentContinue = endOfComment <|> continue   where-    endOfComment = void (Text.Parser.Char.text "-}")+    endOfComment = void (text "-}")      continue = do         blockCommentChunk@@ -331,9 +335,9 @@ simpleLabel allowReserved = try (do     c    <- Text.Parser.Char.satisfy headCharacter     rest <- Dhall.Parser.Combinators.takeWhile tailCharacter-    let text = Data.Text.cons c rest-    Control.Monad.guard (allowReserved || not (Data.HashSet.member text reservedIdentifiers))-    return text )+    let t = Data.Text.cons c rest+    Control.Monad.guard (allowReserved || not (Data.HashSet.member t reservedIdentifiers))+    return t )   where     headCharacter c = alpha c || c == '_' @@ -341,9 +345,9 @@  backtickLabel :: Parser Text backtickLabel = do-    _ <- Text.Parser.Char.char '`'+    _ <- char '`'     t <- takeWhile1 predicate-    _ <- Text.Parser.Char.char '`'+    _ <- char '`'     return t   where     predicate c =@@ -359,6 +363,7 @@ labels :: Parser (Set Text) labels = do     _openBrace+    whitespace     xs <- nonEmptyLabels <|> emptyLabels     _closeBrace     return xs@@ -367,13 +372,10 @@      nonEmptyLabels = do         x  <- anyLabel-        xs <- many (do _ <- _comma; anyLabel)+        whitespace+        xs <- many (do _comma; whitespace; l <- anyLabel; whitespace; return l)         noDuplicates (x : xs) --- | Parse a label without parsing trailing whitespace-labelOnly :: Parser Text-labelOnly = backtickLabel <|> simpleLabel False <?> "label"- {-| Parse a label (e.g. a variable\/field\/alternative name)      Rejects labels that match built-in names (e.g. @Natural/even@)@@ -381,10 +383,7 @@     This corresponds to the @nonreserved-label@ rule in the official grammar -} label :: Parser Text-label = (do-    t <- backtickLabel <|> simpleLabel False-    whitespace-    return t ) <?> "label"+label = backtickLabel <|> simpleLabel False <?> "label"  {-| Same as `label` except that built-in names are allowed @@ -393,7 +392,6 @@ anyLabel :: Parser Text anyLabel = (do     t <- backtickLabel <|> simpleLabel True-    whitespace     return t ) <?> "any label"  {-| Parse a valid Bash environment variable name@@ -422,7 +420,7 @@     escapeCharacter <|> satisfy predicate1   where     escapeCharacter = do-        _ <- Text.Parser.Char.char '\\'+        _ <- char '\\'          c <- Text.Parser.Char.satisfy (`elem` ("\"\\abfnrtv" :: String)) @@ -463,20 +461,20 @@     let pathData =             case componentType of                 FileComponent -> do-                    Text.Megaparsec.takeWhile1P Nothing Dhall.Core.pathCharacter+                    Text.Megaparsec.takeWhile1P Nothing Dhall.Syntax.pathCharacter                 URLComponent -> do                     star pchar      let quotedPathData = do-            _    <- Text.Parser.Char.char '"'-            text <- Text.Megaparsec.takeWhile1P Nothing quotedPathCharacter-            _    <- Text.Parser.Char.char '"'+            _ <- char '"'+            t <- Text.Megaparsec.takeWhile1P Nothing quotedPathCharacter+            _ <- char '"'              case componentType of               FileComponent -> do-                return text+                return t               URLComponent -> do-                return (URI.Encode.encodeText text)+                return (URI.Encode.encodeText t)      quotedPathData <|> pathData @@ -649,20 +647,40 @@ unreserved c =     alphaNum c || c == '-' || c == '.' || c == '_' || c == '~' -reserved :: Data.Text.Text -> Parser ()-reserved x = do _ <- Text.Parser.Char.text x; whitespace+{-| A variation on `Text.Parser.Char.text` that doesn't quote the expected+    in error messages+-}+text :: Data.Text.Text -> Parser Text+text t = Text.Parser.Char.text t <?> Data.Text.unpack t+{-# INLINE text #-} -reservedCharOnly :: Char -> Parser ()-reservedCharOnly c = do _ <- Text.Parser.Char.char c; return ()+{-| A variation on `Text.Parser.Char.char` that doesn't quote the expected+    token in error messages+-}+char :: Char -> Parser Char+char c = Text.Parser.Char.char c <?> [ c ]+{-# INLINE char #-} +reserved :: Data.Text.Text -> Parser ()+reserved x = void (text x)+ reservedChar :: Char -> Parser ()-reservedChar c = do _ <- Text.Parser.Char.char c; whitespace+reservedChar c = void (char c) -keywordOnly :: Data.Text.Text -> Parser ()-keywordOnly x = try (do _ <- Text.Parser.Char.text x; return ())+builtin :: Data.Text.Text -> Parser ()+builtin x = reserved x <?> "built-in"+{-# INLINE builtin #-} +operator :: Data.Text.Text -> Parser ()+operator x = reserved x <?> "operator"+{-# INLINE operator #-}++operatorChar :: Char -> Parser ()+operatorChar x = reservedChar x <?> "operator"+{-# INLINE operatorChar #-}+ keyword :: Data.Text.Text -> Parser ()-keyword x = try (do _ <- Text.Parser.Char.text x; nonemptyWhitespace)+keyword x = try (void (text x)) <?> "keyword"  {-| Parse the @if@ keyword @@ -685,10 +703,6 @@ _else :: Parser () _else = keyword "else" --- | Parse the @let@ keyword without trailing whitespace-_letOnly :: Parser ()-_letOnly = keywordOnly "let"- {-| Parse the @let@ keyword      This corresponds to the @let@ rule from the official grammar@@ -750,256 +764,266 @@     This corresponds to the @None@ rule from the official grammar -} _None :: Parser ()-_None = reserved "None"+_None = builtin "None"  {-| Parse the @Natural/fold@ built-in      This corresponds to the @Natural-fold@ rule from the official grammar -} _NaturalFold :: Parser ()-_NaturalFold = reserved "Natural/fold"+_NaturalFold = builtin "Natural/fold"  {-| Parse the @Natural/build@ built-in      This corresponds to the @Natural-build@ rule from the official grammar -} _NaturalBuild :: Parser ()-_NaturalBuild = reserved "Natural/build"+_NaturalBuild = builtin "Natural/build"  {-| Parse the @Natural/isZero@ built-in      This corresponds to the @Natural-isZero@ rule from the official grammar -} _NaturalIsZero :: Parser ()-_NaturalIsZero = reserved "Natural/isZero"+_NaturalIsZero = builtin "Natural/isZero"  {-| Parse the @Natural/even@ built-in      This corresponds to the @Natural-even@ rule from the official grammar -} _NaturalEven :: Parser ()-_NaturalEven = reserved "Natural/even"+_NaturalEven = builtin "Natural/even"  {-| Parse the @Natural/odd@ built-in      This corresponds to the @Natural-odd@ rule from the official grammar -} _NaturalOdd :: Parser ()-_NaturalOdd = reserved "Natural/odd"+_NaturalOdd = builtin "Natural/odd"  {-| Parse the @Natural/toInteger@ built-in      This corresponds to the @Natural-toInteger@ rule from the official grammar -} _NaturalToInteger :: Parser ()-_NaturalToInteger = reserved "Natural/toInteger"+_NaturalToInteger = builtin "Natural/toInteger"  {-| Parse the @Natural/show@ built-in      This corresponds to the @Natural-show@ rule from the official grammar -} _NaturalShow :: Parser ()-_NaturalShow = reserved "Natural/show"+_NaturalShow = builtin "Natural/show"  {-| Parse the @Natural/subtract@ built-in      This corresponds to the @Natural-subtract@ rule from the official grammar -} _NaturalSubtract :: Parser ()-_NaturalSubtract = reserved "Natural/subtract"+_NaturalSubtract = builtin "Natural/subtract" +{-| Parse the @Integer/clamp@ built-in++    This corresponds to the @Integer-clamp@ rule from the official grammar+-}+_IntegerClamp :: Parser ()+_IntegerClamp = builtin "Integer/clamp"++{-| Parse the @Integer/negate@ built-in++    This corresponds to the @Integer-negate@ rule from the official grammar+-}+_IntegerNegate :: Parser ()+_IntegerNegate = builtin "Integer/negate"+ {-| Parse the @Integer/show@ built-in      This corresponds to the @Integer-show@ rule from the official grammar -} _IntegerShow :: Parser ()-_IntegerShow = reserved "Integer/show"+_IntegerShow = builtin "Integer/show"  {-| Parse the @Integer/toDouble@ built-in      This corresponds to the @Integer-toDouble@ rule from the official grammar -} _IntegerToDouble :: Parser ()-_IntegerToDouble = reserved "Integer/toDouble"+_IntegerToDouble = builtin "Integer/toDouble"  {-| Parse the @Double/show@ built-in      This corresponds to the @Double-show@ rule from the official grammar -} _DoubleShow :: Parser ()-_DoubleShow = reserved "Double/show"+_DoubleShow = builtin "Double/show"  {-| Parse the @List/build@ built-in      This corresponds to the @List-build@ rule from the official grammar -} _ListBuild :: Parser ()-_ListBuild = reserved "List/build"+_ListBuild = builtin "List/build"  {-| Parse the @List/fold@ built-in      This corresponds to the @List-fold@ rule from the official grammar -} _ListFold :: Parser ()-_ListFold = reserved "List/fold"+_ListFold = builtin "List/fold"  {-| Parse the @List/length@ built-in      This corresponds to the @List-length@ rule from the official grammar -} _ListLength :: Parser ()-_ListLength = reserved "List/length"+_ListLength = builtin "List/length"  {-| Parse the @List/head@ built-in      This corresponds to the @List-head@ rule from the official grammar -} _ListHead :: Parser ()-_ListHead = reserved "List/head"+_ListHead = builtin "List/head"  {-| Parse the @List/last@ built-in      This corresponds to the @List-last@ rule from the official grammar -} _ListLast :: Parser ()-_ListLast = reserved "List/last"+_ListLast = builtin "List/last"  {-| Parse the @List/indexed@ built-in      This corresponds to the @List-indexed@ rule from the official grammar -} _ListIndexed :: Parser ()-_ListIndexed = reserved "List/indexed"+_ListIndexed = builtin "List/indexed"  {-| Parse the @List/reverse@ built-in      This corresponds to the @List-reverse@ rule from the official grammar -} _ListReverse :: Parser ()-_ListReverse = reserved "List/reverse"+_ListReverse = builtin "List/reverse"  {-| Parse the @Optional/fold@ built-in      This corresponds to the @Optional-fold@ rule from the official grammar -} _OptionalFold :: Parser ()-_OptionalFold = reserved "Optional/fold"+_OptionalFold = builtin "Optional/fold"  {-| Parse the @Optional/build@ built-in      This corresponds to the @Optional-build@ rule from the official grammar -} _OptionalBuild :: Parser ()-_OptionalBuild = reserved "Optional/build"+_OptionalBuild = builtin "Optional/build"  {-| Parse the @Bool@ built-in      This corresponds to the @Bool@ rule from the official grammar -} _Bool :: Parser ()-_Bool = reserved "Bool"+_Bool = builtin "Bool"  {-| Parse the @Optional@ built-in      This corresponds to the @Optional@ rule from the official grammar -} _Optional :: Parser ()-_Optional = reserved "Optional"+_Optional = builtin "Optional"  {-| Parse the @Natural@ built-in      This corresponds to the @Natural@ rule from the official grammar -} _Natural :: Parser ()-_Natural = reserved "Natural"+_Natural = builtin "Natural"  {-| Parse the @Integer@ built-in      This corresponds to the @Integer@ rule from the official grammar -} _Integer :: Parser ()-_Integer = reserved "Integer"+_Integer = builtin "Integer"  {-| Parse the @Double@ built-in      This corresponds to the @Double@ rule from the official grammar -} _Double :: Parser ()-_Double = reserved "Double"+_Double = builtin "Double"  {-| Parse the @Text@ built-in      This corresponds to the @Text@ rule from the official grammar -} _Text :: Parser ()-_Text = reserved "Text"+_Text = builtin "Text"  {-| Parse the @Text/show@ built-in      This corresponds to the @Text-show@ rule from the official grammar -} _TextShow :: Parser ()-_TextShow = reserved "Text/show"+_TextShow = builtin "Text/show"  {-| Parse the @List@ built-in      This corresponds to the @List@ rule from the official grammar -} _List :: Parser ()-_List = reserved "List"+_List = builtin "List"  {-| Parse the @True@ built-in      This corresponds to the @True@ rule from the official grammar -} _True :: Parser ()-_True = reserved "True"+_True = builtin "True"  {-| Parse the @False@ built-in      This corresponds to the @False@ rule from the official grammar -} _False :: Parser ()-_False = reserved "False"+_False = builtin "False"  {-| Parse a @NaN@ literal      This corresponds to the @NaN@ rule from the official grammar -} _NaN :: Parser ()-_NaN = reserved "NaN"+_NaN = builtin "NaN"  {-| Parse the @Type@ built-in      This corresponds to the @Type@ rule from the official grammar -} _Type :: Parser ()-_Type = reserved "Type"+_Type = builtin "Type"  {-| Parse the @Kind@ built-in      This corresponds to the @Kind@ rule from the official grammar -} _Kind :: Parser ()-_Kind = reserved "Kind"+_Kind = builtin "Kind"  {-| Parse the @Sort@ built-in      This corresponds to the @Sort@ rule from the official grammar -} _Sort :: Parser ()-_Sort = reserved "Sort"+_Sort = builtin "Sort"  {-| Parse the @Location@ keyword      This corresponds to the @Location@ rule from the official grammar -} _Location :: Parser ()-_Location = reserved "Location"---- | Parse the @=@ symbol without trailing whitespace-_equalOnly :: Parser ()-_equalOnly = reservedCharOnly '='+_Location = builtin "Location"  -- | Parse the @=@ symbol _equal :: Parser ()@@ -1007,39 +1031,39 @@  -- | Parse the @||@ symbol _or :: Parser ()-_or = reserved "||"+_or = operator "||"  -- | Parse the @+@ symbol _plus :: Parser ()-_plus = reservedChar '+'+_plus = operatorChar '+'  -- | Parse the @++@ symbol _textAppend :: Parser ()-_textAppend = reserved "++"+_textAppend = operator "++"  -- | Parse the @#@ symbol _listAppend :: Parser ()-_listAppend = reservedChar '#'+_listAppend = operatorChar '#'  -- | Parse the @&&@ symbol _and :: Parser ()-_and = reserved "&&"+_and = operator "&&"  -- | Parse the @*@ symbol _times :: Parser ()-_times = reservedChar '*'+_times = operatorChar '*'  -- | Parse the @==@ symbol _doubleEqual :: Parser ()-_doubleEqual = reserved "=="+_doubleEqual = operator "=="  -- | Parse the @!=@ symbol _notEqual :: Parser ()-_notEqual = reserved "!="+_notEqual = operator "!="  -- | Parse the @.@ symbol _dot :: Parser ()-_dot = reservedChar '.'+_dot = operatorChar '.'  -- | Parse the @{@ symbol _openBrace :: Parser ()@@ -1071,7 +1095,7 @@  -- | Parse the @,@ symbol _comma :: Parser ()-_comma = reservedChar ','+_comma = reservedChar ',' <?> "\',\'"  -- | Parse the @(@ symbol _openParens :: Parser ()@@ -1081,23 +1105,17 @@ _closeParens :: Parser () _closeParens = reservedChar ')' --- | Parse the @:@ symbol without trailing whitespace-_colonOnly :: Parser ()-_colonOnly = reservedCharOnly ':'- -- | Parse the @:@ symbol _colon :: Parser () _colon = reservedChar ':'  -- | Parse the @\@@ symbol _at :: Parser ()-_at = reservedChar '@'+_at = reservedChar '@' <?> "\"@\""  -- | Parse the equivalence symbol (@===@ or @≡@) _equivalent :: Parser ()-_equivalent = do-    void (Text.Parser.Char.char '≡' <?> "\"≡\"") <|> void (Text.Parser.Char.text "===")-    whitespace+_equivalent = (void (char '≡' <?> "\"≡\"") <|> void (text "===")) <?> "operator"  -- | Parse the @missing@ keyword _missing :: Parser ()@@ -1105,31 +1123,23 @@  -- | Parse the @?@ symbol _importAlt :: Parser ()-_importAlt = reservedChar '?'+_importAlt = operatorChar '?'  -- | Parse the record combine operator (@/\\@ or @∧@) _combine :: Parser ()-_combine = do-    void (Text.Parser.Char.char '∧' <?> "\"∧\"") <|> void (Text.Parser.Char.text "/\\")-    whitespace+_combine = (void (char '∧' <?> "\"∧\"") <|> void (text "/\\")) <?> "operator"  -- | Parse the record type combine operator (@//\\\\@ or @⩓@) _combineTypes :: Parser ()-_combineTypes = do-    void (Text.Parser.Char.char '⩓' <?> "\"⩓\"") <|> void (Text.Parser.Char.text "//\\\\")-    whitespace+_combineTypes = (void (char '⩓' <?> "\"⩓\"") <|> void (text "//\\\\")) <?> "operator"  -- | Parse the record \"prefer\" operator (@//@ or @⫽@) _prefer :: Parser ()-_prefer = do-    void (Text.Parser.Char.char '⫽' <?> "\"⫽\"") <|> void (Text.Parser.Char.text "//")-    whitespace+_prefer = (void (char '⫽' <?> "\"⫽\"") <|> void (text "//")) <?> "operator"  -- | Parse a lambda (@\\@ or @λ@) _lambda :: Parser ()-_lambda = do-    _ <- Text.Parser.Char.satisfy predicate-    whitespace+_lambda = void (Text.Parser.Char.satisfy predicate) <?> "\\"   where     predicate 'λ'  = True     predicate '\\' = True@@ -1137,16 +1147,12 @@  -- | Parse a forall (@forall@ or @∀@) _forall :: Parser ()-_forall = do-    void (Text.Parser.Char.char '∀' <?> "\"∀\"") <|> void (Text.Parser.Char.text "forall")-    whitespace+_forall = (void (char '∀' <?> "\"∀\"") <|> void (text "forall")) <?> "forall"  -- | Parse a right arrow (@->@ or @→@) _arrow :: Parser ()-_arrow = do-    void (Text.Parser.Char.char '→' <?> "\"→\"") <|> void (Text.Parser.Char.text "->")-    whitespace+_arrow = (void (char '→' <?> "\"→\"") <|> void (text "->")) <?> "->"  -- | Parse a double colon (@::@) _doubleColon :: Parser ()-_doubleColon = reserved "::"+_doubleColon = operator "::"

src/Dhall/Pretty.hs view

@@ -10,14 +10,8 @@     , CharacterSet(..)     , prettyCharacterSet -    , layoutOpts+    , Dhall.Pretty.Internal.layout+    , Dhall.Pretty.Internal.layoutOpts     ) where  import Dhall.Pretty.Internal-import qualified Data.Text.Prettyprint.Doc as Pretty---- | Default layout options-layoutOpts :: Pretty.LayoutOptions-layoutOpts =-    Pretty.defaultLayoutOptions-        { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 }

src/Dhall/Pretty/Internal.hs view

@@ -21,6 +21,7 @@     , prettyVar     , pretty_     , escapeText_+    , prettyEnvironmentVariable      , prettyConst     , prettyLabel@@ -32,6 +33,8 @@     , prettyDouble     , prettyToStrictText     , prettyToString+    , layout+    , layoutOpts      , docToStrictText @@ -96,6 +99,7 @@   | Literal     -- ^ Literals such as integers and strings   | Builtin     -- ^ Builtin types and values   | Operator    -- ^ Operators+  deriving Show  {-| Convert annotations to their corresponding color for syntax highlighting     purposes@@ -109,7 +113,7 @@ annToAnsiStyle Operator = Terminal.bold <> Terminal.colorDull Terminal.Green  -- | This type determines whether to render code as `ASCII` or `Unicode`-data CharacterSet = ASCII | Unicode+data CharacterSet = ASCII | Unicode deriving Show  -- | Pretty print an expression prettyExpr :: Pretty a => Expr s a -> Doc Ann@@ -407,11 +411,14 @@ digit :: Char -> Bool digit c = '\x30' <= c && c <= '\x39' +alphaNum :: Char -> Bool+alphaNum c = alpha c || digit c+ headCharacter :: Char -> Bool headCharacter c = alpha c || c == '_'  tailCharacter :: Char -> Bool-tailCharacter c = alpha c || digit c || c == '_' || c == '-' || c == '/'+tailCharacter c = alphaNum c || c == '_' || c == '-' || c == '/'  prettyLabelShared :: Bool -> Text -> Doc Ann prettyLabelShared allowReserved a = label doc@@ -457,6 +464,17 @@ prettyVar (V x 0) = label (Pretty.unAnnotate (prettyLabel x)) prettyVar (V x n) = label (Pretty.unAnnotate (prettyLabel x <> "@" <> prettyInt n)) +prettyEnvironmentVariable :: Text -> Doc ann+prettyEnvironmentVariable t+  | validBashEnvVar t = Pretty.pretty t+  | otherwise         = Pretty.pretty ("\"" <> escapeText_ t <> "\"")+  where+    validBashEnvVar v = case Text.uncons v of+        Nothing      -> False+        Just (c, v') ->+                (alpha c || c == '_')+            &&  Text.all (\c' -> alphaNum c' || c' == '_') v'+ {-  There is a close correspondence between the pretty-printers in 'prettyCharacterSet'     and the sub-parsers in 'Dhall.Parser.Expression.parsers'.  Most pretty-printers are     named after the corresponding parser and the relationship between pretty-printers@@ -954,6 +972,10 @@         builtin "Natural/subtract"     prettyPrimitiveExpression Integer =         builtin "Integer"+    prettyPrimitiveExpression IntegerClamp =+        builtin "Integer/clamp"+    prettyPrimitiveExpression IntegerNegate =+        builtin "Integer/negate"     prettyPrimitiveExpression IntegerShow =         builtin "Integer/show"     prettyPrimitiveExpression IntegerToDouble =@@ -1066,37 +1088,48 @@         angles . map prettyAlternative . Dhall.Map.toList      prettyChunks :: Pretty a => Chunks Src a -> Doc Ann-    prettyChunks (Chunks a b) =-        if any (\(builder, _) -> hasNewLine builder) a || hasNewLine b-        then Pretty.flatAlt long short-        else short+    prettyChunks chunks@(Chunks a b)+        | anyText (== '\n') =+            if not (null a) || anyText (/= '\n')+            then long+            else Pretty.group (Pretty.flatAlt long short)+        | otherwise =+            short       where         long =             Pretty.align-            (   literal ("''" <> Pretty.hardline)+            (   literal "''" <> Pretty.hardline             <>  Pretty.align-                (foldMap prettyMultilineChunk a <> prettyMultilineBuilder b)+                (foldMap prettyMultilineChunk a' <> prettyMultilineText b')             <>  literal "''"             )+          where+            Chunks a' b' = multilineChunks chunks          short =             literal "\"" <> foldMap prettyChunk a <> literal (prettyText b <> "\"") -        hasNewLine = Text.any (== '\n')+        anyText predicate = any (\(text, _) -> Text.any predicate text) a || Text.any predicate b          prettyMultilineChunk (c, d) =-                prettyMultilineBuilder c+                prettyMultilineText c             <>  dollar             <>  lbrace             <>  prettyExpression d             <>  rbrace -        prettyMultilineBuilder builder = literal (mconcat docs)+        prettyMultilineText text = mconcat docs           where-            lazyLines = Text.splitOn "\n" (escapeSingleQuotedText builder)+            lines_ = Text.splitOn "\n" (escapeSingleQuotedText text) +            -- Annotate only non-empty lines so trailing whitespace can be+            -- removed on empty ones.+            prettyLine line =+                (if Text.null line then id else literal)+                    (Pretty.pretty line)+             docs =-                Data.List.intersperse Pretty.hardline (fmap Pretty.pretty lazyLines)+                Data.List.intersperse Pretty.hardline (map prettyLine lines_)          prettyChunk (c, d) =                 prettyText c@@ -1106,20 +1139,125 @@          prettyText t = literal (Pretty.pretty (escapeText_ t)) ++-- | Prepare 'Chunks' for multi-line formatting by escaping problematic+-- character sequences via string interpolations+--+-- >>> multilineChunks (Chunks [] "\n \tx")+-- Chunks [("\n",TextLit (Chunks [] " \t"))] "x"+-- >>> multilineChunks (Chunks [] "\n\NUL\b\f\t")+-- Chunks [("\n",TextLit (Chunks [] "\NUL\b\f"))] "\t"+multilineChunks :: Chunks s a -> Chunks s a+multilineChunks =+     escapeTrailingSingleQuote+   . escapeControlCharacters+   . escapeLastLineLeadingWhitespace++-- | Escape leading whitespace on the last line by moving it into a string+-- interpolation+--+-- This ensures that the parser can find the correct indentation level, no matter+-- what the other lines contain.-+--+-- >>> escapeLastLineLeadingWhitespace (Chunks [] "\n \tx")+-- Chunks [("\n",TextLit (Chunks [] " \t"))] "x"+-- >>> escapeLastLineLeadingWhitespace (Chunks [("\n",Var (V "x" 0))] " ")+-- Chunks [("\n",Var (V "x" 0))] " "+-- >>> escapeLastLineLeadingWhitespace (Chunks [("\n ",Var (V "x" 0))] "")+-- Chunks [("\n",TextLit (Chunks [] " ")),("",Var (V "x" 0))] ""+-- >>> escapeLastLineLeadingWhitespace (Chunks [("\n ",Var (V "x" 0))] "\n")+-- Chunks [("\n ",Var (V "x" 0))] "\n"+--+-- We assume that there's at least one newline and may therefore ignore leading+-- whitespace on the first line:+--+-- >>> escapeLastLineLeadingWhitespace (Chunks [] " ")+-- Chunks [] " "+escapeLastLineLeadingWhitespace :: Chunks s a -> Chunks s a+escapeLastLineLeadingWhitespace (Chunks as0 b0) =+    case escape1 b0 of+        Nothing             -> Chunks (escapeChunks as0) b0+        Just (Chunks cs b1) -> Chunks (as0 ++ cs) b1+  where+    -- Nothing: No newline found+    -- Just chunks: Newline was found!+    escape1 :: Text -> Maybe (Chunks s a)+    escape1 t = case Text.breakOnEnd "\n" t of+        ("", _) -> Nothing+        (a , b) -> Just $ case Text.span predicate b of+            ("", _) -> Chunks [] t+            (c , d) -> Chunks [(a, TextLit (Chunks [] c))] d++    predicate c = c == ' ' || c == '\t'++    escapeChunks = snd . foldr f (NotDone, [])++    f chunk  (Done   , chunks) = (Done, chunk : chunks)+    f (t, e) (NotDone, chunks) = case escape1 t of+        Nothing            -> (NotDone, (t, e) : chunks)+        Just (Chunks as b) -> (Done, as ++ (b, e) : chunks)++data Done = NotDone | Done++-- | Escape control characters by moving them into string interpolations+--+-- >>> escapeControlCharacters (Chunks [] "\n\NUL\b\f\t")+-- Chunks [("\n",TextLit (Chunks [] "\NUL\b\f"))] "\t"+escapeControlCharacters :: Chunks s a -> Chunks s a+escapeControlCharacters (Chunks as0 b0) = Chunks as1 b1+  where+    as1 = foldr f (map toChunk bs) as0++    (bs, b1) = splitOnPredicate predicate b0++    f (t0, e) chunks = map toChunk ts1 ++ (t1, e) : chunks+      where+        (ts1, t1) = splitOnPredicate predicate t0++    predicate c = Data.Char.isControl c && c /= ' ' && c /= '\t' && c /= '\n'++    toChunk (t0, t1) = (t0, TextLit (Chunks [] t1))++-- | Split `Text` on a predicate, preserving all parts of the original string.+--+-- >>> splitOnPredicate (== 'x') ""+-- ([],"")+-- >>> splitOnPredicate (== 'x') " xx "+-- ([(" ","xx")]," ")+-- >>> splitOnPredicate (== 'x') "xx"+-- ([("","xx")],"")+--+-- prop> \(Fun _ p) s -> let {t = Text.pack s; (as, b) = splitOnPredicate p t} in foldMap (uncurry (<>)) as <> b == t+splitOnPredicate :: (Char -> Bool) -> Text -> ([(Text, Text)], Text)+splitOnPredicate p t = case Text.break p t of+    (a, "") -> ([], a)+    (a, b)  -> case Text.span p b of+        (c, d) -> case splitOnPredicate p d of+            (e, f) -> ((a, c) : e, f)++-- | Escape a trailing single quote by moving it into a string interpolation+--+-- Otherwise the multiline-string would end with @'''@, which would be parsed+-- as an escaped @''@.+--+-- >>> escapeTrailingSingleQuote (Chunks [] "\n'")+-- Chunks [("\n",TextLit (Chunks [] "'"))] ""+escapeTrailingSingleQuote :: Chunks s a -> Chunks s a+escapeTrailingSingleQuote chunks@(Chunks as b) =+    case Text.unsnoc b of+        Just (b', '\'') -> Chunks (as ++ [(b', TextLit (Chunks [] "'"))]) ""+        _               -> chunks+ -- | Pretty-print a value pretty_ :: Pretty a => a -> Text-pretty_ = Pretty.renderStrict . Pretty.layoutPretty options . Pretty.pretty-  where-   options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }+pretty_ = prettyToStrictText  -- | Escape a `Text` literal using Dhall's escaping rules for single-quoted --   @Text@ escapeSingleQuotedText :: Text -> Text-escapeSingleQuotedText inputBuilder = outputBuilder+escapeSingleQuotedText inputText = outputText   where-    outputText = substitute "${" "''${" (substitute "''" "'''" inputBuilder)--    outputBuilder = outputText+    outputText = substitute "${" "''${" (substitute "''" "'''" inputText)      substitute before after = Text.intercalate after . Text.splitOn before @@ -1160,14 +1298,30 @@  prettyToString :: Pretty a => a -> String prettyToString =-    Pretty.renderString . Pretty.layoutPretty options . Pretty.pretty-  where-   options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }+    Pretty.renderString . layout . Pretty.pretty  docToStrictText :: Doc ann -> Text.Text-docToStrictText = Pretty.renderStrict . Pretty.layoutPretty options-  where-   options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }+docToStrictText = Pretty.renderStrict . layout  prettyToStrictText :: Pretty a => a -> Text.Text prettyToStrictText = docToStrictText . Pretty.pretty++-- | Layout using 'layoutOpts'+--+-- Tries hard to fit the document into 80 columns.+--+-- This also removes trailing space characters (@' '@) /unless/+-- they are enclosed in an annotation.+layout :: Pretty.Doc ann -> Pretty.SimpleDocStream ann+layout = Pretty.removeTrailingWhitespace . Pretty.layoutSmart layoutOpts++-- | Default layout options+layoutOpts :: Pretty.LayoutOptions+layoutOpts =+    Pretty.defaultLayoutOptions+        { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 }+++{- $setup+>>> import Test.QuickCheck (Fun(..))+-}

src/Dhall/Pretty/Internal.hs-boot view

@@ -1,5 +1,6 @@ module Dhall.Pretty.Internal where +import Data.Text (Text) import Data.Text.Prettyprint.Doc (Pretty, Doc)  import {-# SOURCE #-} Dhall.Syntax@@ -11,3 +12,5 @@ prettyConst :: Const -> Doc Ann  prettyExpr :: Pretty a => Expr s a -> Doc Ann++prettyEnvironmentVariable :: Text -> Doc ann

src/Dhall/Repl.hs view

@@ -25,6 +25,7 @@ import Data.Void (Void) import Dhall.Context (Context) import Dhall.Import (hashExpressionToCode)+import Dhall.Parser (Parser(..)) import Dhall.Src (Src) import Dhall.Pretty (CharacterSet(..)) import System.Console.Haskeline (Interrupt(..))@@ -43,18 +44,21 @@ import qualified Dhall.Context import qualified Dhall.Core import qualified Dhall.Core as Dhall ( Var(V), Expr, normalize )+import qualified Dhall.Parser.Token                      as Parser.Token import qualified Dhall.Pretty+import qualified Dhall.Pretty.Internal import qualified Dhall.Core as Expr ( Expr(..) )-import qualified Dhall.Import as Dhall-import qualified Dhall.Map as Map-import qualified Dhall.Parser as Dhall-import qualified Dhall.TypeCheck as Dhall-import qualified Dhall.Version as Meta+import qualified Dhall.Import                            as Dhall+import qualified Dhall.Map                               as Map+import qualified Dhall.Parser                            as Dhall+import qualified Dhall.TypeCheck                         as Dhall+import qualified Dhall.Version                           as Meta import qualified System.Console.ANSI-import qualified System.Console.Haskeline.Completion as Haskeline+import qualified System.Console.Haskeline.Completion     as Haskeline import qualified System.Console.Haskeline.MonadException as Haskeline-import qualified System.Console.Repline as Repline+import qualified System.Console.Repline                  as Repline import qualified System.IO+import qualified Text.Megaparsec                         as Megaparsec  type Repl = Repline.HaskelineT (State.StateT Env IO) @@ -212,23 +216,19 @@  addBinding :: ( MonadFail m, MonadIO m, MonadState Env m ) => [String] -> m () addBinding (k : "=" : srcs) = do-  let-    varName =-      Text.pack k+  varName <- case Megaparsec.parse (unParser Parser.Token.label) "(stdin)" (Text.pack k) of+      Left   _      -> Fail.fail "Invalid variable name"+      Right varName -> return varName -  loaded <--    parseAndLoad ( unwords srcs )+  loaded <- parseAndLoad ( unwords srcs ) -  t <--    typeCheck loaded+  t <- typeCheck loaded -  expr <--    normalize loaded+  expr <- normalize loaded    modify     ( \e ->-        e-          { envBindings =+        e { envBindings =               Dhall.Context.insert                 varName                 Binding { bindingType = t, bindingExpr = expr }@@ -351,7 +351,11 @@       handler handle =           State.evalStateT             (forM_ bindings $ \(name, expr) -> do-              liftIO (System.IO.hPutStr handle $ ":let " <> Text.unpack name <> " = ")+              let doc = Dhall.Pretty.Internal.prettyLabel name++              let label = Dhall.Pretty.Internal.docToStrictText doc++              liftIO (System.IO.hPutStr handle $ ":let " <> Text.unpack label <> " = ")               outputWithoutSpacing expr)             (env { outputHandle = Just handle }) @@ -608,9 +612,7 @@   case outputHandle of     Nothing     -> pure ()     Just handle -> do-      let stream =-              Pretty.layoutSmart Dhall.Pretty.layoutOpts-                  (Dhall.Pretty.prettyCharacterSet characterSet expr)+      let stream = Dhall.Pretty.layout (Dhall.Pretty.prettyCharacterSet characterSet expr)        supportsANSI <- liftIO (System.Console.ANSI.hSupportsANSI handle)       let ansiStream =

src/Dhall/Set.hs view

@@ -10,6 +10,7 @@ module Dhall.Set (       Set(..)     , toList+    , toAscList     , toSet     , toSeq     , fromList@@ -20,6 +21,7 @@     , sort     , isSorted     , null+    , size     ) where  import Prelude hiding (null)@@ -57,6 +59,15 @@     foldMap f (Set _ x) = foldMap f x     {-# INLINABLE foldMap #-} +    toList = Dhall.Set.toList+    {-# INLINABLE toList #-}++    null = Dhall.Set.null+    {-# INLINABLE null #-}++    length = Dhall.Set.size+    {-# INLINABLE length #-}+ -- | Convert to an unordered @"Data.Set".`Data.Set.Set`@ toSet :: Set a -> Data.Set.Set a toSet (Set s _) = s@@ -67,8 +78,12 @@  -- | Convert a `Set` to a list, preserving the original order of the elements toList :: Set a -> [a]-toList = Data.Foldable.toList+toList (Set _ xs) = Data.Foldable.toList xs +-- | Convert a `Set` to a list of ascending elements+toAscList :: Set a -> [a]+toAscList (Set s _) = Data.Set.toAscList s+ -- | Convert a list to a `Set`, remembering the element order fromList :: Ord a => [a] -> Set a fromList = foldl' (flip append) empty@@ -103,7 +118,7 @@ True -} sort :: Ord a => Set a -> Set a-sort (Set s xs) = Set s (Data.Sequence.sort xs)+sort (Set s _) = Set s (Data.Sequence.fromList (Data.Set.toList s))  {-| >>> isSorted (fromList [2, 1])@@ -122,3 +137,10 @@ -} null :: Set a -> Bool null (Set s _) = Data.Set.null s++{-|+>>> size (fromList [1])+1+-}+size :: Set a -> Int+size (Set s _) = Data.Set.size s

src/Dhall/Syntax.hs view

@@ -211,7 +211,7 @@ -- -- This instance is also consistent with with the binary encoding of Dhall @Double@s: ----- >>> toBytes n = Codec.Serialise.serialise (Dhall.Binary.encode (n :: DhallDouble))+-- >>> toBytes n = Dhall.Binary.encodeExpression (DoubleLit n :: Expr Void Import) -- -- prop> \a b -> (a == b) == (toBytes a == toBytes b) instance Eq DhallDouble where@@ -338,6 +338,10 @@     | Integer     -- | > IntegerLit n                             ~  ±n     | IntegerLit Integer+    -- | IntegerClamp                               ~  Integer/clamp+    | IntegerClamp+    -- | IntegerNegate                              ~  Integer/negate+    | IntegerNegate     -- | > IntegerShow                              ~  Integer/show     | IntegerShow     -- | > IntegerToDouble                          ~  Integer/toDouble@@ -486,6 +490,8 @@   fmap f (NaturalTimes e1 e2) = NaturalTimes (fmap f e1) (fmap f e2)   fmap _ Integer = Integer   fmap _ (IntegerLit i) = IntegerLit i+  fmap _ IntegerClamp = IntegerClamp+  fmap _ IntegerNegate = IntegerNegate   fmap _ IntegerShow = IntegerShow   fmap _ IntegerToDouble = IntegerToDouble   fmap _ Double = Double@@ -569,6 +575,8 @@     NaturalTimes a b     >>= k = NaturalTimes (a >>= k) (b >>= k)     Integer              >>= _ = Integer     IntegerLit a         >>= _ = IntegerLit a+    IntegerClamp         >>= _ = IntegerClamp+    IntegerNegate        >>= _ = IntegerNegate     IntegerShow          >>= _ = IntegerShow     IntegerToDouble      >>= _ = IntegerToDouble     Double               >>= _ = Double@@ -639,6 +647,8 @@     first k (NaturalTimes a b    ) = NaturalTimes (first k a) (first k b)     first _  Integer               = Integer     first _ (IntegerLit a        ) = IntegerLit a+    first _  IntegerClamp          = IntegerClamp+    first _  IntegerNegate         = IntegerNegate     first _  IntegerShow           = IntegerShow     first _  IntegerToDouble       = IntegerToDouble     first _  Double                = Double@@ -769,6 +779,8 @@ subExpressions f (NaturalTimes a b) = NaturalTimes <$> f a <*> f b subExpressions _ Integer = pure Integer subExpressions _ (IntegerLit n) = pure (IntegerLit n)+subExpressions _ IntegerClamp = pure IntegerClamp+subExpressions _ IntegerNegate = pure IntegerNegate subExpressions _ IntegerShow = pure IntegerShow subExpressions _ IntegerToDouble = pure IntegerToDouble subExpressions _ Double = pure Double@@ -977,7 +989,7 @@      pretty (Remote url) = Pretty.pretty url -    pretty (Env env) = "env:" <> Pretty.pretty env+    pretty (Env env) = "env:" <> prettyEnvironmentVariable env      pretty Missing = "missing" @@ -1074,6 +1086,8 @@ denote (NaturalTimes a b    ) = NaturalTimes (denote a) (denote b) denote  Integer               = Integer denote (IntegerLit a        ) = IntegerLit a+denote  IntegerClamp          = IntegerClamp+denote  IntegerNegate         = IntegerNegate denote  IntegerShow           = IntegerShow denote  IntegerToDouble       = IntegerToDouble denote  Double                = Double@@ -1132,23 +1146,24 @@ reservedIdentifiers :: HashSet Text reservedIdentifiers =     Data.HashSet.fromList-        [ "let"-        , "in"-        , "Type"-        , "Kind"-        , "Sort"-        , "forall"-        , "Bool"-        , "True"-        , "False"-        , "merge"-        , "toMap"-        , "if"+        [ -- Keywords according to the `keyword` rule in the grammar+          "if"         , "then"         , "else"-        , "as"+        , "let"+        , "in"         , "using"-        , "Natural"+        , "missing"+        , "as"+        , "Infinity"+        , "NaN"+        , "merge"+        , "Some"+        , "toMap"+        , "assert"+        , "forall"++          -- Builtins according to the `builtin` rule in the grammar         , "Natural/fold"         , "Natural/build"         , "Natural/isZero"@@ -1158,13 +1173,13 @@         , "Natural/show"         , "Natural/subtract"         , "Integer"+        , "Integer/clamp"+        , "Integer/negate"         , "Integer/show"         , "Integer/toDouble"-        , "Double"+        , "Integer/show"+        , "Natural/subtract"         , "Double/show"-        , "Text"-        , "Text/show"-        , "List"         , "List/build"         , "List/fold"         , "List/length"@@ -1172,11 +1187,20 @@         , "List/last"         , "List/indexed"         , "List/reverse"+        , "Optional/fold"+        , "Optional/build"+        , "Text/show"+        , "Bool"+        , "True"+        , "False"         , "Optional"-        , "Some"         , "None"-        , "Optional/build"-        , "Optional/fold"-        , "NaN"-        , "Infinity"+        , "Natural"+        , "Integer"+        , "Double"+        , "Text"+        , "List"+        , "Type"+        , "Kind"+        , "Sort"         ]

src/Dhall/Tags.hs view

@@ -9,14 +9,14 @@     ) where  import Control.Exception (handle, SomeException(..))-import Data.List (isSuffixOf)+import Data.List (isSuffixOf, foldl') import Data.Maybe (fromMaybe) import Data.Semigroup (Semigroup(..)) import Dhall.Map (foldMapWithKey) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Dhall.Util (Input(..))-import Dhall.Core (Expr(..), Binding(..))+import Dhall.Syntax (Expr(..), Binding(..)) import Dhall.Src (Src(srcStart)) import Dhall.Parser (exprFromText) import System.FilePath ((</>), takeFileName)@@ -144,7 +144,7 @@           --   In example above, first line is 15 bytes long and '\n', mls contain:           --   (1, (16, "let foo = "bar"")           --   That allow us to get byte offset easier.-          mls = M.fromList . fst . foldl processLine ([], 0) . zip [1..] $ T.lines t+          mls = M.fromList . fst . foldl' processLine ([], 0) . zip [1..] $ T.lines t            {-| processLine is a worker for `foldl` that generates the list of lines with               byte offsets from the start of the first line from a list of lines

src/Dhall/Tutorial.hs view

@@ -1498,7 +1498,7 @@ -- We'll use this trick to test changes to the protected import in the following -- examples. ----- Now, supose you add a comment to the @./bar@ file:+-- Now, suppose you add a comment to the @./bar@ file: -- -- > $ cat ./bar -- > -- This comment does not change the hash

src/Dhall/TypeCheck.hs view

@@ -37,12 +37,11 @@ import Data.Text.Prettyprint.Doc (Doc, Pretty(..)) import Data.Typeable (Typeable) import Data.Void (Void, absurd)-import Dhall.Binary (ToTerm(..)) import Dhall.Context (Context)-import Dhall.Core (Binding(..), Const(..), Chunks(..), Expr(..), Var(..))+import Dhall.Syntax (Binding(..), Const(..), Chunks(..), Expr(..), Var(..)) import Dhall.Eval     (Environment(..), Names(..), Val(..), (~>))-import Dhall.Pretty (Ann, layoutOpts)+import Dhall.Pretty (Ann) import Dhall.Src (Src) import Lens.Family (over) @@ -60,6 +59,7 @@ import qualified Dhall.Eval                              as Eval import qualified Dhall.Map import qualified Dhall.Set+import qualified Dhall.Pretty import qualified Dhall.Pretty.Internal import qualified Dhall.Util import qualified Lens.Family@@ -510,6 +510,12 @@         IntegerLit _ -> do             return VInteger +        IntegerClamp -> do+            return (VInteger ~> VNatural)++        IntegerNegate -> do+            return (VInteger ~> VInteger)+         IntegerShow -> do             return (VInteger ~> VText) @@ -588,7 +594,7 @@                                     -- Carefully note that we don't use `die`                                     -- here so that the source span is narrowed                                     -- to just the offending element-                                    let err = MismatchedListElements i _T₀'' t₁ _T₁''+                                    let err = MismatchedListElements (i+1) _T₀'' t₁ _T₁''                                      let context = ctxToContext ctx @@ -678,7 +684,7 @@                             VList a                         ~>  VList                                 (VRecord-                                    (Dhall.Map.fromList+                                    (Dhall.Map.unorderedFromList                                         [ ("index", VNatural)                                         , ("value", a       )                                         ]@@ -897,8 +903,18 @@             return (VRecord (Dhall.Map.union xRs' xLs'))          RecordCompletion l r -> do-            loop ctx (Annot (Prefer (Field l "default") r) (Field l "Type"))+            _L' <- loop ctx l +            case _L' of+                VRecord xLs' +                  | not (Dhall.Map.member "default" xLs')+                     -> die (InvalidRecordCompletion "default" l)+                  | not (Dhall.Map.member "Type" xLs')+                     -> die (InvalidRecordCompletion "Type" l)+                  | otherwise+                     -> loop ctx (Annot (Prefer (Field l "default") r) (Field l "Type"))+                _ -> die (CompletionSchemaMustBeARecord l (quote names _L'))+         Merge t u mT₁ -> do             _T' <- loop ctx t @@ -934,7 +950,8 @@              if Data.Set.null diffU                 then return ()-                else die (MissingHandler diffU)+                else let (exemplar,rest) = Data.Set.deleteFindMin diffU+                     in die (MissingHandler exemplar rest)              let match _y _T₀' Nothing =                     return _T₀'@@ -1067,7 +1084,7 @@             let mapType _T' =                     VList                         (VRecord-                            (Dhall.Map.fromList+                            (Dhall.Map.unorderedFromList                                 [("mapKey", VText), ("mapValue", _T')]                             )                         )@@ -1133,9 +1150,9 @@                                 Just _T' -> return (x, _T')                                 Nothing  -> die (MissingField x _E'') -                    let adapt = VRecord . Dhall.Map.fromList+                    let adapt = VRecord . Dhall.Map.unorderedFromList -                    fmap adapt (traverse process (Dhall.Set.toList (Dhall.Set.sort xs)))+                    fmap adapt (traverse process (Dhall.Set.toAscList xs))                  _ -> do                     let text =@@ -1284,6 +1301,8 @@     | AlternativeAnnotationMismatch Text (Expr s a) Const Text (Expr s a) Const     | ListAppendMismatch (Expr s a) (Expr s a)     | MustCombineARecord Char (Expr s a) (Expr s a)+    | InvalidRecordCompletion Text (Expr s a)+    | CompletionSchemaMustBeARecord (Expr s a) (Expr s a)     | CombineTypesRequiresRecordType (Expr s a) (Expr s a)     | RecordTypeMismatch Const Const (Expr s a) (Expr s a)     | FieldCollision Text@@ -1296,7 +1315,7 @@     | MapTypeMismatch (Expr s a) (Expr s a)     | MissingToMapType     | UnusedHandler (Set Text)-    | MissingHandler (Set Text)+    | MissingHandler Text (Set Text)     | HandlerInputTypeMismatch Text (Expr s a) (Expr s a)     | DisallowedHandlerType Text (Expr s a) (Expr s a) Text     | HandlerOutputTypeMismatch Text (Expr s a) Text (Expr s a)@@ -1324,13 +1343,13 @@     | CantMultiply (Expr s a) (Expr s a)     deriving (Show) -shortTypeMessage :: (Eq a, Pretty a, ToTerm a) => TypeMessage s a -> Doc Ann+shortTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> Doc Ann shortTypeMessage msg =     "\ESC[1;31mError\ESC[0m: " <> short <> "\n"   where     ErrorMessages {..} = prettyTypeMessage msg -longTypeMessage :: (Eq a, Pretty a, ToTerm a) => TypeMessage s a -> Doc Ann+longTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> Doc Ann longTypeMessage msg =         "\ESC[1;31mError\ESC[0m: " <> short <> "\n"     <>  "\n"@@ -1351,8 +1370,7 @@ insert :: Pretty a => a -> Doc Ann insert = Dhall.Util.insert -prettyTypeMessage-    :: (Eq a, Pretty a, ToTerm a) => TypeMessage s a -> ErrorMessages+prettyTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> ErrorMessages prettyTypeMessage (UnboundVariable x) = ErrorMessages {..}   -- We do not need to print variable name here. For the discussion see:   -- https://github.com/dhall-lang/dhall-haskell/pull/116@@ -2023,7 +2041,9 @@  prettyTypeMessage (InvalidPredicate expr0 expr1) = ErrorMessages {..}   where-    short = "Invalid predicate for ❰if❱"+    short = "Invalid predicate for ❰if❱: "+        <>  "\n"+        <>  Dhall.Diff.doc (Dhall.Diff.diffNormalized Bool expr1)      long =         "Explanation: Every ❰if❱ expression begins with a predicate which must have type \n\@@ -2672,6 +2692,55 @@         txt0 = insert expr0         txt1 = insert expr1 +prettyTypeMessage (CompletionSchemaMustBeARecord expr0 expr1) = ErrorMessages {..} + where+   short = "The completion schema must be a record" ++   long = +        "Explanation: You can complete records using the ❰::❱ operator:                  \n\+        \                                                                                \n\+        \    ┌─────────────────────────────────────────────────────────────────────────┐ \n\+        \    │ {Type = {foo : Bool, bar : Natural}, default = {bar = 2}::{foo = True}} │ \n\+        \    └─────────────────────────────────────────────────────────────────────────┘ \n\+        \                                                                                \n\+        \... The left-hand side of :: must be a record with 'Type' and 'default' keys    \n\+        \                                                                                \n\+        \You tried to record complete the following value:                               \n\+        \                                                                                \n\+        \" <> txt0 <> "\n\+        \                                                                                \n\+        \... which is not a record. It is:                                               \n\+        \                                                                                \n\+        \" <> txt1 <> "\n"+      where+        txt0 = insert expr0+        txt1 = insert expr1++prettyTypeMessage (InvalidRecordCompletion fieldName expr0) = ErrorMessages {..} + where+   short = "Completion schema is missing a field: " <> pretty fieldName++   long = +        "Explanation: You can complete records using the ❰::❱ operator like this:\n\+        \                                                                                \n\+        \    ┌─────────────────────────────────────────────────────────────────────────┐ \n\+        \    │ {Type = {foo : Bool, bar : Natural}, default = {bar = 2}::{foo = True}} │ \n\+        \    └─────────────────────────────────────────────────────────────────────────┘ \n\+        \                                                                                \n\+        \... but you need to have both Type and default fields in the completion schema  \n\+        \    (the record on the left of the the ::).                                     \n\+        \                                                                                \n\+        \You tried to do record completion using the schema:                             \n\+        \                                                                                \n\+        \" <> txt0 <> "\n\+        \                                                                                \n\+        \... which is missing the key:                                                   \n\+        \                                                                                \n\+        \" <> txt1 <> "\n"+      where+        txt0 = insert expr0+        txt1 = pretty fieldName+ prettyTypeMessage (MustCombineARecord c expr0 expr1) = ErrorMessages {..}   where     short = "You can only combine records"@@ -2820,7 +2889,7 @@  prettyTypeMessage (FieldCollision k) = ErrorMessages {..}   where-    short = "Field collision"+    short = "Field collision on: " <> Dhall.Pretty.Internal.prettyLabel k      long =         "Explanation: You can combine records or record types if they don't share any    \n\@@ -3030,9 +3099,12 @@       where         txt0 = insert (Text.intercalate ", " (Data.Set.toList ks)) -prettyTypeMessage (MissingHandler ks) = ErrorMessages {..}+prettyTypeMessage (MissingHandler exemplar ks) = ErrorMessages {..}   where-    short = "Missing handler"+    short = case Data.Set.toList ks of+         []       -> "Missing handler: " <> Dhall.Pretty.Internal.prettyLabel exemplar+         xs@(_:_) -> "Missing handlers: " <> (Pretty.hsep . Pretty.punctuate Pretty.comma +                                             . map Dhall.Pretty.Internal.prettyLabel $ exemplar:xs)      long =         "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\@@ -3068,7 +3140,7 @@         \                                                                                \n\         \" <> txt0 <> "\n"       where-        txt0 = insert (Text.intercalate ", " (Data.Set.toList ks))+        txt0 = insert (Text.intercalate ", " (exemplar : Data.Set.toList ks))  prettyTypeMessage MissingMergeType =     ErrorMessages {..}@@ -3331,7 +3403,7 @@  prettyTypeMessage (HandlerNotAFunction k expr0) = ErrorMessages {..}   where-    short = "Handler is not a function"+    short = "Handler for "<> Dhall.Pretty.Internal.prettyLabel k <> " is not a function"      long =         "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\@@ -3682,7 +3754,7 @@  prettyTypeMessage (MissingField k expr0) = ErrorMessages {..}   where-    short = "Missing record field"+    short = "Missing record field: " <> Dhall.Pretty.Internal.prettyLabel k      long =         "Explanation: You can only access fields on records, like this:                  \n\@@ -3724,7 +3796,7 @@  prettyTypeMessage (MissingConstructor k expr0) = ErrorMessages {..}   where-    short = "Missing constructor"+    short = "Missing constructor: " <> Dhall.Pretty.Internal.prettyLabel k      long =         "Explanation: You can access constructors from unions, like this:                \n\@@ -4246,35 +4318,24 @@     , typeMessage :: TypeMessage s a     } -instance (Eq a, Pretty s, Pretty a, ToTerm a) => Show (TypeError s a) where-    show = Pretty.renderString . Pretty.layoutPretty layoutOpts . Pretty.pretty--instance (Eq a, Pretty s, Pretty a, ToTerm a, Typeable s, Typeable a) => Exception (TypeError s a)+instance (Eq a, Pretty s, Pretty a) => Show (TypeError s a) where+    show = Pretty.renderString . Dhall.Pretty.layout . prettyTypeError -instance (Eq a, Pretty s, Pretty a, ToTerm a) => Pretty (TypeError s a) where-    pretty (TypeError ctx expr msg)-        = Pretty.unAnnotate-            (   "\n"-            <>  (   if null (Dhall.Context.toList ctx)-                    then ""-                    else prettyContext ctx <> "\n\n"-                )-            <>  shortTypeMessage msg <> "\n"-            <>  source-            )-      where-        prettyKV (key, val) =-            pretty key <> " : " <> Dhall.Util.snipDoc (pretty val)+instance (Eq a, Pretty s, Pretty a, Typeable s, Typeable a) => Exception (TypeError s a) -        prettyContext =-                Pretty.vsep-            .   map prettyKV-            .   reverse-            .   Dhall.Context.toList+instance (Eq a, Pretty s, Pretty a) => Pretty (TypeError s a) where+    pretty = Pretty.unAnnotate . prettyTypeError -        source = case expr of-            Note s _ -> pretty s-            _        -> mempty+prettyTypeError :: (Eq a, Pretty s, Pretty a) => TypeError s a -> Doc Ann+prettyTypeError (TypeError _ expr msg) =+    (   "\n"+    <>  shortTypeMessage msg <> "\n"+    <>  source+    )+  where+    source = case expr of+        Note s _ -> pretty s+        _        -> mempty  {-| Wrap a type error in this exception type to censor source code and     `Text` literals from the error message@@ -4284,7 +4345,7 @@     | Censored (TypeError Src X)  instance Show Censored where-    show = Pretty.renderString . Pretty.layoutPretty layoutOpts . Pretty.pretty+    show = Pretty.renderString . Dhall.Pretty.layout . Pretty.pretty  instance Exception Censored @@ -4349,6 +4410,10 @@         ListAppendMismatch <$> f a <*> f b     MustCombineARecord a b c ->         MustCombineARecord <$> pure a <*> f b <*> f c+    InvalidRecordCompletion a l -> +        InvalidRecordCompletion a <$> f l+    CompletionSchemaMustBeARecord l r -> +        CompletionSchemaMustBeARecord <$> f l <*> f r     CombineTypesRequiresRecordType a b ->         CombineTypesRequiresRecordType <$> f a <*> f b     RecordTypeMismatch a b c d ->@@ -4373,8 +4438,8 @@         pure MissingToMapType     UnusedHandler a ->         UnusedHandler <$> pure a-    MissingHandler a ->-        MissingHandler <$> pure a+    MissingHandler e a ->+        MissingHandler <$> pure e <*> pure a     HandlerInputTypeMismatch a b c ->         HandlerInputTypeMismatch <$> pure a <*> f b <*> f c     DisallowedHandlerType a b c d ->@@ -4432,37 +4497,40 @@ newtype DetailedTypeError s a = DetailedTypeError (TypeError s a)     deriving (Typeable) -instance (Eq a, Pretty s, Pretty a, ToTerm a) => Show (DetailedTypeError s a) where-    show = Pretty.renderString . Pretty.layoutPretty layoutOpts . Pretty.pretty+instance (Eq a, Pretty s, Pretty a) => Show (DetailedTypeError s a) where+    show = Pretty.renderString . Dhall.Pretty.layout . prettyDetailedTypeError -instance (Eq a, Pretty s, Pretty a, ToTerm a, Typeable s, Typeable a) => Exception (DetailedTypeError s a)+instance (Eq a, Pretty s, Pretty a, Typeable s, Typeable a) => Exception (DetailedTypeError s a) -instance (Eq a, Pretty s, Pretty a, ToTerm a) => Pretty (DetailedTypeError s a) where-    pretty (DetailedTypeError (TypeError ctx expr msg))-        = Pretty.unAnnotate-            (   "\n"-            <>  (   if null (Dhall.Context.toList ctx)-                    then ""-                    else prettyContext ctx <> "\n\n"-                )-            <>  longTypeMessage msg <> "\n"-            <>  "────────────────────────────────────────────────────────────────────────────────\n"-            <>  "\n"-            <>  source-            )-      where-        prettyKV (key, val) =-            pretty key <> " : " <> Dhall.Util.snipDoc (pretty val)+instance (Eq a, Pretty s, Pretty a) => Pretty (DetailedTypeError s a) where+    pretty = Pretty.unAnnotate . prettyDetailedTypeError -        prettyContext =-                Pretty.vsep-            .   map prettyKV-            .   reverse-            .   Dhall.Context.toList+prettyDetailedTypeError :: (Eq a, Pretty s, Pretty a) => DetailedTypeError s a -> Doc Ann+prettyDetailedTypeError (DetailedTypeError (TypeError ctx expr msg)) =+    (   "\n"+    <>  (   if null (Dhall.Context.toList ctx)+            then ""+            else prettyContext ctx <> "\n\n"+        )+    <>  longTypeMessage msg <> "\n"+    <>  "────────────────────────────────────────────────────────────────────────────────\n"+    <>  "\n"+    <>  source+    )+  where+    prettyKV (key, val) =+        Dhall.Util.snipDoc+            (Dhall.Pretty.Internal.prettyLabel key <> " : " <> Dhall.Pretty.prettyExpr val) -        source = case expr of-            Note s _ -> pretty s-            _        -> mempty+    prettyContext =+            Pretty.vsep+        .   map prettyKV+        .   reverse+        .   Dhall.Context.toList++    source = case expr of+        Note s _ -> pretty s+        _        -> mempty  {-| This function verifies that a custom context is well-formed so that     type-checking will not loop

src/Dhall/URL.hs view

@@ -6,7 +6,7 @@ import Data.Monoid ((<>)) import Data.Text (Text) -import Dhall.Core+import Dhall.Syntax     ( Scheme(..)     , URL(..)     , File(..)

src/Dhall/Util.hs view

@@ -12,23 +12,27 @@     , Output(..)     , getExpression     , getExpressionAndHeader+    , getExpressionAndHeaderFromStdinText+    , Header(..)     ) where +import Control.Exception (Exception(..))+import Control.Monad.IO.Class (MonadIO(..)) import Data.Bifunctor (first) import Data.Monoid ((<>)) import Data.String (IsString) import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty)-import Dhall.Core (Expr, Import)-import Dhall.Parser (ParseError)+import Dhall.Parser (ParseError, Header(..)) import Dhall.Pretty (Ann)+import Dhall.Syntax (Expr, Import) import Dhall.Src (Src) +import qualified Control.Exception import qualified Data.Text import qualified Data.Text.IO-import qualified Data.Text.Prettyprint.Doc             as Pretty-import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty-import qualified Dhall.Core+import qualified Data.Text.Prettyprint.Doc                 as Pretty+import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal import qualified Dhall.Parser import qualified Dhall.Pretty @@ -73,11 +77,11 @@ snipDoc :: Doc Ann -> Doc a snipDoc doc = Pretty.align (Pretty.pretty (snip text))   where-    stream = Pretty.layoutSmart Dhall.Pretty.layoutOpts doc+    stream = Dhall.Pretty.layout doc      ansiStream = fmap Dhall.Pretty.annToAnsiStyle stream -    text = Pretty.renderStrict ansiStream+    text = Pretty.Terminal.renderStrict ansiStream  takeEnd :: Int -> [a] -> [a] takeEnd n l = go (drop n l) l@@ -94,17 +98,19 @@ _ERROR :: IsString string => string _ERROR = "\ESC[1;31mError\ESC[0m" -get :: (String -> Text -> Either ParseError a) -> Censor -> Input -> IO a+get :: (String -> Text -> Either ParseError a) -> Censor -> InputOrTextFromStdin -> IO a get parser censor input = do     inText <- do         case input of-            InputFile file -> Data.Text.IO.readFile file-            StandardInput  -> Data.Text.IO.getContents+            Input_ (InputFile file) -> Data.Text.IO.readFile file+            Input_ StandardInput    -> Data.Text.IO.getContents+            StdinText text          -> pure text      let name =             case input of-                InputFile file -> file-                StandardInput  -> "(stdin)"+                Input_ (InputFile file) -> file+                Input_ StandardInput    -> "(stdin)"+                StdinText _             -> "(stdin)"      let result = parser name inText @@ -113,21 +119,36 @@                 NoCensor -> result                 Censor   -> first Dhall.Parser.censor result -    Dhall.Core.throws censoredResult+    throws censoredResult +{-| Convenience utility for converting `Either`-based exceptions to `IO`-based+    exceptions+-}+throws :: (Exception e, MonadIO io) => Either e a -> io a+throws (Left  e) = liftIO (Control.Exception.throwIO e)+throws (Right r) = return r+ -- | Set to `Censor` if you want to censor error text that might include secrets data Censor = NoCensor | Censor  -- | Path to input data Input = StandardInput | InputFile FilePath +-- | Path to input or raw input text, necessary since we can't read STDIN twice+data InputOrTextFromStdin = Input_ Input | StdinText Text+ -- | Path to output data Output = StandardOutput | OutputFile FilePath  -- | Convenient utility for retrieving an expression getExpression :: Censor -> Input -> IO (Expr Src Import)-getExpression = get Dhall.Parser.exprFromText+getExpression censor = get Dhall.Parser.exprFromText censor . Input_  -- | Convenient utility for retrieving an expression along with its header-getExpressionAndHeader :: Censor -> Input -> IO (Text, Expr Src Import)-getExpressionAndHeader = get Dhall.Parser.exprAndHeaderFromText+getExpressionAndHeader :: Censor -> Input -> IO (Header, Expr Src Import)+getExpressionAndHeader censor = get Dhall.Parser.exprAndHeaderFromText censor . Input_++-- | 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

tests/Dhall/Test/Dhall.hs view

@@ -57,8 +57,8 @@  data MyType = MyType { foo :: String , bar :: Natural } -wrongDhallType :: Dhall.Type MyType-wrongDhallType = Dhall.Type { .. }+wrongDhallType :: Dhall.Decoder MyType+wrongDhallType = Dhall.Decoder { .. }   where expected =           Dhall.Core.Record             ( Dhall.Map.fromList@@ -74,12 +74,12 @@         try ( Dhall.input wrongDhallType "{  bar = 0, foo = \"foo\" }")    let expectedMsg =-        "\ESC[1;31mError\ESC[0m: Invalid Dhall.Type                                                  \n\+        "\ESC[1;31mError\ESC[0m: Invalid Dhall.Decoder                                               \n\         \                                                                                \n\-        \Every Type must provide an extract function that succeeds if an expression      \n\-        \matches the expected type.  You provided a Type that disobeys this contract     \n\+        \Every Decoder must provide an extract function that succeeds if an expression   \n\+        \matches the expected type.  You provided a Decoder that disobeys this contract  \n\         \                                                                                \n\-        \The Type provided has the expected dhall type:                                  \n\+        \The Decoder provided has the expected dhall type:                               \n\         \                                                                                \n\         \↳ { bar : Natural, foo : Text }\n\         \                                                                                \n\@@ -97,7 +97,7 @@ -- https://github.com/dhall-lang/dhall-haskell/issues/915 shouldHandleUnionLiteral :: TestTree shouldHandleUnionLiteral = testCase "Marshal union literals" $ do-    let example :: Dhall.Type Bool+    let example :: Dhall.Decoder Bool         example = Dhall.union (Dhall.constructor "Test" Dhall.bool)      _ <- Dhall.input example "< Test : Bool >.Test True"@@ -106,15 +106,15 @@  shouldTreatAConstructorStoringUnitAsEmptyAlternative :: TestTree shouldTreatAConstructorStoringUnitAsEmptyAlternative = testCase "Handle unit constructors" $ do-    let exampleType :: Dhall.Type ()+    let exampleType :: Dhall.Decoder ()         exampleType = Dhall.union (Dhall.constructor "A" Dhall.unit)      () <- Dhall.input exampleType "< A >.A" -    let exampleInputType :: Dhall.InputType ()-        exampleInputType = Dhall.inputUnion (Dhall.inputConstructor "A")+    let exampleEncoder :: Dhall.Encoder ()+        exampleEncoder = Dhall.unionEncoder (Dhall.encodeConstructor "A") -    Dhall.embed exampleInputType () @=? Field (Union (Dhall.Map.singleton "A" Nothing)) "A"+    Dhall.embed exampleEncoder () @=? Field (Union (Dhall.Map.singleton "A" Nothing)) "A"  shouldHaveWorkingRecursiveFromDhall :: TestTree shouldHaveWorkingRecursiveFromDhall = testGroup "recursive FromDhall instance"

tests/Dhall/Test/Diff.hs view

@@ -10,11 +10,11 @@  import qualified Data.Text                             as Text import qualified Data.Text.IO                          as Text.IO-import qualified Data.Text.Prettyprint.Doc             as Pretty import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text import qualified Dhall.Core                            as Core import qualified Dhall.Diff                            as Diff import qualified Dhall.Parser                          as Parser+import qualified Dhall.Pretty import qualified Dhall.Test.Util                       as Test.Util import qualified Test.Tasty                            as Tasty import qualified Test.Tasty.HUnit                      as Tasty.HUnit@@ -50,13 +50,8 @@         let actualDiffDocument =                 Diff.doc (Diff.diffNormalized leftInput rightInput) <> "\n" -        let options =-                Pretty.LayoutOptions-                    { Pretty.layoutPageWidth = Pretty.Unbounded }--        let actualDiffText =-                Pretty.Text.renderStrict-                    (Pretty.layoutPretty options actualDiffDocument)+        let actualDiffText = Pretty.Text.renderStrict+                    (Dhall.Pretty.layout actualDiffDocument)          let message = "The diffed expressions did not match the expected output"

tests/Dhall/Test/Format.hs view

@@ -4,6 +4,7 @@  import Data.Monoid (mempty, (<>)) import Data.Text (Text)+import Dhall.Parser (Header(..)) import Dhall.Pretty (CharacterSet(..)) import Test.Tasty (TestTree) @@ -43,6 +44,16 @@      return testTree +format :: CharacterSet -> (Header, Core.Expr Parser.Src Core.Import) -> Text+format characterSet (Header header, expr) =+    let doc =  Doc.pretty header+            <> Pretty.prettyCharacterSet characterSet expr+            <> "\n"++        docStream = Pretty.layout doc+    in+        Doc.Render.Text.renderStrict docStream+ formatTest :: CharacterSet -> Text -> TestTree formatTest characterSet prefix =     Tasty.HUnit.testCase (Text.unpack prefix) $ do@@ -51,14 +62,9 @@          inputText <- Text.IO.readFile inputFile -        (header, expr) <- Core.throws (Parser.exprAndHeaderFromText mempty inputText)--        let doc        =   Doc.pretty header-                       <>  Pretty.prettyCharacterSet characterSet expr-                       <>  "\n"-        let docStream  = Doc.layoutSmart Pretty.layoutOpts doc-        let actualText = Doc.Render.Text.renderStrict docStream+        headerAndExpr <- Core.throws (Parser.exprAndHeaderFromText mempty inputText) +        let actualText = format characterSet headerAndExpr         expectedText <- Text.IO.readFile outputFile          let message =

tests/Dhall/Test/Parser.hs view

@@ -10,9 +10,6 @@ import Test.Tasty (TestTree) import Turtle (FilePath, (</>)) -import qualified Codec.CBOR.Read      as CBOR-import qualified Codec.CBOR.Term      as CBOR-import qualified Codec.Serialise      as Serialise import qualified Control.Monad        as Monad import qualified Data.Bifunctor       as Bifunctor import qualified Data.ByteString      as ByteString@@ -26,6 +23,7 @@ import qualified Dhall.Test.Util      as Test.Util import qualified Test.Tasty           as Tasty import qualified Test.Tasty.HUnit     as Tasty.HUnit+import qualified Text.Printf          as Printf import qualified Turtle  parseDirectory :: FilePath@@ -91,7 +89,8 @@                       (Just " ")                       Nothing                       (Just " ")-                      (Note "0 " (NaturalLit 0)))+                      (Note "0 " (Note "0" (NaturalLit 0)))+                    )                     -- This 'Let' isn't wrapped in a 'Note'!                     (Let                       (Binding@@ -100,7 +99,7 @@                         (Just " ")                         Nothing                         (Just " ")-                        (Note "1 " (NaturalLit 1))+                        (Note "1 " (Note "1" (NaturalLit 1)))                       )                       (Note "let z = 2 in x"                         (Let@@ -110,10 +109,14 @@                             (Just " ")                             Nothing                             (Just " ")-                            (Note "2 " (NaturalLit 2))+                            (Note "2 " (Note "2" (NaturalLit 2)))                           )-                          (Note "x"-                            (Var (V "x" 0))))))))+                          (Note "x" (Var (V "x" 0)))+                        )+                      )+                    )+                  )+                )          let msg = "Unexpected parse result" @@ -124,8 +127,13 @@     let expectedFailures =             -- This is a bug created by a parsing performance             -- improvement-            [ parseDirectory </> "success/unit/MergeParenAnnotation" ]+            [ parseDirectory </> "success/unit/MergeParenAnnotation" +            -- https://github.com/dhall-lang/dhall-haskell/issues/1454+            , parseDirectory </> "success/missingFoo"+            , parseDirectory </> "success/missingSlash"+            ]+     let pathString = Text.unpack path      Test.Util.testCase path expectedFailures $ do@@ -133,18 +141,20 @@          encoded <- ByteString.Lazy.readFile (pathString <> "B.dhallb") -        expression <- Core.throws (Parser.exprFromText mempty text)+        expression <- case Parser.exprFromText mempty text of+            Left  exception  -> Tasty.HUnit.assertFailure (show exception)+            Right expression -> return expression -        let term = Binary.encodeExpression expression+        let bytes = Binary.encodeExpression (Core.denote expression) -        let bytes = Serialise.serialise term+        let render =+                  concatMap (Printf.printf "%02x ")+                . ByteString.Lazy.unpack          Monad.unless (encoded == bytes) $ do-            ("", expected) <- Core.throws (CBOR.deserialiseFromBytes CBOR.decodeTerm encoded)-             let message = "The expected CBOR representation doesn't match the actual one\n"-                          ++ "expected: " ++ show expected ++ "\n but got: " ++ show term-                          ++ "\n expr: " ++ show expression+                          ++ "expected: " ++ render encoded ++ "\n but got: " ++ render bytes+                          ++ "\n expr: " ++ show (Core.denote expression :: Expr Void Import)              Tasty.HUnit.assertFailure message @@ -152,35 +162,11 @@ shouldNotParse :: Text -> TestTree shouldNotParse path = do     let expectedFailures =-            [ -- These two unexpected successes are due to not correctly-              -- requiring non-empty whitespace after the `:` in a type-              -- annotation-              parseDirectory </> "failure/unit/ImportEnvWrongEscape.dhall"--              -- Other spacing related unexpected successes:-            , parseDirectory </> "failure/spacing/AnnotationNoSpace.dhall"-            , parseDirectory </> "failure/spacing/ApplicationNoSpace1.dhall"-            , parseDirectory </> "failure/spacing/ApplicationNoSpace2.dhall"-            , parseDirectory </> "failure/spacing/AssertNoSpace.dhall"-            , parseDirectory </> "failure/spacing/ForallNoSpace.dhall"-            , parseDirectory </> "failure/spacing/ImportAltNoSpace.dhall"-            , parseDirectory </> "failure/spacing/ImportHashedNoSpace.dhall"-            , parseDirectory </> "failure/spacing/LambdaNoSpace.dhall"-            , parseDirectory </> "failure/spacing/ListLitEmptyNoSpace.dhall"-            , parseDirectory </> "failure/spacing/MergeAnnotationNoSpace3.dhall"-            , parseDirectory </> "failure/spacing/MergeNoSpace2.dhall"-            , parseDirectory </> "failure/spacing/NaturalPlusNoSpace.dhall"-            , parseDirectory </> "failure/spacing/RecordTypeNoSpace.dhall"-            , parseDirectory </> "failure/spacing/ToMapAnnotNoSpace.dhall"-            , parseDirectory </> "failure/spacing/UnionTypeNoSpace.dhall"--            , parseDirectory </> "failure/ImportHeadersExteriorHash.dhall"--              -- For parsing performance reasons the implementation+            [ -- For parsing performance reasons the implementation               -- treats a missing type annotation on an empty list as               -- as a type-checking failure instead of a parse failure,               -- but this might be fixable.-            , parseDirectory </> "failure/unit/ListLitEmptyMissingAnnotation.dhall"+              parseDirectory </> "failure/unit/ListLitEmptyMissingAnnotation.dhall"             , parseDirectory </> "failure/unit/ListLitEmptyAnnotation.dhall"                -- The same performance improvements also broke the@@ -202,16 +188,29 @@  shouldDecode :: Text -> TestTree shouldDecode pathText = do-    let expectedFailures = []+    let expectedFailures =+          [ {- Note that this test actually successfully decodes the value, but+               mistakenly decodes the value to `_` instead of `x`.  This is+               because the 55799 tag causes normal decoding to fail, so it falls+               back to treating the `"x"` as a version tag instead of a label. +               Either way, fixing 55799 decoding would cause this test to pass+               again.+            -}+            binaryDecodeDirectory </> "success/unit/SelfDescribeCBORX2"+          , binaryDecodeDirectory </> "success/unit/SelfDescribeCBORX3"+          ]+     let pathString = Text.unpack pathText      Test.Util.testCase pathText expectedFailures (do         bytes <- ByteString.Lazy.readFile (pathString <> "A.dhallb") -        term <- Core.throws (Serialise.deserialiseOrFail bytes)--        decodedExpression <- Core.throws (Binary.decodeExpression term)+        decodedExpression <- case Binary.decodeExpression bytes of+            Left exception ->+                Tasty.HUnit.assertFailure (show exception)+            Right decodedExpression ->+                return decodedExpression          text <- Text.IO.readFile (pathString <> "B.dhall") @@ -223,7 +222,7 @@         let message =                 "The decoded expression didn't match the parsed expression" -        Tasty.HUnit.assertEqual message decodedExpression strippedExpression )+        Tasty.HUnit.assertEqual message strippedExpression decodedExpression )  shouldNotDecode :: Text -> TestTree shouldNotDecode pathText = do@@ -234,8 +233,6 @@     Test.Util.testCase pathText expectedFailures (do         bytes <- ByteString.Lazy.readFile (pathString <> ".dhallb") -        term <- Core.throws (Serialise.deserialiseOrFail bytes)--        case Binary.decodeExpression term :: Either Binary.DecodingFailure (Expr Void Import) of+        case Binary.decodeExpression bytes :: Either Binary.DecodingFailure (Expr Void Import) of             Left _ -> return ()             Right _ -> Tasty.HUnit.assertFailure "Unexpected successful decode" )

tests/Dhall/Test/QuickCheck.hs view

@@ -1,18 +1,19 @@ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE StandaloneDeriving  #-}-{-# LANGUAGE TypeOperators       #-} {-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns #-}  {-# OPTIONS_GHC -fno-warn-orphans #-}  module Dhall.Test.QuickCheck where -import Codec.Serialise (DeserialiseFailure(..)) import Data.Either (isRight) import Data.Either.Validation (Validation(..))+import Data.Monoid ((<>))+import Data.Void (Void) import Dhall (ToDhall(..), FromDhall(..), auto, extract, inject, embed, Vector) import Dhall.Map (Map) import Dhall.Core@@ -37,19 +38,21 @@ import Data.Typeable (Typeable, typeRep) import Data.Proxy (Proxy(..)) import Dhall.Set (Set)+import Dhall.Parser (Header(..), createHeader)+import Dhall.Pretty (CharacterSet(..)) import Dhall.Src (Src(..))+import Dhall.Test.Format (format) import Dhall.TypeCheck (Typer, TypeError) import Generic.Random (Weights, W, (%), (:+)(..)) import Test.QuickCheck-    (Arbitrary(..), Gen, Positive(..), Property, NonNegative(..), genericShrink, (===), (==>))+    ( Arbitrary(..), Gen, Positive(..), Property, NonNegative(..)+    , genericShrink, suchThat, (===), (==>)) import Test.QuickCheck.Instances () import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (QuickCheckTests(..)) import Text.Megaparsec (SourcePos(..), Pos)  import qualified Control.Spoon-import qualified Codec.Serialise-import qualified Data.Coerce import qualified Data.List import qualified Data.Sequence import qualified Data.SpecialValues@@ -63,6 +66,7 @@ import qualified Dhall.Core import qualified Dhall.Diff import qualified Dhall.Map+import qualified Dhall.Parser as Parser import qualified Dhall.Set import qualified Dhall.TypeCheck import qualified Generic.Random@@ -72,13 +76,6 @@ import qualified Test.Tasty.QuickCheck import qualified Text.Megaparsec       as Megaparsec -newtype DeserialiseFailureWithEq = D DeserialiseFailure-    deriving (Show)--instance Eq DeserialiseFailureWithEq where-    D (DeserialiseFailure aL bL) == D (DeserialiseFailure aR bR) =-        aL == aR && bL == bR- instance (Arbitrary a, Ord a) => Arbitrary (Set a) where   arbitrary = Dhall.Set.fromList <$> arbitrary   shrink = map Dhall.Set.fromList . shrink . Dhall.Set.toList@@ -140,6 +137,42 @@         , (1, fmap (\x -> x - (2 ^ (64 :: Int))) arbitrary)         ] +instance Arbitrary CharacterSet where+    arbitrary = Test.QuickCheck.elements [ ASCII, Unicode ]++instance Arbitrary Header where+    arbitrary = do+      let commentChar =+              Test.QuickCheck.frequency+                  [ (20, Test.QuickCheck.elements [' ' .. '\DEL'])+                  , ( 1, arbitrary)+                  ]++          commentText = Text.pack <$> Test.QuickCheck.listOf commentChar++          multiline = do+              txt <- commentText+              pure $ "{-" <> txt <> "-}"++          singleline = do+              txt <- commentText `suchThat` (not . Text.isInfixOf "\n")+              endOfLine <- Test.QuickCheck.elements ["\n", "\r\n"]+              pure $ "--" <> txt <> endOfLine++          newlines = Text.concat <$> Test.QuickCheck.listOf (pure "\n")++      comments <- do+          n <- Test.QuickCheck.choose (0, 2)+          Test.QuickCheck.vectorOf n $ Test.QuickCheck.oneof+              [ multiline+              , singleline+              , newlines+              ]++      pure . createHeader $ Text.unlines comments++    shrink (Header txt) = createHeader . Text.pack <$> shrink (Text.unpack txt)+ instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where     arbitrary = do         n   <- Test.QuickCheck.choose (0, 2)@@ -241,6 +274,8 @@             % (1 :: W "NaturalTimes")             % (1 :: W "Integer")             % (7 :: W "IntegerLit")+            % (1 :: W "IntegerClamp")+            % (1 :: W "IntegerNegate")             % (1 :: W "IntegerShow")             % (1 :: W "IntegerToDouble")             % (1 :: W "Double")@@ -368,21 +403,11 @@  binaryRoundtrip :: Expr () Import -> Property binaryRoundtrip expression =-        wrap-            (fmap-                Dhall.Binary.decodeExpression-                (Codec.Serialise.deserialiseOrFail-                  (Codec.Serialise.serialise-                    (Dhall.Binary.encodeExpression expression)-                  )-                )-            )-    === wrap (Right (Right (Dhall.Core.denote expression :: Expr () Import)))+        Dhall.Binary.decodeExpression (Dhall.Binary.encodeExpression denotedExpression)+    === Right denotedExpression   where-    wrap-        :: Either DeserialiseFailure       a-        -> Either DeserialiseFailureWithEq a-    wrap = Data.Coerce.coerce+    denotedExpression :: Expr Void Import+    denotedExpression = Dhall.Core.denote expression  everythingWellTypedNormalizes :: Expr () () -> Property everythingWellTypedNormalizes expression =@@ -450,17 +475,23 @@ embedThenExtractIsIdentity     :: forall a. (ToDhall a, FromDhall a, Eq a, Typeable a, Arbitrary a, Show a)     => Proxy a-    -> (String, Property, QuickCheckTests)+    -> (String, Property, TestTree -> TestTree) embedThenExtractIsIdentity p =     ( "Embedding then extracting is identity for " ++ show (typeRep p)     , Test.QuickCheck.property (prop :: a -> Bool)-    , QuickCheckTests 1000+    , adjustQuickCheckTests 1000     )   where     prop a = case extract auto (embed inject a) of         Success a' -> a == a'         Failure _  -> False +idempotenceTest :: CharacterSet -> Header -> Expr Src Import -> Property+idempotenceTest characterSet header expr =+    let once = format characterSet (header, expr)+    in case Parser.exprAndHeaderFromText mempty once of+        Right (format characterSet -> twice) -> once === twice+        Left _ -> Test.QuickCheck.discard  tests :: TestTree tests =@@ -468,31 +499,31 @@         "QuickCheck"         [ ( "Binary serialization should round-trip"           , Test.QuickCheck.property binaryRoundtrip-          , QuickCheckTests 100+          , adjustQuickCheckTests 100           )         , ( "everything well-typed should normalize"           , Test.QuickCheck.property everythingWellTypedNormalizes-          , QuickCheckTests 100000+          , adjustQuickCheckTests 100000           )         , ( "isNormalized should be consistent with normalize"           , Test.QuickCheck.property isNormalizedIsConsistentWithNormalize-          , QuickCheckTests 10000+          , adjustQuickCheckTests 10000           )         , ( "normalizeWithM should be consistent with normalize"           , Test.QuickCheck.property normalizeWithMIsConsistentWithNormalize-          , QuickCheckTests 10000+          , adjustQuickCheckTests 10000           )         , ( "An expression should have no difference with itself"           , Test.QuickCheck.property isSameAsSelf-          , QuickCheckTests 10000+          , adjustQuickCheckTests 10000           )         , ( "Inferred types should be normalized"           , Test.QuickCheck.property inferredTypesAreNormalized-          , QuickCheckTests 10000+          , adjustQuickCheckTests 10000           )         , ( "Normalizing an expression doesn't change its inferred type"           , Test.QuickCheck.property normalizingAnExpressionDoesntChangeItsInferredType-          , QuickCheckTests 10000+          , adjustQuickCheckTests 10000           )         , embedThenExtractIsIdentity (Proxy :: Proxy (Text.Text))         , embedThenExtractIsIdentity (Proxy :: Proxy [Nat.Natural])@@ -504,13 +535,28 @@         , embedThenExtractIsIdentity (Proxy :: Proxy (Vector Double))         , embedThenExtractIsIdentity (Proxy :: Proxy (Data.Map.Map Double Bool))         , embedThenExtractIsIdentity (Proxy :: Proxy (HashMap.HashMap Double Bool))+        , ( "Formatting should be idempotent"+          , Test.QuickCheck.property idempotenceTest++            -- FIXME: While this test is flaky, we set the number of test cases+            -- to 0 by subtracting the default number of tests (100).+            -- To run the test manually, use e.g.+            --    --quickcheck-tests 1000+          , Test.Tasty.adjustOption (subtract (QuickCheckTests 100))+          )         ] +adjustQuickCheckMaxRatio :: Int -> TestTree -> TestTree+adjustQuickCheckMaxRatio maxSize =+    Test.Tasty.adjustOption (max $ Test.Tasty.QuickCheck.QuickCheckMaxRatio maxSize) +adjustQuickCheckTests :: Int -> TestTree -> TestTree+adjustQuickCheckTests nTests =+    -- Using adjustOption instead of withMaxSuccess allows us to override the number of tests+    -- with the --quickcheck-tests CLI option.+    Test.Tasty.adjustOption (max $ QuickCheckTests nTests) -testProperties' :: String -> [(String, Property, QuickCheckTests)] -> TestTree+testProperties' :: String -> [(String, Property, TestTree -> TestTree)] -> TestTree testProperties' name = Test.Tasty.testGroup name . map f   where-    -- Using adjustOption instead of withMaxSuccess allows us to override the number of tests-    -- with the --quickcheck-tests CLI option.-    f (n, p, nTests) = Test.Tasty.adjustOption (max nTests) (Test.Tasty.QuickCheck.testProperty n p)+    f (n, p, adjust) = adjust (Test.Tasty.QuickCheck.testProperty n p)

tests/Dhall/Test/Regression.hs view

@@ -42,6 +42,7 @@         , issue1131a         , issue1131b         , issue1341+        , issue1584         , parsing0         , typeChecking0         , typeChecking1@@ -55,7 +56,7 @@  unnamedFields :: TestTree unnamedFields = Test.Tasty.HUnit.testCase "Unnamed Fields" (do-    let ty = Dhall.auto :: Dhall.Type Foo+    let ty = Dhall.auto :: Dhall.Decoder Foo     Test.Tasty.HUnit.assertEqual "Good type" (Dhall.expected ty)         (Dhall.Core.Union             (Dhall.Map.fromList@@ -69,14 +70,14 @@             )         ) -    let inj = Dhall.inject :: Dhall.InputType Foo+    let inj = Dhall.inject :: Dhall.Encoder Foo     Test.Tasty.HUnit.assertEqual "Good ToDhall" (Dhall.declared inj) (Dhall.expected ty) -    let tu_ty = Dhall.auto :: Dhall.Type (Integer, Bool)+    let tu_ty = Dhall.auto :: Dhall.Decoder (Integer, Bool)     Test.Tasty.HUnit.assertEqual "Auto Tuple" (Dhall.expected tu_ty) (Dhall.Core.Record (             Dhall.Map.fromList [ ("_1",Dhall.Core.Integer),("_2",Dhall.Core.Bool) ])) -    let tu_in = Dhall.inject :: Dhall.InputType (Integer, Bool)+    let tu_in = Dhall.inject :: Dhall.Encoder (Integer, Bool)     Test.Tasty.HUnit.assertEqual "Inj. Tuple" (Dhall.declared tu_in) (Dhall.expected tu_ty)      return () )@@ -90,7 +91,7 @@ issue126 :: TestTree issue126 = Test.Tasty.HUnit.testCase "Issue #126" (do     e <- Util.code "''\nfoo\nbar\n''"-    Util.normalize' e @?= "\"foo\\nbar\\n\"" )+    Util.normalize' e @?= "''\nfoo\nbar\n''" )  issue151 :: TestTree issue151 = Test.Tasty.HUnit.testCase "Issue #151" (do@@ -147,7 +148,7 @@     source <- Data.Text.IO.readFile "./tests/regression/issue216b.dhall"     e <- Util.code source     let doc       = Data.Text.Prettyprint.Doc.pretty e-    let docStream = Data.Text.Prettyprint.Doc.layoutSmart Dhall.Pretty.layoutOpts doc+    let docStream = Dhall.Pretty.layout doc     let text0 = Data.Text.Prettyprint.Doc.Render.Text.renderLazy docStream      text1 <- Data.Text.Lazy.IO.readFile "./tests/regression/issue216b.dhall"@@ -179,6 +180,13 @@     let actual = Dhall.Core.V "x" 0 `Dhall.Core.freeIn` nan     let msg    = "NaN shouldn't contain any free variables"     Test.Tasty.HUnit.assertEqual msg False actual)++issue1584 :: TestTree+issue1584 = Test.Tasty.HUnit.testCase "Issue #1584" (do+    -- This test ensures that we can parse variables with keyword prefixes+    -- (e.g. `ifX`)+    _ <- Util.code "./tests/regression/issue1584.dhall"+    return () )  parsing0 :: TestTree parsing0 = Test.Tasty.HUnit.testCase "Parsing regression #0" (do

tests/diff/function.txt view

@@ -2,5 +2,5 @@ → … → …@- 1     + 0-  + → …

+ tests/diff/insideList.txt view

@@ -0,0 +1,7 @@+[ …+, { y = - 4+        + 5+  , …+  }+]+

+ tests/diff/insideListA.dhall view

@@ -0,0 +1,3 @@+[ { x = 1, y = 2 }+, { x = 3, y = 4 }+]

+ tests/diff/insideListB.dhall view

@@ -0,0 +1,3 @@+[ { x = 1, y = 2 }+, { x = 3, y = 5 }+]

tests/format/concatSepB.dhall view

@@ -23,7 +23,7 @@                       status                 )                 Status.Empty-        +         in  merge { Empty = "", NonEmpty = λ(result : Text) → result } status  let example0 = assert : concatSep ", " [ "ABC", "DEF", "GHI" ] ≡ "ABC, DEF, GHI"

+ tests/format/envVarsA.dhall view

@@ -0,0 +1,1 @@+[ env:x, env:"1", env:" ", env:"\\", env:"." ]

+ tests/format/envVarsB.dhall view

@@ -0,0 +1,1 @@+[ env:x, env:"1", env:" ", env:"\\", env:"." ]

tests/format/escapeSingleQuotedOpenInterpolationB.dhall view

@@ -1,1 +1,3 @@-"\${\n"+''+''${+''

tests/format/headerB.dhall view

@@ -1,3 +1,3 @@ {- bla -}-  + True

+ tests/format/importAltPrecedenceA.dhall view

@@ -0,0 +1,1 @@+a ? b || c

+ tests/format/importAltPrecedenceB.dhall view

@@ -0,0 +1,1 @@+a ? b || c

tests/format/innerMultilineB.dhall view

@@ -1,1 +1,11 @@-{ inner = "\none\n\ntwo\n\nthree\n\n" }+{ inner =+    ''++    one++    two++    three++    ''+}

+ tests/format/interpolation0A.dhall view

@@ -0,0 +1,1 @@+"foo\n${a} bar"

+ tests/format/interpolation0B.dhall view

@@ -0,0 +1,3 @@+''+foo+${a} bar''

+ tests/format/issue1400-1A.dhall view

@@ -0,0 +1,14 @@+{ conversation =+    [ { author = "robert", content = [] }+    , { author = "robert", content = [] }+    , { author =+          "bob"+      , content =+          [ text+              ''+              any line going past the 80 characters boundary (e.g. this one is 82)+              ''+          ]+      }+    ]+}

+ tests/format/issue1400-1B.dhall view

@@ -0,0 +1,13 @@+{ conversation =+    [ { author = "robert", content = [] }+    , { author = "robert", content = [] }+    , { author = "bob"+      , content =+          [ text+              ''+              any line going past the 80 characters boundary (e.g. this one is 82)+              ''+          ]+      }+    ]+}

+ tests/format/issue1400-2A.dhall view

@@ -0,0 +1,14 @@+let Tagged+    : Type → Type+    =   λ ( a+          : Type+          )+      → { field :+            Text+        , nesting :+              ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335+            ? ./Nesting+        , contents : a+        }++in  Tagged

+ tests/format/issue1400-2B.dhall view

@@ -0,0 +1,11 @@+let Tagged+    : Type → Type+    =   λ(a : Type)+      → { field : Text+        , nesting :+              ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335+            ? ./Nesting+        , contents : a+        }++in  Tagged

tests/format/issue1413B.dhall view

@@ -1,5 +1,5 @@ let foo =-    +     {- test -}       "hello"

+ tests/format/issue1545-1A.dhall view

@@ -0,0 +1,1 @@+"\n\tx"

+ tests/format/issue1545-1B.dhall view

@@ -0,0 +1,3 @@+''++${"\t"}x''

+ tests/format/issue1545-2A.dhall view

@@ -0,0 +1,1 @@+"\n x"

+ tests/format/issue1545-2B.dhall view

@@ -0,0 +1,3 @@+''++${" "}x''

+ tests/format/issue183A.dhall view

@@ -0,0 +1,11 @@+    let foo = 1++in    λ(bar : Integer)+    →     let exposePort =+                  λ(portSpec : { ext : Integer, int : Integer })+                → Integer/show portSpec.ext ++ ":" ++ Integer/show portSpec.int+      +      in  let exposeSamePort =+                λ(port : Integer) → exposePort { ext = port, int = port }+      +      in  { blah = bar }

+ tests/format/issue183B.dhall view

@@ -0,0 +1,11 @@+let foo = 1++in    λ(bar : Integer)+    → let exposePort =+              λ(portSpec : { ext : Integer, int : Integer })+            → Integer/show portSpec.ext ++ ":" ++ Integer/show portSpec.int++      in  let exposeSamePort =+                λ(port : Integer) → exposePort { ext = port, int = port }++          in  { blah = bar }

tests/format/letNewlineCommentsB.dhall view

@@ -5,5 +5,5 @@         : {- bbbbbbbbbbbbbbbbbbbbb           -} Natural         = {- ddddddddddddddddd -} 2-    +     in  x

+ tests/format/multilineArgumentA.dhall view

@@ -0,0 +1,1 @@+fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff xxxxxxxxxxxxxxxx "\n"

+ tests/format/multilineArgumentB.dhall view

@@ -0,0 +1,3 @@+fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff+  xxxxxxxxxxxxxxxx+  "\n"

tests/format/multilineB.dhall view

@@ -1,1 +1,3 @@-"ABC\nDEF"+''+ABC+DEF''

+ tests/format/multilineTrailingSingleQuoteA.dhall view

@@ -0,0 +1,1 @@+"\n'"

+ tests/format/multilineTrailingSingleQuoteB.dhall view

@@ -0,0 +1,3 @@+''++${"'"}''

+ tests/format/multilineTrailingWhitespaceA.dhall view

@@ -0,0 +1,1 @@+{ x = "  \n\nfoo  \n" }

+ tests/format/multilineTrailingWhitespaceB.dhall view

@@ -0,0 +1,7 @@+{ x =+    ''+      ++    foo  +    ''+}

+ tests/format/nestedAnnotationA.dhall view

@@ -0,0 +1,1 @@+([] : a) : b

+ tests/format/nestedAnnotationB.dhall view

@@ -0,0 +1,1 @@+([] : a) : b

+ tests/format/stringWithNullA.dhall view

@@ -0,0 +1,1 @@+"\u0000 \$ \\ \n ☺"

+ tests/format/stringWithNullB.dhall view

@@ -0,0 +1,3 @@+''+${"\u0000"} $ \ +${" "}☺''

+ tests/format/textLitNewlinesOnlyA.dhall view

@@ -0,0 +1,1 @@+"\n\n"

+ tests/format/textLitNewlinesOnlyB.dhall view

@@ -0,0 +1,1 @@+"\n\n"

+ tests/regression/issue1584.dhall view

@@ -0,0 +1,19 @@+[ let ifX = 1 in ifX+, let thenX = 1 in thenX+, let elseX = 1 in elseX+, let letX = 1 in letX+, let inX = 1 in inX+, let usingX = 1 in usingX+{- Fixing this case appears to be difficult for the current parser+   implementation+-}+-- , let missingX = 1 in missingX+, let asX = 1 in asX+, let InfinityX = 1 in InfinityX+, let NaNX = 1 in NaNX+, let mergeX = 1 in mergeX+, let SomeX = 1 in SomeX+, let toMapX = 1 in toMapX+, let assertX = 1 in assertX+, let forallX = 1 in forallX+]