diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +1.42.1 + +* Add several new entrypoints to `Dhall` module [[#2534](https://github.com/dhall-lang/dhall-haskell/pull/2534)] / [[#2544](https://github.com/dhall-lang/dhall-haskell/pull/2544)] +* Build against latest versions of: + * [`ansi-terminal`](https://github.com/dhall-lang/dhall-haskell/pull/2521) + * [`optparse-applicative`](https://github.com/dhall-lang/dhall-haskell/pull/2543) + * [`optparse-generic`](https://github.com/dhall-lang/dhall-haskell/pull/2519) + * [`lens`](https://github.com/dhall-lang/dhall-haskell/pull/2539) + * `template-haskell` [[#2532](https://github.com/dhall-lang/dhall-haskell/pull/2532)] / [[#2542](https://github.com/dhall-lang/dhall-haskell/pull/2542)] + * [`unix-compat`](https://github.com/dhall-lang/dhall-haskell/pull/2532) 1.42.0 * [Supports standard version 23.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v23.0.0) diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.4 Name: dhall -Version: 1.42.0 +Version: 1.42.1 Build-Type: Simple License: BSD-3-Clause License-File: LICENSE @@ -205,19 +205,19 @@ Common common Build-Depends: base >= 4.11.0.0 && < 5 , - aeson >= 1.0.0.0 && < 2.2 , + aeson >= 1.0.0.0 && < 2.3 , aeson-pretty < 0.9 , - ansi-terminal >= 0.6.3.1 && < 0.12, + ansi-terminal >= 0.6.3.1 && < 1.1 , atomic-write >= 0.2.0.7 && < 0.3 , base16-bytestring >= 1.0.0.0 , - bytestring < 0.12, + bytestring < 0.13, case-insensitive < 1.3 , cborg >= 0.2.0.0 && < 0.3 , cborg-json >= 0.2.2.0 && < 0.3 , containers >= 0.5.8.0 && < 0.7 , contravariant < 1.6 , data-fix < 0.4 , - deepseq < 1.5 , + deepseq < 1.6 , Diff >= 0.2 && < 0.5 , directory >= 1.3.0.0 && < 1.4 , dotgen >= 0.4.2 && < 0.5 , @@ -234,7 +234,7 @@ mmorph < 1.3 , mtl >= 2.2.1 && < 2.4 , network-uri >= 2.6 && < 2.7 , - optparse-applicative >= 0.14.0.0 && < 0.18, + optparse-applicative >= 0.14.0.0 && < 0.19, parsers >= 0.12.4 && < 0.13, parser-combinators , prettyprinter >= 1.7.0 && < 1.8 , @@ -244,16 +244,20 @@ repline >= 0.4.0.0 && < 0.5 , serialise >= 0.2.0.0 && < 0.3 , scientific >= 0.3.0.0 && < 0.4 , - template-haskell >= 2.13.0.0 && < 2.20, - text >= 0.11.1.0 && < 2.1 , + template-haskell >= 2.13.0.0 && < 2.22, + text >= 0.11.1.0 && < 2.2 , text-manipulate >= 0.2.0.1 && < 0.4 , text-short >= 0.1 && < 0.2 , th-lift-instances >= 0.1.13 && < 0.2 , time >= 1.9 && < 1.13, transformers >= 0.5.2.0 && < 0.7 , - unix-compat >= 0.4.2 && < 0.7 , + unix-compat >= 0.4.2 && < 0.8 , unordered-containers >= 0.1.3.0 && < 0.3 , vector >= 0.11.0.0 && < 0.14 + + if !os(windows) + Build-Depends: + unix >= 2.7 && < 2.9 , if flag(with-http) CPP-Options: diff --git a/src/Dhall.hs b/src/Dhall.hs --- a/src/Dhall.hs +++ b/src/Dhall.hs @@ -24,6 +24,10 @@ , inputFileWithSettings , inputExpr , inputExprWithSettings + , interpretExpr + , interpretExprWithSettings + , fromExpr + , fromExprWithSettings , rootDirectory , sourceName , startingContext @@ -43,16 +47,25 @@ -- * Encoders , module Dhall.Marshal.Encode + -- * Individual phases + , parseWithSettings + , resolveWithSettings + , typecheckWithSettings + , checkWithSettings + , expectWithSettings + , normalizeWithSettings + -- * Miscellaneous , rawInput ) where import Control.Applicative (Alternative, empty) +import Control.Monad.Catch (MonadThrow, throwM) import Data.Either.Validation (Validation (..)) import Data.Void (Void) import Dhall.Import (Imported (..)) import Dhall.Parser (Src (..)) -import Dhall.Syntax (Expr (..)) +import Dhall.Syntax (Expr (..), Import) import Dhall.TypeCheck (DetailedTypeError (..), TypeError) import GHC.Generics import Lens.Family (LensLike', view) @@ -195,6 +208,81 @@ instance HasEvaluateSettings EvaluateSettings where evaluateSettings = id +-- | Parse an expression, using the supplied `InputSettings` +parseWithSettings :: MonadThrow m => InputSettings -> Text -> m (Expr Src Import) +parseWithSettings settings text = + either throwM return (Dhall.Parser.exprFromText (view sourceName settings) text) + +-- | Type-check an expression, using the supplied `InputSettings` +typecheckWithSettings :: MonadThrow m => InputSettings -> Expr Src Void -> m () +typecheckWithSettings settings expression = + either throwM (return . const ()) (Dhall.TypeCheck.typeWith (view startingContext settings) expression) + +{-| Type-check an expression against a type provided as a Dhall expreession, + using the supplied `InputSettings` +-} +checkWithSettings :: + MonadThrow m => + -- | The input settings + InputSettings -> + -- | The expected type of the expression + Expr Src Void -> + -- | The expression to check + Expr Src Void -> + m () +checkWithSettings settings type_ expression = do + let suffix = Dhall.Pretty.Internal.prettyToStrictText type_ + + let annotated = case expression of + Note (Src begin end bytes) _ -> + Note (Src begin end bytes') (Annot expression type_) + where + bytes' = bytes <> " : " <> suffix + _ -> + Annot expression type_ + + typecheckWithSettings settings annotated + +{-| Type-check an expression against a `Decoder`'s expected type, using the + supplied `InputSettings`. + This is equivalent of using the 'expected' type of a @Decoder@ as the second + argument to 'checkWithSettings'. +-} +expectWithSettings :: MonadThrow m => InputSettings -> Decoder a -> Expr Src Void -> m () +expectWithSettings settings Decoder{..} expression = do + expected' <- case expected of + Success x -> return x + Failure e -> throwM e + + checkWithSettings settings expected' expression + +{-| Resolve an expression, using the supplied `InputSettings` + + Note that this also applies any substitutions specified in the + `InputSettings` +-} +resolveWithSettings :: InputSettings -> Expr Src Import -> IO (Expr Src Void) +resolveWithSettings settings expression = do + let InputSettings{..} = settings + + let EvaluateSettings{..} = _evaluateSettings + + let transform = + Lens.Family.set Dhall.Import.substitutions _substitutions + . Lens.Family.set Dhall.Import.normalizer _normalizer + . Lens.Family.set Dhall.Import.startingContext _startingContext + + let status = transform (Dhall.Import.emptyStatusWithManager _newManager _rootDirectory) + + resolved <- State.evalStateT (Dhall.Import.loadWith expression) status + + pure (Dhall.Substitution.substitute resolved (view substitutions settings)) + +-- | Normalize an expression, using the supplied `InputSettings` +normalizeWithSettings :: InputSettings -> Expr Src Void -> Expr Src Void +normalizeWithSettings settings = + Core.normalizeWith (view normalizer settings) + {-| Type-check and evaluate a Dhall program, decoding the result into Haskell The first argument determines the type of value that you decode: @@ -236,24 +324,17 @@ -- ^ The Dhall program -> IO a -- ^ The decoded value in Haskell -inputWithSettings settings (Decoder {..}) txt = do - expected' <- case expected of - Success x -> return x - Failure e -> Control.Exception.throwIO e +inputWithSettings settings decoder@Decoder{..} text = do + parsed <- parseWithSettings settings text - let suffix = Dhall.Pretty.Internal.prettyToStrictText expected' - let annotate substituted = case substituted of - Note (Src begin end bytes) _ -> - Note (Src begin end bytes') (Annot substituted expected') - where - bytes' = bytes <> " : " <> suffix - _ -> - Annot substituted expected' + resolved <- resolveWithSettings settings parsed - normExpr <- inputHelper annotate settings txt + expectWithSettings settings decoder resolved - case extract normExpr of - Success x -> return x + let normalized = normalizeWithSettings settings resolved + + case extract normalized of + Success x -> return x Failure e -> Control.Exception.throwIO e {-| Type-check and evaluate a Dhall program that is read from the @@ -320,39 +401,51 @@ -- ^ The Dhall program -> IO (Expr Src Void) -- ^ The fully normalized AST -inputExprWithSettings = inputHelper id +inputExprWithSettings settings text = do + parsed <- parseWithSettings settings text -{-| Helper function for the input* function family + resolved <- resolveWithSettings settings parsed -@since 1.30 + _ <- typecheckWithSettings settings resolved + + pure (Core.normalizeWith (view normalizer settings) resolved) + +{-| Interpret a Dhall Expression + + This takes care of import resolution, type-checking, and normalization -} -inputHelper - :: (Expr Src Void -> Expr Src Void) - -> InputSettings - -> Text - -- ^ The Dhall program - -> IO (Expr Src Void) - -- ^ The fully normalized AST -inputHelper annotate settings txt = do - expr <- Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt) +interpretExpr :: Expr Src Import -> IO (Expr Src Void) +interpretExpr = interpretExprWithSettings defaultInputSettings - let InputSettings {..} = settings +-- | Like `interpretExpr`, but customizable using `InputSettings` +interpretExprWithSettings + :: InputSettings -> Expr Src Import -> IO (Expr Src Void) +interpretExprWithSettings settings parsed = do + resolved <- resolveWithSettings settings parsed - let EvaluateSettings {..} = _evaluateSettings + typecheckWithSettings settings resolved - let transform = - Lens.Family.set Dhall.Import.substitutions _substitutions - . Lens.Family.set Dhall.Import.normalizer _normalizer - . Lens.Family.set Dhall.Import.startingContext _startingContext + pure (Core.normalizeWith (view normalizer settings) resolved) - let status = transform (Dhall.Import.emptyStatusWithManager _newManager _rootDirectory) +{- | Decode a Dhall expression - expr' <- State.evalStateT (Dhall.Import.loadWith expr) status + This takes care of import resolution, type-checking and normalization +-} +fromExpr :: Decoder a -> Expr Src Import -> IO a +fromExpr = fromExprWithSettings defaultInputSettings - let substituted = Dhall.Substitution.substitute expr' $ view substitutions settings - let annot = annotate substituted - _ <- Core.throws (Dhall.TypeCheck.typeWith (view startingContext settings) annot) - pure (Core.normalizeWith (view normalizer settings) substituted) +-- | Like `fromExpr`, but customizable using `InputSettings` +fromExprWithSettings :: InputSettings -> Decoder a -> Expr Src Import -> IO a +fromExprWithSettings settings decoder@Decoder{..} expression = do + resolved <- resolveWithSettings settings expression + + expectWithSettings settings decoder resolved + + let normalized = Core.normalizeWith (view normalizer settings) resolved + + case extract normalized of + Success x -> return x + Failure e -> Control.Exception.throwIO e -- | Use this function to extract Haskell values directly from Dhall AST. -- The intended use case is to allow easy extraction of Dhall values for diff --git a/src/Dhall/DirectoryTree.hs b/src/Dhall/DirectoryTree.hs --- a/src/Dhall/DirectoryTree.hs +++ b/src/Dhall/DirectoryTree.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -54,8 +55,12 @@ import qualified Prettyprinter.Render.String as Pretty import qualified System.Directory as Directory import qualified System.FilePath as FilePath +#ifdef mingw32_HOST_OS +import System.IO.Error (illegalOperationErrorType, mkIOError) +#else +import qualified System.Posix.User as Posix +#endif import qualified System.PosixCompat.Files as Posix -import qualified System.PosixCompat.User as Posix {-| Attempt to transform a Dhall record into a directory tree where: @@ -263,12 +268,24 @@ -- | Resolve a `User` to a numerical id. getUser :: User -> IO UserID getUser (UserId uid) = return uid -getUser (UserName name) = Posix.userID <$> Posix.getUserEntryForName name +getUser (UserName name) = +#ifdef mingw32_HOST_OS + ioError $ mkIOError illegalOperationErrorType x Nothing Nothing + where x = "System.Posix.User.getUserEntryForName: not supported" +#else + Posix.userID <$> Posix.getUserEntryForName name +#endif -- | Resolve a `Group` to a numerical id. getGroup :: Group -> IO GroupID getGroup (GroupId gid) = return gid -getGroup (GroupName name) = Posix.groupID <$> Posix.getGroupEntryForName name +getGroup (GroupName name) = +#ifdef mingw32_HOST_OS + ioError $ mkIOError illegalOperationErrorType x Nothing Nothing + where x = "System.Posix.User.getGroupEntryForName: not supported" +#else + Posix.groupID <$> Posix.getGroupEntryForName name +#endif -- | Process a `FilesystemEntry`. Writes the content to disk and apply the -- metadata to the newly created item. @@ -409,57 +426,57 @@ Pretty.renderString (Dhall.Pretty.layout message) where message = - Util._ERROR <> ": Not a valid directory tree expression \n\ - \ \n\ - \Explanation: Only a subset of Dhall expressions can be converted to a directory \n\ - \tree. Specifically, record literals or maps can be converted to directories, \n\ - \❰Text❱ literals can be converted to files, and ❰Optional❱ values are included if \n\ - \❰Some❱ and omitted if ❰None❱. Values of union types can also be converted if \n\ - \they are an alternative which has a non-nullary constructor whose argument is of \n\ - \an otherwise convertible type. Furthermore, there is a more advanced approach to \n\ - \constructing a directory tree utilizing a fixpoint encoding. Consult the upstream \n\ - \documentation of the `toDirectoryTree` function in the Dhall.Directory module for \n\ - \further information on that. \n\ - \No other type of value can be translated to a directory tree. \n\ - \ \n\ - \For example, this is a valid expression that can be translated to a directory \n\ - \tree: \n\ - \ \n\ - \ \n\ - \ ┌──────────────────────────────────┐ \n\ - \ │ { `example.json` = \"[1, true]\" } │ \n\ - \ └──────────────────────────────────┘ \n\ - \ \n\ - \ \n\ - \In contrast, the following expression is not allowed due to containing a \n\ - \❰Natural❱ field, which cannot be translated in this way: \n\ - \ \n\ - \ \n\ - \ ┌───────────────────────┐ \n\ - \ │ { `example.txt` = 1 } │ \n\ - \ └───────────────────────┘ \n\ - \ \n\ - \ \n\ - \Note that key names cannot contain path separators: \n\ - \ \n\ - \ \n\ - \ ┌─────────────────────────────────────┐ \n\ - \ │ { `directory/example.txt` = \"ABC\" } │ Invalid: Key contains a forward slash\n\ - \ └─────────────────────────────────────┘ \n\ - \ \n\ - \ \n\ - \Instead, you need to refactor the expression to use nested records instead: \n\ - \ \n\ - \ \n\ - \ ┌───────────────────────────────────────────┐ \n\ - \ │ { directory = { `example.txt` = \"ABC\" } } │ \n\ - \ └───────────────────────────────────────────┘ \n\ - \ \n\ - \ \n\ - \You tried to translate the following expression to a directory tree: \n\ - \ \n\ - \" <> Util.insert unexpectedExpression <> "\n\ - \ \n\ + Util._ERROR <> ": Not a valid directory tree expression \n\\ + \ \n\\ + \Explanation: Only a subset of Dhall expressions can be converted to a directory \n\\ + \tree. Specifically, record literals or maps can be converted to directories, \n\\ + \❰Text❱ literals can be converted to files, and ❰Optional❱ values are included if \n\\ + \❰Some❱ and omitted if ❰None❱. Values of union types can also be converted if \n\\ + \they are an alternative which has a non-nullary constructor whose argument is of \n\\ + \an otherwise convertible type. Furthermore, there is a more advanced approach to \n\\ + \constructing a directory tree utilizing a fixpoint encoding. Consult the upstream \n\\ + \documentation of the `toDirectoryTree` function in the Dhall.Directory module for \n\\ + \further information on that. \n\\ + \No other type of value can be translated to a directory tree. \n\\ + \ \n\\ + \For example, this is a valid expression that can be translated to a directory \n\\ + \tree: \n\\ + \ \n\\ + \ \n\\ + \ ┌──────────────────────────────────┐ \n\\ + \ │ { `example.json` = \"[1, true]\" } │ \n\\ + \ └──────────────────────────────────┘ \n\\ + \ \n\\ + \ \n\\ + \In contrast, the following expression is not allowed due to containing a \n\\ + \❰Natural❱ field, which cannot be translated in this way: \n\\ + \ \n\\ + \ \n\\ + \ ┌───────────────────────┐ \n\\ + \ │ { `example.txt` = 1 } │ \n\\ + \ └───────────────────────┘ \n\\ + \ \n\\ + \ \n\\ + \Note that key names cannot contain path separators: \n\\ + \ \n\\ + \ \n\\ + \ ┌─────────────────────────────────────┐ \n\\ + \ │ { `directory/example.txt` = \"ABC\" } │ Invalid: Key contains a forward slash\n\\ + \ └─────────────────────────────────────┘ \n\\ + \ \n\\ + \ \n\\ + \Instead, you need to refactor the expression to use nested records instead: \n\\ + \ \n\\ + \ \n\\ + \ ┌───────────────────────────────────────────┐ \n\\ + \ │ { directory = { `example.txt` = \"ABC\" } } │ \n\\ + \ └───────────────────────────────────────────┘ \n\\ + \ \n\\ + \ \n\\ + \You tried to translate the following expression to a directory tree: \n\\ + \ \n\\ + \" <> Util.insert unexpectedExpression <> "\n\\ + \ \n\\ \... which is not an expression that can be translated to a directory tree. \n" {- | This error indicates that you want to set some metadata for a file or @@ -475,11 +492,11 @@ Pretty.renderString (Dhall.Pretty.layout message) where message = - Util._ERROR <> ": Setting metadata is not supported on this platform. \n\ - \ \n\ - \Explanation: Your Dhall expression indicates that you intend to set some metadata \n\ - \like ownership or permissions for the following file or directory: \n\ - \ \n\ - \" <> Pretty.pretty metadataForPath <> "\n\ - \ \n\ + Util._ERROR <> ": Setting metadata is not supported on this platform. \n\\ + \ \n\\ + \Explanation: Your Dhall expression indicates that you intend to set some metadata \n\\ + \like ownership or permissions for the following file or directory: \n\\ + \ \n\\ + \" <> Pretty.pretty metadataForPath <> "\n\\ + \ \n\\ \... which is not supported on your platform. \n" diff --git a/src/Dhall/Syntax/Instances/Lift.hs b/src/Dhall/Syntax/Instances/Lift.hs --- a/src/Dhall/Syntax/Instances/Lift.hs +++ b/src/Dhall/Syntax/Instances/Lift.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE StandaloneDeriving #-} @@ -15,13 +16,17 @@ import Dhall.Syntax.Var import Language.Haskell.TH.Syntax (Lift) +#if !MIN_VERSION_template_haskell(2,21,0) import qualified Data.Fixed as Fixed +#endif import qualified Data.Time as Time deriving instance Lift Time.Day deriving instance Lift Time.TimeOfDay deriving instance Lift Time.TimeZone +#if !MIN_VERSION_template_haskell(2,21,0) deriving instance Lift (Fixed.Fixed a) +#endif deriving instance Lift Const deriving instance Lift Var deriving instance (Lift s, Lift a) => Lift (Binding s a) diff --git a/src/Dhall/TH.hs b/src/Dhall/TH.hs --- a/src/Dhall/TH.hs +++ b/src/Dhall/TH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} @@ -263,7 +264,13 @@ interpretOptions = generateToInterpretOptions generateOptions typ - toTypeVar (V n i) = Syntax.PlainTV $ Syntax.mkName (Text.unpack n ++ show i) +#if MIN_VERSION_template_haskell(2,21,0) + toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) Syntax.BndrInvis +#elif MIN_VERSION_template_haskell(2,17,0) + toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) () +#else + toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) +#endif toDataD typeName typeParams constructors = do let name = Syntax.mkName (Text.unpack typeName) diff --git a/tests/Dhall/Test/Import.hs b/tests/Dhall/Test/Import.hs --- a/tests/Dhall/Test/Import.hs +++ b/tests/Dhall/Test/Import.hs @@ -54,6 +54,24 @@ , importDirectory "success/unit/asLocation/RemoteChain2A.dhall" , importDirectory "success/unit/asLocation/RemoteChain3A.dhall" , importDirectory "success/unit/asLocation/RemoteChainMissingA.dhall" + + -- Skip all tests that reference httpbin.org to avoid clobbering + -- their servers. These should eventually be replaced by tests + -- that depend on an equivalent endpoint on test.dhall-lang.org + -- instead of httpbin.org. + , importDirectory "failure/customHeadersUsingBoundVariable.dhall" + , importDirectory "failure/originHeadersFromRemote.dhall" + , importDirectory "failure/originHeadersFromRemoteENV.dhall" + , importDirectory "success/customHeadersA.dhall" + , importDirectory "success/noHeaderForwardingA.dhall" + , importDirectory "success/success/originHeadersA.dhall" + , importDirectory "success/originHeadersENV.dhall" + , importDirectory "success/originHeadersImportA.dhall" + , importDirectory "success/originHeadersImportENV.dhall" + , importDirectory "success/originHeadersImportFromEnvA.dhall" + , importDirectory "success/originHeadersImportFromEnvENV.dhall" + , importDirectory "success/originHeadersOverrideA.dhall" + , importDirectory "success/originHeadersOverrideENV.dhall" ] successTests <- Test.Util.discover (Turtle.chars <* "A.dhall") successTest (do