diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,63 @@ +1.23.0 + +* BREAKING CHANGE: Fix marshaling union literals + * 1.22.0 introduced two separate bugs in marshaling union literals between + Dhall and Haskell, which this release fixes: + * Dhall enums did not correctly map onto Haskell enums + * New-style union literals (i.e. `< A : T >.A x`) were not correctly + supported + * See: https://github.com/dhall-lang/dhall-haskell/pull/918 + * See: https://github.com/dhall-lang/dhall-haskell/pull/927 + * See: https://github.com/dhall-lang/dhall-haskell/pull/936 +* BUG FIX: Fix α-normalization + * Version 1.22.0 introduced a new faster evaluation algorithm, but the new + algorithm introduced two α-normalization regression, which this release + fixes + * The primary effect of this bug was that semantic integrity checks would + fail for expressions that contain an `if`/`then`/else` expression in their + normal form + * See: https://github.com/dhall-lang/dhall-haskell/pull/931 + * See: https://github.com/dhall-lang/dhall-haskell/pull/938 +* BUG FIX: Fix merging of sort-level record types + * The language standard requires that `{ a : Kind } ⩓ { b : Kind }` is + valid, which this change fixes + * See: https://github.com/dhall-lang/dhall-haskell/pull/891 +* BUG FIX: `dhall freeze` respects the `--ascii` flag + * See: https://github.com/dhall-lang/dhall-haskell/pull/934 +* BUG FIX: Don't autocomplete fields for record types + * This prevents the REPL from expanding `{ x : T }.` to `{ x : T }.x` + * See: https://github.com/dhall-lang/dhall-haskell/pull/937 +* Support `MonadFail`-related changes in GHC 8.8 + * See: https://github.com/dhall-lang/dhall-haskell/pull/912 +* Add `cross` flag to simplify cross-compilation + * This allows the `dhall` package to be built without using + `TemplateHaskell` + * See: https://github.com/dhall-lang/dhall-haskell/pull/928 +* Increase lines of context for error messages + * Error messages now provide at least 20 lines of context instead of 3 + before truncating large expressions + * See: https://github.com/dhall-lang/dhall-haskell/pull/916 +* Add line numbers to error messages + * The bottom of every Dhall type error includes the original source code, + which now has line numbers on the left margin + * See: https://github.com/dhall-lang/dhall-haskell/pull/919 +* Expand lower bounds on `megaparsec`/`transformers-compat` dependencies + * This is to support `dhall` on Debian Sid + * See: https://github.com/dhall-lang/dhall-haskell/pull/939 + 1.22.0 * Supports version 7.0.0 of the standard * See: https://github.com/dhall-lang/dhall-lang/releases/tag/v7.0.0 +* BREAKING CHANGE: Add support for empty alternatives + * The `Union` type now has an optional (`Maybe`) type for each alternative + * See the changelog for standard version 7.0.0 for more details + * See: https://github.com/dhall-lang/dhall-haskell/pull/863 +* BREAKING CHANGE: Remove support for URL fragments + * The `URL` type no longer has a field for a URL fragment since the language + no longer supports fragments + * See the changelog for standard version 7.0.0 for more details + * See: https://github.com/dhall-lang/dhall-haskell/pull/851 * BREAKING CHANGE: Remove deprecated `Path` type synonym * See: https://github.com/dhall-lang/dhall-haskell/pull/858 * BUG FIX: Correctly parse identifiers beginning with `http` diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,6 +1,6 @@ Name: dhall -Version: 1.22.0 -Cabal-Version: >=1.10 +Version: 1.23.0 +cabal-Version: >=1.10 Build-Type: Simple Tested-With: GHC == 7.10.3, GHC == 8.4.3, GHC == 8.6.1 License: BSD3 @@ -375,6 +375,11 @@ Default: True Manual: True +Flag cross + Description: Disable TemplateHaskell to make cross-compiling easier + Default: False + Manual: True + Library Hs-Source-Dirs: src Build-Depends: @@ -396,19 +401,20 @@ filepath >= 1.4 && < 1.5 , haskeline >= 0.7.2.1 && < 0.8 , lens-family-core >= 1.0.0 && < 1.3 , - megaparsec >= 7.0.0 && < 7.1 , + megaparsec >= 6.5.0 && < 7.1 , memory >= 0.14 && < 0.15, mtl >= 2.2.1 && < 2.3 , optparse-applicative >= 0.14.0.0 && < 0.15, parsers >= 0.12.4 && < 0.13, prettyprinter >= 1.2.0.1 && < 1.3 , prettyprinter-ansi-terminal >= 1.1.1 && < 1.2 , - repline >= 0.2.0.0 && < 0.3 , + repline >= 0.2.1.0 && < 0.3 , serialise >= 0.2.0.0 && < 0.3 , scientific >= 0.3.0.0 && < 0.4 , template-haskell < 2.15, text >= 0.11.1.0 && < 1.3 , transformers >= 0.2.0.0 && < 0.6 , + transformers-compat >= 0.6.2 && < 0.7 , unordered-containers >= 0.1.3.0 && < 0.3 , uri-encode < 1.6 , vector >= 0.11.0.0 && < 0.13 @@ -424,6 +430,34 @@ if impl(ghcjs) Build-Depends: ghcjs-xhr + Other-Extensions: + BangPatterns + CPP + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFunctor + DeriveGeneric + DeriveTraversable + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + MultiParamTypeClasses + NamedFieldPuns + OverloadedLists + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeOperators + UnicodeSyntax + if !flag(cross) + Other-Extensions: + TemplateHaskell + Exposed-Modules: Dhall, Dhall.Binary, @@ -441,9 +475,11 @@ Dhall.Parser, Dhall.Pretty, Dhall.Repl, - Dhall.TH, Dhall.Tutorial, Dhall.TypeCheck + if !flag(cross) + Exposed-Modules: + Dhall.TH Other-Modules: Dhall.Pretty.Internal, Dhall.Parser.Expression, @@ -539,6 +575,8 @@ serialise , text >= 0.11.1.0 && < 1.3 Default-Language: Haskell2010 + Other-Extensions: + TypeApplications ghc-options: -rtsopts Benchmark deep-nested-large-record @@ -571,4 +609,4 @@ criterion >= 1.1 && < 1.6, dhall Default-Language: Haskell2010 --- ghc-options: -rtsopts -O2 + ghc-options: -rtsopts -O2 diff --git a/src/Dhall.hs b/src/Dhall.hs --- a/src/Dhall.hs +++ b/src/Dhall.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -71,6 +72,7 @@ , Inject(..) , inject + , genericInject , RecordInputType(..) , inputFieldWith , inputField @@ -146,6 +148,7 @@ -- $setup -- >>> :set -XOverloadedStrings +-- >>> :set -XRecordWildCards {-| Every `Type` must obey the contract that if an expression's type matches the the `expected` type then the `extract` function must succeed. If not, then @@ -921,9 +924,11 @@ unsafeExpectUnionLit :: Text -> Expr Src X - -> (Text, Expr Src X, Dhall.Map.Map Text (Maybe (Expr Src X))) -unsafeExpectUnionLit _ (UnionLit k v kts) = - (k, v, kts) + -> (Text, Maybe (Expr Src X)) +unsafeExpectUnionLit _ (Field (Union _) k) = + (k, Nothing) +unsafeExpectUnionLit _ (App (Field (Union _) k) v) = + (k, Just v) unsafeExpectUnionLit name expression = Dhall.Core.internalError (name <> ": Unexpected constructor: " <> Dhall.Core.pretty expression) @@ -935,11 +940,26 @@ Dhall.Core.internalError (name <> ": Unexpected constructor: " <> Dhall.Core.pretty expression) -possible :: Expr s a -> Maybe (Expr s a) -possible e = case e of +notEmptyRecordLit :: Expr s a -> Maybe (Expr s a) +notEmptyRecordLit e = case e of RecordLit m | null m -> Nothing _ -> Just e +notEmptyRecord :: Expr s a -> Maybe (Expr s a) +notEmptyRecord e = case e of + Record m | null m -> Nothing + _ -> Just e +extractUnionConstructor + :: Expr s a -> Maybe (Text, Expr s a, Dhall.Map.Map Text (Maybe (Expr s a))) +extractUnionConstructor (UnionLit fld e rest) = + return (fld, e, rest) +extractUnionConstructor (App (Field (Union kts) fld) e) = + return (fld, e, Dhall.Map.delete fld kts) +extractUnionConstructor (Field (Union kts) fld) = + return (fld, RecordLit mempty, Dhall.Map.delete fld kts) +extractUnionConstructor _ = + empty + instance (Constructor c1, Constructor c2, GenericInterpret f1, GenericInterpret f2) => GenericInterpret (M1 C c1 f1 :+: M1 C c2 f2) where genericAutoWith options@(InterpretOptions {..}) = pure (Type {..}) where @@ -952,16 +972,19 @@ nameL = constructorModifier (Data.Text.pack (conName nL)) nameR = constructorModifier (Data.Text.pack (conName nR)) - extract (UnionLit name e _) - | name == nameL = fmap (L1 . M1) (extractL e) - | name == nameR = fmap (R1 . M1) (extractR e) - | otherwise = Nothing - extract _ = Nothing + extract e0 = do + (name, e1, _) <- extractUnionConstructor e0 + if + | name == nameL -> fmap (L1 . M1) (extractL e1) + | name == nameR -> fmap (R1 . M1) (extractR e1) + | otherwise -> Nothing expected = Union (Dhall.Map.fromList - [(nameL, possible expectedL), (nameR, possible expectedR)] + [ (nameL, notEmptyRecord expectedL) + , (nameR, notEmptyRecord expectedR) + ] ) Type extractL expectedL = evalState (genericAutoWith options) 1 @@ -975,13 +998,14 @@ name = constructorModifier (Data.Text.pack (conName n)) - extract u@(UnionLit name' e _) - | name == name' = fmap (R1 . M1) (extractR e) - | otherwise = fmap L1 (extractL u) - extract _ = Nothing + extract u = do + (name', e, _) <- extractUnionConstructor u + if + | name == name' -> fmap (R1 . M1) (extractR e) + | otherwise -> fmap L1 (extractL u) expected = - Union (Dhall.Map.insert name (possible expectedR) ktsL) + Union (Dhall.Map.insert name (notEmptyRecord expectedR) ktsL) Type extractL expectedL = evalState (genericAutoWith options) 1 Type extractR expectedR = evalState (genericAutoWith options) 1 @@ -996,13 +1020,14 @@ name = constructorModifier (Data.Text.pack (conName n)) - extract u@(UnionLit name' e _) - | name == name' = fmap (L1 . M1) (extractL e) - | otherwise = fmap R1 (extractR u) - extract _ = Nothing + extract u = do + (name', e, _) <- extractUnionConstructor u + if + | name == name' -> fmap (L1 . M1) (extractL e) + | otherwise -> fmap R1 (extractR u) expected = - Union (Dhall.Map.insert name (possible expectedL) ktsR) + Union (Dhall.Map.insert name (notEmptyRecord expectedL) ktsR) Type extractL expectedL = evalState (genericAutoWith options) 1 Type extractR expectedR = evalState (genericAutoWith options) 1 @@ -1116,6 +1141,17 @@ inject :: Inject a => InputType a inject = injectWith defaultInterpretOptions +{-| Use the default options for injecting a value, whose structure is +determined generically. + +This can be used when you want to use 'Inject' on types that you don't +want to define orphan instances for. +-} +genericInject + :: (Generic a, GenericInject (Rep a)) => InputType a +genericInject + = contramap GHC.Generics.from (evalState (genericInjectWith defaultInterpretOptions) 1) + instance Inject Bool where injectWith _ = InputType {..} where @@ -1253,21 +1289,25 @@ genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..}) where embed (L1 (M1 l)) = - UnionLit - keyL - (embedL l) - (Dhall.Map.singleton keyR (possible declaredR)) + case notEmptyRecordLit (embedL l) of + Nothing -> + Field declared keyL + Just valL -> + App (Field declared keyL) valL embed (R1 (M1 r)) = - UnionLit - keyR - (embedR r) - (Dhall.Map.singleton keyL (possible declaredL)) + case notEmptyRecordLit (embedR r) of + Nothing -> + Field declared keyR + Just valR -> + App (Field declared keyR) valR declared = Union (Dhall.Map.fromList - [(keyL, possible declaredL), (keyR, possible declaredR)] + [ (keyL, notEmptyRecord declaredL) + , (keyR, notEmptyRecord declaredR) + ] ) nL :: M1 i c1 f1 a @@ -1286,38 +1326,42 @@ genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..}) where embed (L1 l) = - UnionLit - keyL - valL - (Dhall.Map.insert keyR (possible declaredR) ktsL') + case maybeValL of + Nothing -> Field declared keyL + Just valL -> App (Field declared keyL) valL where - (keyL, valL, ktsL') = + (keyL, maybeValL) = unsafeExpectUnionLit "genericInjectWith (:+:)" (embedL l) - embed (R1 (M1 r)) = UnionLit keyR (embedR r) ktsL + embed (R1 (M1 r)) = + case notEmptyRecordLit (embedR r) of + Nothing -> Field declared keyR + Just valR -> App (Field declared keyR) valR nR :: M1 i c h a nR = undefined keyR = constructorModifier (Data.Text.pack (conName nR)) - declared = Union (Dhall.Map.insert keyR (possible declaredR) ktsL) + declared = Union (Dhall.Map.insert keyR (notEmptyRecord declaredR) ktsL) - InputType embedL declaredL = evalState (genericInjectWith options) 1 - InputType embedR declaredR = evalState (genericInjectWith options) 1 + InputType embedL declaredL = evalState (genericInjectWith options) 1 + InputType embedR declaredR = evalState (genericInjectWith options) 1 ktsL = unsafeExpectUnion "genericInjectWith (:+:)" declaredL instance (Constructor c, GenericInject f, GenericInject (g :+: h)) => GenericInject (M1 C c f :+: (g :+: h)) where genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..}) where - embed (L1 (M1 l)) = UnionLit keyL (embedL l) ktsR + embed (L1 (M1 l)) = + case notEmptyRecordLit (embedL l) of + Nothing -> Field declared keyL + Just valL -> App (Field declared keyL) valL embed (R1 r) = - UnionLit - keyR - valR - (Dhall.Map.insert keyL (possible declaredL) ktsR') + case maybeValR of + Nothing -> Field declared keyR + Just valR -> App (Field declared keyR) valR where - (keyR, valR, ktsR') = + (keyR, maybeValR) = unsafeExpectUnionLit "genericInjectWith (:+:)" (embedR r) nL :: M1 i c f a @@ -1325,7 +1369,7 @@ keyL = constructorModifier (Data.Text.pack (conName nL)) - declared = Union (Dhall.Map.insert keyL (possible declaredL) ktsR) + declared = Union (Dhall.Map.insert keyL (notEmptyRecord declaredL) ktsR) InputType embedL declaredL = evalState (genericInjectWith options) 1 InputType embedR declaredR = evalState (genericInjectWith options) 1 @@ -1336,14 +1380,18 @@ genericInjectWith options = pure (InputType {..}) where embed (L1 l) = - UnionLit keyL valL (Dhall.Map.union ktsL' ktsR) + case maybeValL of + Nothing -> Field declared keyL + Just valL -> App (Field declared keyL) valL where - (keyL, valL, ktsL') = + (keyL, maybeValL) = unsafeExpectUnionLit "genericInjectWith (:+:)" (embedL l) embed (R1 r) = - UnionLit keyR valR (Dhall.Map.union ktsL ktsR') + case maybeValR of + Nothing -> Field declared keyR + Just valR -> App (Field declared keyR) valR where - (keyR, valR, ktsR') = + (keyR, maybeValR) = unsafeExpectUnionLit "genericInjectWith (:+:)" (embedR r) declared = Union (Dhall.Map.union ktsL ktsR) @@ -1401,11 +1449,13 @@ For example, let's take the following Haskell data type: -> data Project = Project -> { projectName :: Text -> , projectDescription :: Text -> , projectStars :: Natural -> } +>>> :{ +data Project = Project + { projectName :: Text + , projectDescription :: Text + , projectStars :: Natural + } +:} And assume that we have the following Dhall record that we would like to parse as a @Project@: @@ -1422,14 +1472,15 @@ 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@: -> project :: Type Project -> project = -> record -> ( Project <$> field "name" string -> <*> field "description" string -> <*> field "stars" natural -> ) - +>>> :{ +project :: Type Project +project = + record + ( Project <$> field "name" strictText + <*> field "description" strictText + <*> field "stars" natural + ) +:} -} newtype RecordType a = @@ -1489,9 +1540,11 @@ For example, let's take the following Haskell data type: -> data Status = Queued Natural -> | Result Text -> | Errored Text +>>> :{ +data Status = Queued Natural + | Result Text + | Errored Text +:} And assume that we have the following Dhall union that we would like to parse as a @Status@: @@ -1505,13 +1558,14 @@ 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@: -> status :: Type Status -> status = -> union -> ( Queued <$> constructor "Queued" natural -> <> Result <$> constructor "Result" string -> <> Errored <$> constructor "Errored" string -> ) +>>> :{ +status :: Type Status +status = union + ( ( Queued <$> constructor "Queued" natural ) + <> ( Result <$> constructor "Result" strictText ) + <> ( Errored <$> constructor "Errored" strictText ) + ) +:} -} newtype UnionType a = @@ -1533,14 +1587,18 @@ , expected = Union expect } where - expect = (possible . Dhall.expected) <$> mp + expect = (notEmptyRecord . Dhall.expected) <$> mp + extractF e0 = do - UnionLit fld e1 rest <- Just e0 + (fld, e1, rest) <- extractUnionConstructor e0 + t <- Dhall.Map.lookup fld mp + guard $ Dhall.Core.Union rest `Dhall.Core.judgmentallyEqual` Dhall.Core.Union (Dhall.Map.delete fld expect) - Dhall.extract t e1 + extract t e1 + -- | Parse a single constructor of a union constructor :: Text -> Type a -> UnionType a constructor key valueType = UnionType @@ -1551,11 +1609,13 @@ For example, let's take the following Haskell data type: -> data Project = Project -> { projectName :: Text -> , projectDescription :: Text -> , projectStars :: Natural -> } +>>> :{ +data Project = Project + { projectName :: Text + , projectDescription :: Text + , projectStars :: Natural + } +:} And assume that we have the following Dhall record that we would like to parse as a @Project@: @@ -1572,27 +1632,31 @@ 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@: -> injectProject :: InputType Project -> injectProject = -> inputRecord -> ( adapt >$< inputFieldWith "name" inject -> >*< inputFieldWith "description" inject -> >*< inputFieldWith "stars" inject -> ) -> where -> adapt (Project{..}) = (projectName, (projectDescription, projectStars)) +>>> :{ +injectProject :: InputType Project +injectProject = + inputRecord + ( adapt >$< inputFieldWith "name" inject + >*< inputFieldWith "description" inject + >*< inputFieldWith "stars" inject + ) + where + adapt (Project{..}) = (projectName, (projectDescription, projectStars)) +:} Or, since we are simply using the `Inject` instance to inject each field, we could write -> injectProject :: InputType Project -> injectProject = -> inputRecord -> ( adapt >$< inputField "name" -> >*< inputField "description" -> >*< inputField "stars" -> ) -> where -> adapt (Project{..}) = (projectName, (projectDescription, projectStars)) +>>> :{ +injectProject :: InputType Project +injectProject = + inputRecord + ( adapt >$< inputField "name" + >*< inputField "description" + >*< inputField "stars" + ) + where + adapt (Project{..}) = (projectName, (projectDescription, projectStars)) +:} -} @@ -1633,9 +1697,11 @@ For example, let's take the following Haskell data type: -> data Status = Queued Natural -> | Result Text -> | Errored Text +>>> :{ +data Status = Queued Natural + | Result Text + | Errored Text +:} And assume that we have the following Dhall union that we would like to parse as a @Status@: @@ -1647,31 +1713,36 @@ 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 'InputUnionType' to build an 'InputType' for @Status@: + However, we can use an 'UnionInputType' to build an 'InputType' for @Status@: -> injectStatus :: InputType Status -> injectStatus = -> adapt -> >$< inputConstructorWith "Queued" inject -> >|< inputConstructorWith "Result" inject -> >|< inputConstructorWith "Errored" inject -> where -> adapt (Queued n) = Left (Left n) -> adapt (Result t) = Left (Right t) -> adapt (Errored e) = Right e +>>> :{ +injectStatus :: InputType Status +injectStatus = adapt >$< inputUnion + ( inputConstructorWith "Queued" inject + >|< inputConstructorWith "Result" inject + >|< inputConstructorWith "Errored" inject + ) + where + adapt (Queued n) = Left n + adapt (Result t) = Right (Left t) + adapt (Errored e) = Right (Right e) +:} Or, since we are simply using the `Inject` instance to inject each branch, we could write -> injectStatus :: InputType Status -> injectStatus = -> adapt -> >$< inputConstructor "Queued" -> >|< inputConstructor "Result" -> >|< inputConstructor "Errored" -> where -> adapt (Queued n) = Left (Left n) -> adapt (Result t) = Left (Right t) -> adapt (Errored e) = Right e +>>> :{ +injectStatus :: InputType Status +injectStatus = adapt >$< inputUnion + ( inputConstructor "Queued" + >|< inputConstructor "Result" + >|< inputConstructor "Errored" + ) + where + adapt (Queued n) = Left n + adapt (Result t) = Right (Left t) + adapt (Errored e) = Right (Right e) +:} + -} newtype UnionInputType a = UnionInputType @@ -1709,12 +1780,14 @@ InputType { embed = \x -> let (name, y) = embedF x - in UnionLit name y (Dhall.Map.delete name fields') + in case notEmptyRecordLit y of + Nothing -> Field (Union fields') name + Just val -> App (Field (Union fields') name) val , declared = Union fields' } where - fields' = fmap possible fields + fields' = fmap notEmptyRecord fields inputConstructorWith :: Text diff --git a/src/Dhall/Eval.hs b/src/Dhall/Eval.hs --- a/src/Dhall/Eval.hs +++ b/src/Dhall/Eval.hs @@ -843,7 +843,7 @@ go !acc (NBind env x) !i | x == topX = if i == 0 then Var (V "_" acc) else go (acc + 1) env (i - 1) | otherwise = go (acc + 1) env i - go acc NEmpty i = Var (V topX topI) + go acc NEmpty i = Var (V topX i) goEnv :: Names -> Expr s a -> Expr s a goEnv !e t = let @@ -878,7 +878,7 @@ BoolOr t u -> BoolOr (go t) (go u) BoolEQ t u -> BoolEQ (go t) (go u) BoolNE t u -> BoolNE (go t) (go u) - BoolIf b t f -> BoolIf (go t) (go t) (go f) + BoolIf b t f -> BoolIf (go b) (go t) (go f) Natural -> Natural NaturalLit n -> NaturalLit n NaturalFold -> NaturalFold diff --git a/src/Dhall/Freeze.hs b/src/Dhall/Freeze.hs --- a/src/Dhall/Freeze.hs +++ b/src/Dhall/Freeze.hs @@ -17,7 +17,7 @@ import Dhall.Core (Expr(..), Import(..), ImportHashed(..), ImportType(..)) import Dhall.Import (standardVersion) import Dhall.Parser (exprAndHeaderFromText, Src) -import Dhall.Pretty (annToAnsiStyle, layoutOpts) +import Dhall.Pretty (CharacterSet, annToAnsiStyle, layoutOpts, prettyCharacterSet) import Dhall.TypeCheck (X) import Lens.Family (set) import System.Console.ANSI (hSupportsANSI) @@ -100,15 +100,17 @@ Left err -> Control.Exception.throwIO err Right x -> return x -writeExpr :: Maybe FilePath -> (Text, Expr s Import) -> IO () -writeExpr inplace (header, expr) = do - let doc = Pretty.pretty header <> Pretty.pretty expr - let stream = Pretty.layoutSmart layoutOpts doc +writeExpr :: Maybe FilePath -> (Text, Expr s Import) -> CharacterSet -> IO () +writeExpr inplace (header, expr) characterSet = do + let doc = Pretty.pretty header + <> Dhall.Pretty.prettyCharacterSet characterSet expr + let unAnnotated = Pretty.layoutSmart layoutOpts (Pretty.unAnnotate doc) + case inplace of Just f -> System.IO.withFile f System.IO.WriteMode (\handle -> do - Pretty.renderIO handle (annToAnsiStyle <$> stream) + Pretty.renderIO handle unAnnotated Data.Text.IO.hPutStrLn handle "" ) Nothing -> do @@ -117,7 +119,7 @@ then Pretty.renderIO System.IO.stdout (annToAnsiStyle <$> Pretty.layoutSmart layoutOpts doc) else - Pretty.renderIO System.IO.stdout (Pretty.layoutSmart layoutOpts (Pretty.unAnnotate doc)) + Pretty.renderIO System.IO.stdout unAnnotated -- | Implementation of the @dhall freeze@ subcommand freeze @@ -126,9 +128,10 @@ -- to @stdout@ -> Bool -- ^ If `True` then freeze all imports, otherwise freeze only remote imports + -> CharacterSet -> StandardVersion -> IO () -freeze inplace everything _standardVersion = do +freeze inplace everything characterSet _standardVersion = do (text, directory) <- case inplace of Nothing -> do text <- Data.Text.IO.getContents @@ -145,6 +148,6 @@ let freezeFunction = if everything then freezeImport else freezeRemoteImport frozenExpression <- traverse (freezeFunction directory _standardVersion) parsedExpression - writeExpr inplace (header, frozenExpression) + writeExpr inplace (header, frozenExpression) characterSet where srcInfo = fromMaybe "(stdin)" inplace diff --git a/src/Dhall/Main.hs b/src/Dhall/Main.hs --- a/src/Dhall/Main.hs +++ b/src/Dhall/Main.hs @@ -440,7 +440,7 @@ Dhall.Format.format (Dhall.Format.Format {..}) Freeze {..} -> do - Dhall.Freeze.freeze inplace all_ standardVersion + Dhall.Freeze.freeze inplace all_ characterSet standardVersion Hash -> do Dhall.Hash.hash standardVersion diff --git a/src/Dhall/Parser.hs b/src/Dhall/Parser.hs --- a/src/Dhall/Parser.hs +++ b/src/Dhall/Parser.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} -- | This module contains Dhall's parsing logic @@ -42,13 +43,21 @@ -- | 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 } 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 diff --git a/src/Dhall/Parser/Combinators.hs b/src/Dhall/Parser/Combinators.hs --- a/src/Dhall/Parser/Combinators.hs +++ b/src/Dhall/Parser/Combinators.hs @@ -34,10 +34,14 @@ import qualified Dhall.Util 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 import qualified Text.Parser.Token.Style +import qualified Text.Printf -- | Source code extract data Src = Src !Text.Megaparsec.SourcePos !Text.Megaparsec.SourcePos Text @@ -68,7 +72,7 @@ instance Pretty Src where pretty (Src begin _ text) = - pretty (Dhall.Util.snip (prefix <> text)) + pretty (Dhall.Util.snip numberedLines) <> "\n" <> pretty (Text.Megaparsec.sourcePosPretty begin) where @@ -76,6 +80,28 @@ where n = Text.Megaparsec.unPos (Text.Megaparsec.sourceColumn begin) + ls = Data.Text.lines (prefix <> text) + + numberOfLines = length ls + + minimumNumber = + Text.Megaparsec.unPos (Text.Megaparsec.sourceLine begin) + + maximumNumber = minimumNumber + numberOfLines - 1 + + numberWidth :: Int + numberWidth = + truncate (logBase (10 :: Double) (fromIntegral maximumNumber)) + 1 + + adapt n line = Data.Text.pack outputString + where + inputString = Data.Text.unpack line + + outputString = + Text.Printf.printf ("%" <> show numberWidth <> "d: %s") n inputString + + numberedLines = Data.Text.unlines (zipWith adapt [minimumNumber..] ls) + {-| A `Parser` that is almost identical to @"Text.Megaparsec".`Text.Megaparsec.Parsec`@ except treating Haskell-style comments as whitespace @@ -210,7 +236,11 @@ 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 diff --git a/src/Dhall/Parser/Expression.hs b/src/Dhall/Parser/Expression.hs --- a/src/Dhall/Parser/Expression.hs +++ b/src/Dhall/Parser/Expression.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedLists #-} @@ -27,16 +28,47 @@ import qualified Data.Text import qualified Data.Text.Encoding 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 +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 #-} + +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 #-} + +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 +{-# INLINE setOffset #-} + noted :: Parser (Expr Src a) -> Parser (Expr Src a) noted parser = do - before <- Text.Megaparsec.getSourcePos + before <- getSourcePos (tokens, e) <- Text.Megaparsec.match parser - after <- Text.Megaparsec.getSourcePos + after <- getSourcePos let src₀ = Src before after tokens case e of Note src₁ _ | laxSrcEq src₀ src₁ -> return e @@ -240,10 +272,10 @@ <|> alternative38 where alternative00 = do - n <- Text.Megaparsec.getOffset + n <- getOffset a <- try doubleLiteral b <- if isInfinite a - then Text.Megaparsec.setOffset n *> fail "double out of bounds" + then setOffset n *> fail "double out of bounds" else return a return (DoubleLit b) @@ -390,7 +422,7 @@ ) && c /= '$' unescapedCharacterSlow = do - _ <- Text.Megaparsec.single '$' + _ <- Text.Parser.Char.char '$' return (Chunks [] "$") escapedCharacter = do diff --git a/src/Dhall/Repl.hs b/src/Dhall/Repl.hs --- a/src/Dhall/Repl.hs +++ b/src/Dhall/Repl.hs @@ -12,9 +12,12 @@ import Control.Exception ( SomeException(SomeException), displayException, throwIO ) import Control.Monad ( forM_ ) +import Control.Monad.Fail ( MonadFail ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import Control.Monad.State.Class ( MonadState, get, modify ) import Control.Monad.State.Strict ( evalStateT ) +-- For the MonadFail instance for StateT. +import Control.Monad.Trans.Instances () import Data.List ( isPrefixOf, nub ) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe ( mapMaybe ) @@ -30,6 +33,7 @@ import System.Directory ( getDirectoryContents ) import System.Environment ( getEnvironment ) +import qualified Control.Monad.Fail as Fail import qualified Control.Monad.Trans.State.Strict as State import qualified Data.HashSet import qualified Data.Text as Text @@ -149,8 +153,8 @@ -typeOf :: ( MonadIO m, MonadState Env m ) => [String] -> m () -typeOf [] = fail ":type requires an argument to check the type of" +typeOf :: ( MonadFail m, MonadIO m, MonadState Env m ) => [String] -> m () +typeOf [] = Fail.fail ":type requires an argument to check the type of" typeOf srcs = do loaded <- @@ -217,7 +221,7 @@ | otherwise = str : strs -addBinding :: ( MonadIO m, MonadState Env m ) => [String] -> m () +addBinding :: ( MonadFail m, MonadIO m, MonadState Env m ) => [String] -> m () addBinding (k : "=" : srcs) = do let varName = @@ -245,10 +249,10 @@ output ( Expr.Annot ( Expr.Var ( Dhall.V varName 0 ) ) t ) -addBinding _ = fail ":let should be of the form `:let x = y`" +addBinding _ = Fail.fail ":let should be of the form `:let x = y`" -hashBinding :: ( MonadIO m, MonadState Env m ) => [String] -> m () -hashBinding [] = fail ":hash should be of the form `:hash expr" +hashBinding :: ( MonadFail m, MonadIO m, MonadState Env m ) => [String] -> m () +hashBinding [] = Fail.fail ":hash should be of the form `:hash expr" hashBinding tokens = do loadedExpression <- parseAndLoad (unwords tokens) @@ -296,7 +300,7 @@ pure $ saveFilePrefix <> "-" <> show nextIndex loadBinding - :: ( MonadIO m, MonadState Env m, Haskeline.MonadException m ) + :: ( MonadFail m, MonadIO m, MonadState Env m, Haskeline.MonadException m ) => [String] -> m () loadBinding [] = do mFile <- currentSaveFile @@ -304,7 +308,7 @@ case mFile of Just file -> loadBinding [file] Nothing -> - fail $ ":load couldn't find any `" <> saveFilePrefix <> "-*` files" + Fail.fail $ ":load couldn't find any `" <> saveFilePrefix <> "-*` files" loadBinding [file] = do -- Read commands from the save file @@ -314,7 +318,7 @@ | c == optionsPrefix , Just action <- lookup cmd options = action opts - runCommand _ = fail $ + runCommand _ = Fail.fail $ ":load expects `" <> file <> "` to contain one command per line" -- Keep current handle in scope @@ -331,9 +335,9 @@ writeOutputHandle $ "Loaded `" <> Text.pack file <> "`\n" -loadBinding _ = fail ":load should be of the form `:load` or `:load file`" +loadBinding _ = Fail.fail ":load should be of the form `:load` or `:load file`" -saveBinding :: ( MonadIO m, MonadState Env m ) => [String] -> m () +saveBinding :: ( MonadFail m, MonadIO m, MonadState Env m ) => [String] -> m () -- Save all the bindings into a context save file saveBinding [] = do file <- nextSaveFile @@ -380,7 +384,7 @@ writeOutputHandle $ "Expression saved to `" <> Text.pack file <> "`\n" -saveBinding _ = fail ":save should be of the form `:save`, `:save file`, or `:save file = expr`" +saveBinding _ = Fail.fail ":save should be of the form `:save`, `:save file`, or `:save file = expr`" setOption :: ( MonadIO m, MonadState Env m ) => [String] -> m () setOption [ "--explain" ] = do @@ -405,7 +409,7 @@ options - :: ( Haskeline.MonadException m, MonadIO m, MonadState Env m ) + :: ( Haskeline.MonadException m, MonadFail m, MonadIO m, MonadState Env m ) => Repline.Options m options = [ ( "type", dontCrash . typeOf ) @@ -420,7 +424,7 @@ completer - :: (Monad m, MonadIO m, MonadState Env m) + :: (Monad m, MonadFail m, MonadIO m, MonadState Env m) => Repline.CompleterStyle m completer = Repline.Prefix @@ -433,7 +437,7 @@ separators = " \t[(,=+*&|}#?>:" completeFunc - :: (Monad m, MonadIO m, MonadState Env m) + :: (Monad m, MonadFail m, MonadIO m, MonadState Env m) => String -> String -> m [Completion] completeFunc reversedPrev word @@ -500,10 +504,8 @@ fmap (("." <> f) <>) (algebraicComplete fs e) in case expr of - Dhall.Core.Record m -> withMap (fmap Just m) Dhall.Core.RecordLit m -> withMap (fmap Just m) Dhall.Core.Union m -> withMap m - Dhall.Core.UnionLit _ _ m -> withMap m _ -> [] diff --git a/src/Dhall/Tutorial.hs b/src/Dhall/Tutorial.hs --- a/src/Dhall/Tutorial.hs +++ b/src/Dhall/Tutorial.hs @@ -314,7 +314,7 @@ -- - Bool -- + Natural -- ... --- 1 : Bool +-- 1: 1 : Bool -- ... -- (input):1:1 -- ... @@ -514,7 +514,8 @@ -- *** Exception: -- ...Error...: An empty list requires a type annotation -- ... --- [] +-- 1: [] +-- ... -- (input):1:1 -- -- Also, list elements must all have the same type. You will get an error if @@ -527,7 +528,7 @@ -- - Natural -- + Bool -- ... --- True +-- 1: True -- ... -- (input):1:5 -- ... diff --git a/src/Dhall/TypeCheck.hs b/src/Dhall/TypeCheck.hs --- a/src/Dhall/TypeCheck.hs +++ b/src/Dhall/TypeCheck.hs @@ -626,6 +626,8 @@ return Type decide Kind Kind = return Kind + decide Sort Sort = + return Sort decide x y = Left (TypeError ctx e (RecordTypeMismatch x y l r)) c <- decide cL cR diff --git a/src/Dhall/Util.hs b/src/Dhall/Util.hs --- a/src/Dhall/Util.hs +++ b/src/Dhall/Util.hs @@ -23,15 +23,17 @@ -- | Utility function to cut out the interior of a large text block snip :: Text -> Text snip text - | length ls <= 7 = text + | length ls <= numberOfLinesOfContext * 2 + 1 = text | otherwise = if Data.Text.last text == '\n' then preview else Data.Text.init preview where + numberOfLinesOfContext = 20 + ls = Data.Text.lines text - header = take 3 ls + header = take numberOfLinesOfContext ls - footer = takeEnd 3 ls + footer = takeEnd numberOfLinesOfContext ls excerpt = filter (Data.Text.any (/= ' ')) (header <> footer) diff --git a/tests/Dhall/Test/Dhall.hs b/tests/Dhall/Test/Dhall.hs --- a/tests/Dhall/Test/Dhall.hs +++ b/tests/Dhall/Test/Dhall.hs @@ -1,21 +1,38 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Dhall.Test.Dhall where import Control.Exception (SomeException, try) +import Data.Text (Text) +import Dhall (Inject, Interpret) +import Dhall.Core (Expr(..)) +import GHC.Generics (Generic) import Numeric.Natural (Natural) import Test.Tasty import Test.Tasty.HUnit import qualified Dhall import qualified Dhall.Core +import qualified Dhall.Import import qualified Dhall.Map +import qualified Dhall.Parser tests :: TestTree tests = testGroup "Input" - [ shouldShowDetailedTypeError ] + [ shouldShowDetailedTypeError + , shouldHandleBothUnionLiterals + , shouldHaveWorkingGenericAuto + , shouldHandleUnionsCorrectly + , shouldTreatAConstructorStoringUnitAsEmptyAlternative + ] data MyType = MyType { foo :: String , bar :: Natural } @@ -55,5 +72,130 @@ case inputEx of Left ex -> assertEqual assertMsg expectedMsg (show ex) Right _ -> fail "The extraction using a wrong type succeded" - - + +-- https://github.com/dhall-lang/dhall-haskell/issues/915 +shouldHandleBothUnionLiterals :: TestTree +shouldHandleBothUnionLiterals = testCase "Marshal union literals" $ do + let example :: Dhall.Type Bool + example = Dhall.union (Dhall.constructor "Test" Dhall.bool) + + _ <- Dhall.input example "< Test : Bool >.Test True" + _ <- Dhall.input example "< Test = True >" + + return () + +shouldTreatAConstructorStoringUnitAsEmptyAlternative :: TestTree +shouldTreatAConstructorStoringUnitAsEmptyAlternative = testCase "Handle unit constructors" $ do + let exampleType :: Dhall.Type () + exampleType = Dhall.union (Dhall.constructor "A" Dhall.unit) + + () <- Dhall.input exampleType "< A >.A" + + let exampleInputType :: Dhall.InputType () + exampleInputType = Dhall.inputUnion (Dhall.inputConstructor "A") + + Dhall.embed exampleInputType () @=? Field (Union (Dhall.Map.singleton "A" Nothing)) "A" + +data CompilerFlavor3 = + GHC3 | GHCJS3 | Helium3 + deriving (Generic, Show, Eq) + +data CompilerFlavor2 = + GHC2 | GHCJS2 + deriving (Generic, Show, Eq) + +-- https://github.com/dhall-lang/dhall-haskell/issues/926 +shouldHaveWorkingGenericAuto :: TestTree +shouldHaveWorkingGenericAuto = testGroup "genericAuto" + [ testCase "works for a three-constructor enum" $ do + compiler <- Dhall.input Dhall.genericAuto "< GHC3 | GHCJS3 | Helium3 >.GHC3" + assertEqual "genericAuto didn't give us what we wanted" GHC3 compiler + + , testCase "works for a two-constructor enum" $ do + compiler <- Dhall.input Dhall.genericAuto "< GHC2 | GHCJS2 >.GHC2" + assertEqual "genericAuto didn't give us what we wanted" GHC2 compiler + ] + +data NonEmptyUnion = N0 Bool | N1 Natural | N2 Text + deriving (Eq, Generic, Inject, Interpret, Show) + +data Enum = E0 | E1 | E2 + deriving (Eq, Generic, Inject, Interpret, Show) + +data Mixed = M0 Bool | M1 | M2 () + deriving (Eq, Generic, Inject, Interpret, Show) + +deriving instance Interpret () + +shouldHandleUnionsCorrectly :: TestTree +shouldHandleUnionsCorrectly = + testGroup "Handle union literals" + [ "λ(x : < N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >) → x" + `shouldPassThrough` [ N0 True, N1 5, N2 "ABC" ] + , "λ(x : < E0 | E1 | E2 >) → x" + `shouldPassThrough` [ E0, E1, E2 ] + , "λ(x : < M0 : { _1 : Bool } | M1 | M2 : { _1 : {} } >) → x" + `shouldPassThrough` [ M0 True, M1, M2 () ] + + , "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N0 { _1 = True }" + `shouldMarshalInto` N0 True + , "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N1 { _1 = 5 }" + `shouldMarshalInto` N1 5 + , "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N2 { _1 = \"ABC\" }" + `shouldMarshalInto` N2 "ABC" + + , "< N0 = { _1 = True } | N1 : { _1 : Natural } | N2 : { _1 : Text } >" + `shouldMarshalInto` N0 True + , "< N0 : { _1 : Bool } | N1 = { _1 = 5 } | N2 : { _1 : Text } >" + `shouldMarshalInto` N1 5 + , "< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 = { _1 = \"ABC\" } >" + `shouldMarshalInto` N2 "ABC" + + , "(< E0 | E1 | E2>).E0" `shouldMarshalInto` E0 + , "(< E0 | E1 | E2>).E1" `shouldMarshalInto` E1 + , "(< E0 | E1 | E2>).E2" `shouldMarshalInto` E2 + + , "(< M0 : { _1 : Bool } | M1 | M2 : { _1 : {} } >).M0 { _1 = True }" + `shouldMarshalInto` M0 True + , "(< M0 : { _1 : Bool } | M1 | M2 : { _1 : {} } >).M1" + `shouldMarshalInto` M1 + , "(< M0 : { _1 : Bool } | M1 | M2 : { _1 : {} } >).M2 { _1 = {=} }" + `shouldMarshalInto` M2 () + + , "< M0 = { _1 = True } | M1 | M2 : { _1 : {} } >" + `shouldMarshalInto` M0 True + + , N0 True + `shouldInjectInto` + "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N0 { _1 = True }" + , N1 5 + `shouldInjectInto` + "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N1 { _1 = 5 }" + , N2 "ABC" + `shouldInjectInto` + "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N2 { _1 = \"ABC\" }" + + , E0 `shouldInjectInto` "< E0 | E1 | E2 >.E0" + , E1 `shouldInjectInto` "< E0 | E1 | E2 >.E1" + , E2 `shouldInjectInto` "< E0 | E1 | E2 >.E2" + + , M0 True `shouldInjectInto` "(< M0 : { _1 : Bool } | M1 | M2 : { _1 : {} } >).M0 { _1 = True }" + , M1 `shouldInjectInto` "(< M0 : { _1 : Bool } | M1 | M2 : { _1 : {} } >).M1" + , M2 () `shouldInjectInto` "(< M0 : { _1 : Bool } | M1 | M2 : { _1 : {} } >).M2 { _1 = {=} }" + ] + where + code `shouldPassThrough` values = testCase "Pass through" $ do + f <- Dhall.input Dhall.auto code + + values @=? map f values + + code `shouldMarshalInto` expectedValue = testCase "Marshal" $ do + actualValue <- Dhall.input Dhall.auto code + expectedValue @=? actualValue + + value `shouldInjectInto` expectedCode = testCase "Inject" $ do + parsedExpression <- Dhall.Core.throws (Dhall.Parser.exprFromText "(test)" expectedCode) + + resolvedExpression <- Dhall.Import.assertNoImports parsedExpression + + Dhall.Core.denote resolvedExpression @=? Dhall.embed Dhall.inject value diff --git a/tests/Dhall/Test/Normalization.hs b/tests/Dhall/Test/Normalization.hs --- a/tests/Dhall/Test/Normalization.hs +++ b/tests/Dhall/Test/Normalization.hs @@ -41,10 +41,6 @@ alphaNormalizationTests <- do Test.Util.discover pattern alphaNormalizationTest - -- Hackage rejects packages with Unicode directory names. This - -- will be fixed in the next release of `dhall` but for now we - -- disable the tests that depend on the `α-normalization` directory - -- (Turtle.lstree "./dhall-lang/tests/α-normalization/success/") Turtle.empty let unitTestFiles = do