diff --git a/dhall-nixpkgs/Main.hs b/dhall-nixpkgs/Main.hs index 797ced1ab..d70d85d90 100644 --- a/dhall-nixpkgs/Main.hs +++ b/dhall-nixpkgs/Main.hs @@ -81,7 +81,7 @@ import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Void (Void) import Dhall.Crypto (SHA256Digest (..)) -import Dhall.Import (Status (..), stack) +import Dhall.Import (Status, stack) import Dhall.Parser (Src) import GHC.Generics (Generic) import Lens.Micro (rewriteOf) diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index 85a082fbc..a9c676cd0 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -369,6 +369,7 @@ Library Dhall.Normalize Dhall.Parser.Combinators Dhall.Pretty.Internal + Dhall.Settings Dhall.Syntax Dhall.Syntax.Binding Dhall.Syntax.Chunks diff --git a/dhall/ghc-src/Dhall/Import/HTTP.hs b/dhall/ghc-src/Dhall/Import/HTTP.hs index 4438a055e..8d977c958 100644 --- a/dhall/ghc-src/Dhall/Import/HTTP.hs +++ b/dhall/ghc-src/Dhall/Import/HTTP.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -9,11 +10,11 @@ module Dhall.Import.HTTP ) where import Control.Exception (Exception) +import Control.Monad (join) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.State.Strict (StateT) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) -import Data.Dynamic (toDyn) import Data.List.NonEmpty (NonEmpty (..)) import Data.Text.Encoding (decodeUtf8) import Dhall.Core @@ -29,27 +30,35 @@ import Dhall.Core , URL (..) ) import Dhall.Import.Types + ( Chained (..) + , HTTPHeader + , Manager + , OriginHeaders + , PrettyHttpException (..) + , Status (..) + ) import Dhall.Parser (Src) import Dhall.URL (renderURL) +import Lens.Micro.Mtl (assign, use) import System.Directory (getXdgDirectory, XdgDirectory(XdgConfig)) import System.FilePath (splitDirectories) - import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..)) import qualified Control.Exception -import qualified Control.Monad.Trans.State.Strict as State import qualified Data.ByteString.Lazy as ByteString.Lazy import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as Text import qualified Data.Text.Encoding +import qualified Dhall.Import.Types +import qualified Dhall.Settings import qualified Dhall.Util import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Types mkPrettyHttpException :: String -> HttpException -> PrettyHttpException mkPrettyHttpException url ex = - PrettyHttpException (renderPrettyHttpException url ex) (toDyn ex) + PrettyHttpException (renderPrettyHttpException url ex) (Control.Exception.toException ex) renderPrettyHttpException :: String -> HttpException -> String renderPrettyHttpException _ (InvalidUrlException _ r) = @@ -162,18 +171,9 @@ renderPrettyHttpException url (HttpExceptionRequest _ e) = newManager :: StateT Status IO Manager newManager = do - Status { _manager = oldManager, ..} <- State.get - - case oldManager of - Nothing -> do - manager <- liftIO _newManager - - State.put (Status { _manager = Just manager , ..}) - - return manager - - Just manager -> - return manager + manager <- liftIO =<< use Dhall.Settings.newManager + assign Dhall.Settings.newManager (return manager) + return manager data NotCORSCompliant = NotCORSCompliant { expectedOrigins :: [ByteString] @@ -255,7 +255,7 @@ addHeaders originHeaders urlHeaders request = request { HTTP.requestHeaders = (filterHeaders urlHeaders) <> perOriginHeaders } where origin = decodeUtf8 (HTTP.host request) <> ":" <> Text.pack (show (HTTP.port request)) - + perOriginHeaders = HashMap.lookupDefault [] origin originHeaders filterHeaders = foldMap (filter (not . overridden)) @@ -269,10 +269,7 @@ addHeaders originHeaders urlHeaders request = fetchFromHttpUrlBytes :: URL -> Maybe [HTTPHeader] -> StateT Status IO ByteString fetchFromHttpUrlBytes childURL mheaders = do - Status { _loadOriginHeaders } <- State.get - - originHeaders <- _loadOriginHeaders - + originHeaders <- join (use Dhall.Import.Types.loadOriginHeaders) manager <- newManager let childURLString = Text.unpack (renderURL childURL) @@ -289,9 +286,7 @@ fetchFromHttpUrlBytes childURL mheaders = do response <- liftIO (Control.Exception.handle handler io) - Status {..} <- State.get - - case _stack of + use Dhall.Import.Types.stack >>= \case -- We ignore the first import in the stack since that is the same import -- as the `childUrl` _ :| Chained parentImport : _ -> do diff --git a/dhall/ghcjs-src/Dhall/Import/Manager.hs b/dhall/ghcjs-src/Dhall/Import/Manager.hs index 244a595b7..142064e72 100644 --- a/dhall/ghcjs-src/Dhall/Import/Manager.hs +++ b/dhall/ghcjs-src/Dhall/Import/Manager.hs @@ -4,9 +4,8 @@ For the GHC implementation the `Dhall.Import.Manager.Manager` type is a real `Network.HTTP.Client.Manager` from the @http-client@ package. For the GHCJS - implementation the `Dhall.Import.Manager.Manager` type is a synonym for - @`Data.Void.Void`@ since GHCJS does not use a - `Network.HTTP.Client.Manager` for HTTP requests. + implementation the `Dhall.Import.Manager.Manager` type is a stub since GHCJS + does not use a `Network.HTTP.Client.Manager` for HTTP requests. -} module Dhall.Import.Manager ( -- * Manager @@ -16,11 +15,11 @@ module Dhall.Import.Manager {-| The GHCJS implementation does not require a `Network.HTTP.Client.Manager` - The purpose of this synonym is so that "Dhall.Import.Types" can import a + The purpose of this type is so that "Dhall.Import.Types" can import a `Dhall.Import.Manager.Manager` type from "Dhall.Import.HTTP" that does the - correct thing for both the GHC and GHCJS implementations + correct thing for both the GHC and GHCJS implementations. -} -type Manager = () +data Manager = Manager defaultNewManager :: IO Manager -defaultNewManager = pure () +defaultNewManager = pure Manager diff --git a/dhall/src/Dhall.hs b/dhall/src/Dhall.hs index a1c0c0bc8..4abc009fe 100644 --- a/dhall/src/Dhall.hs +++ b/dhall/src/Dhall.hs @@ -28,19 +28,24 @@ module Dhall , interpretExprWithSettings , fromExpr , fromExprWithSettings - , rootDirectory - , sourceName - , startingContext - , substitutions - , normalizer - , newManager - , defaultInputSettings - , InputSettings - , defaultEvaluateSettings - , EvaluateSettings - , HasEvaluateSettings(..) , detailed + -- ** Input settings + , Dhall.Settings.InputSettings + , Dhall.Settings.defaultInputSettings + , Dhall.Settings.rootDirectory + , Dhall.Settings.sourceName + , Dhall.Settings.HasInputSettings(..) + + -- ** Evaluation settings + , Dhall.Settings.EvaluateSettings + , Dhall.Settings.defaultEvaluateSettings + , Dhall.Settings.newManager + , Dhall.Settings.normalizer + , Dhall.Settings.startingContext + , Dhall.Settings.substitutions + , Dhall.Settings.HasEvaluateSettings(..) + -- * Decoders , module Dhall.Marshal.Decode @@ -66,10 +71,17 @@ import Data.Either.Validation (Validation (..)) import Data.Void (Void) import Dhall.Import (Imported (..), Status) import Dhall.Parser (Src (..)) +import Dhall.Settings + ( EvaluateSettings + , HasEvaluateSettings + , HasInputSettings + , InputSettings + , defaultEvaluateSettings + , defaultInputSettings + ) import Dhall.Syntax (Expr (..), Import) import Dhall.TypeCheck (DetailedTypeError (..), TypeError) import GHC.Generics -import Lens.Micro (Lens', lens) import Lens.Micro.Extras (view) import Prelude hiding (maybe, sequence) import System.FilePath (takeDirectory) @@ -77,11 +89,11 @@ import System.FilePath (takeDirectory) import qualified Control.Exception import qualified Control.Monad.Trans.State.Strict as State import qualified Data.Text.IO -import qualified Dhall.Context import qualified Dhall.Core as Core import qualified Dhall.Import import qualified Dhall.Parser import qualified Dhall.Pretty.Internal +import qualified Dhall.Settings import qualified Dhall.Substitution import qualified Dhall.TypeCheck import qualified Lens.Micro as Lens @@ -89,128 +101,36 @@ import qualified Lens.Micro as Lens import Dhall.Marshal.Decode import Dhall.Marshal.Encode --- | @since 1.16 -data InputSettings = InputSettings - { _rootDirectory :: FilePath - , _sourceName :: FilePath - , _evaluateSettings :: EvaluateSettings - } - --- | Default input settings: resolves imports relative to @.@ (the --- current working directory), report errors as coming from @(input)@, --- and default evaluation settings from 'defaultEvaluateSettings'. --- --- @since 1.16 -defaultInputSettings :: InputSettings -defaultInputSettings = InputSettings - { _rootDirectory = "." - , _sourceName = "(input)" - , _evaluateSettings = defaultEvaluateSettings - } - - --- | Access the directory to resolve imports relative to. --- --- @since 1.16 -rootDirectory :: Lens' InputSettings FilePath -rootDirectory = lens _rootDirectory (\s x -> s { _rootDirectory = x }) - --- | Access the name of the source to report locations from; this is --- only used in error messages, so it's okay if this is a best guess --- or something symbolic. --- --- @since 1.16 -sourceName :: Lens' InputSettings FilePath -sourceName = lens _sourceName (\s x -> s { _sourceName = x}) - --- | @since 1.16 -data EvaluateSettings = EvaluateSettings - { _substitutions :: Dhall.Substitution.Substitutions Src Void - , _startingContext :: Dhall.Context.Context (Expr Src Void) - , _normalizer :: Maybe (Core.ReifiedNormalizer Void) - , _newManager :: IO Dhall.Import.Manager - } - --- | Default evaluation settings: no extra entries in the initial --- context, and no special normalizer behaviour. --- --- @since 1.16 -defaultEvaluateSettings :: EvaluateSettings -defaultEvaluateSettings = EvaluateSettings - { _substitutions = Dhall.Substitution.empty - , _startingContext = Dhall.Context.empty - , _normalizer = Nothing - , _newManager = Dhall.Import.defaultNewManager - } - --- | Access the starting context used for evaluation and type-checking. --- --- @since 1.16 -startingContext - :: (HasEvaluateSettings s) - => Lens' s (Dhall.Context.Context (Expr Src Void)) -startingContext = - evaluateSettings - . lens _startingContext (\s x -> s { _startingContext = x}) - --- | Access the custom substitutions. --- --- @since 1.30 -substitutions - :: (HasEvaluateSettings s) - => Lens' s (Dhall.Substitution.Substitutions Src Void) -substitutions = - evaluateSettings - . lens _substitutions (\s x -> s { _substitutions = x }) - --- | Access the custom normalizer. --- --- @since 1.16 -normalizer - :: (HasEvaluateSettings s) - => Lens' s (Maybe (Core.ReifiedNormalizer Void)) -normalizer = - evaluateSettings - . lens _normalizer (\s x -> s { _normalizer = x }) - --- | Access the HTTP manager initializer. --- --- @since 1.36 -newManager - :: (HasEvaluateSettings s) - => Lens' s (IO Dhall.Import.Manager) -newManager = - evaluateSettings - . lens _newManager (\s x -> s { _newManager = x }) - --- | @since 1.16 -class HasEvaluateSettings s where - evaluateSettings :: Lens' s EvaluateSettings - -instance HasEvaluateSettings InputSettings where - evaluateSettings = - lens _evaluateSettings (\s x -> s { _evaluateSettings = x }) - -instance HasEvaluateSettings EvaluateSettings where - evaluateSettings = id +-------------------------------------------------------------------------------- +-- Individual phases +-------------------------------------------------------------------------------- -- | 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) +parseWithSettings + :: (HasInputSettings s, MonadThrow m) + => s -> Text -> m (Expr Src Import) +parseWithSettings settings text = do + let sourceName = view Dhall.Settings.sourceName settings + + either throwM return (Dhall.Parser.exprFromText sourceName 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) +typecheckWithSettings + :: (HasEvaluateSettings s, MonadThrow m) + => s -> Expr Src Void -> m () +typecheckWithSettings settings expression = do + let startingContext = view Dhall.Settings.startingContext settings + + either throwM (return . const ()) + (Dhall.TypeCheck.typeWith startingContext expression) {-| Type-check an expression against a type provided as a Dhall expreession, using the supplied `InputSettings` -} checkWithSettings :: - MonadThrow m => + (HasEvaluateSettings s, MonadThrow m) => -- | The input settings - InputSettings -> + s -> -- | The expected type of the expression Expr Src Void -> -- | The expression to check @@ -234,7 +154,9 @@ checkWithSettings settings type_ expression = do 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 + :: (HasEvaluateSettings s, MonadThrow m) + => s -> Decoder a -> Expr Src Void -> m () expectWithSettings settings Decoder{..} expression = do expected' <- case expected of Success x -> return x @@ -247,38 +169,44 @@ expectWithSettings settings Decoder{..} expression = do Note that this also applies any substitutions specified in the `InputSettings` -} -resolveWithSettings :: InputSettings -> Expr Src Import -> IO (Expr Src Void) +resolveWithSettings + :: (HasInputSettings s) + => s -> Expr Src Import -> IO (Expr Src Void) resolveWithSettings settings expression = fst <$> resolveAndStatusWithSettings settings expression -- | A version of 'resolveWithSettings' that also returns the import 'Status' -- together with the resolved expression. resolveAndStatusWithSettings - :: InputSettings - -> Expr Src Import - -> IO (Expr Src Void, Status) + :: (HasInputSettings s) + => s -> Expr Src Import -> IO (Expr Src Void, Status) resolveAndStatusWithSettings settings expression = do - let InputSettings{..} = settings + let inputSettings = view Dhall.Settings.inputSettings settings - let EvaluateSettings{..} = _evaluateSettings + let evaluateSettings = view Dhall.Settings.evaluateSettings inputSettings - let transform = - Lens.set Dhall.Import.substitutions _substitutions - . Lens.set Dhall.Import.normalizer _normalizer - . Lens.set Dhall.Import.startingContext _startingContext + let rootDirectory = view Dhall.Settings.rootDirectory inputSettings - let status = transform (Dhall.Import.emptyStatusWithManager _newManager _rootDirectory) + let substitutions = view Dhall.Settings.substitutions evaluateSettings + + let status = Dhall.Import.emptyStatusWith evaluateSettings rootDirectory (resolved, status') <- State.runStateT (Dhall.Import.loadWith expression) status - let substituted = Dhall.Substitution.substitute resolved (view substitutions settings) + let substituted = Dhall.Substitution.substitute resolved substitutions pure (substituted, status') -- | Normalize an expression, using the supplied `InputSettings` -normalizeWithSettings :: InputSettings -> Expr Src Void -> Expr Src Void +normalizeWithSettings + :: (HasEvaluateSettings s) + => s -> Expr Src Void -> Expr Src Void normalizeWithSettings settings = - Core.normalizeWith (view normalizer settings) + Core.normalizeWith (view Dhall.Settings.normalizer settings) + +-------------------------------------------------------------------------------- +-- High-level entrypoints +-------------------------------------------------------------------------------- {-| Type-check and evaluate a Dhall program, decoding the result into Haskell @@ -366,11 +294,11 @@ inputFileWithSettings -- ^ The decoded value in Haskell. inputFileWithSettings settings ty path = do text <- Data.Text.IO.readFile path - let inputSettings = InputSettings - { _rootDirectory = takeDirectory path - , _sourceName = path - , _evaluateSettings = settings - } + let inputSettings + = Lens.set Dhall.Settings.evaluateSettings settings + . Lens.set Dhall.Settings.rootDirectory (takeDirectory path) + . Lens.set Dhall.Settings.sourceName path + $ Dhall.Settings.defaultInputSettings inputWithSettings inputSettings ty text {-| Similar to `input`, but without interpreting the Dhall `Expr` into a Haskell @@ -405,7 +333,9 @@ inputExprWithSettings settings text = do _ <- typecheckWithSettings settings resolved - pure (Core.normalizeWith (view normalizer settings) resolved) + let normalizer = view Dhall.Settings.normalizer settings + + pure (Core.normalizeWith normalizer resolved) {-| Interpret a Dhall Expression @@ -422,7 +352,9 @@ interpretExprWithSettings settings parsed = do typecheckWithSettings settings resolved - pure (Core.normalizeWith (view normalizer settings) resolved) + let normalizer = view Dhall.Settings.normalizer settings + + pure (Core.normalizeWith normalizer resolved) {- | Decode a Dhall expression @@ -438,7 +370,9 @@ fromExprWithSettings settings decoder@Decoder{..} expression = do expectWithSettings settings decoder resolved - let normalized = Core.normalizeWith (view normalizer settings) resolved + let normalizer = view Dhall.Settings.normalizer settings + + let normalized = Core.normalizeWith normalizer resolved case extract normalized of Success x -> return x diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 7627b8531..f8987c628 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -114,44 +114,56 @@ module Dhall.Import ( , hashExpressionToCode , writeExpressionToSemanticCache , assertNoImports - , Manager - , defaultNewManager - , CacheWarning(..) - , Status(..) - , SemanticCacheMode(..) + , envOriginHeaders + , fetchRemote + , fetchRemoteBytes + , Depends(..) + , toHeaders + , chainImport + , dependencyToFile + , ImportSemantics + , HTTPHeader + , Imported(..) , Chained , chainedImport , chainedFromLocalHere , chainedChangeMode + + -- * Import status + , Status , emptyStatus + , emptyStatusWith , emptyStatusWithManager - , envOriginHeaders , makeEmptyStatus , remoteStatus , remoteStatusWithManager - , fetchRemote - , stack - , cache - , Depends(..) - , graph - , remote - , toHeaders - , substitutions - , normalizer - , startingContext - , chainImport - , dependencyToFile - , ImportSemantics - , HTTPHeader + + -- ** Lenses for accessing the import status + , Dhall.Import.Types.stack + , Dhall.Import.Types.graph + , Dhall.Import.Types.cache + , Dhall.Import.Types.remote + , Dhall.Import.Types.remoteBytes + , Dhall.Settings.substitutions + , Dhall.Settings.normalizer + , Dhall.Settings.startingContext + , Dhall.Import.Types.semanticCacheMode + + -- ** Auxiliary definitions used by the import status + , CacheWarning(..) + , SemanticCacheMode(..) + , Manager + , Dhall.Import.Types.defaultNewManager + + -- * Errors , Cycle(..) - , ReferentiallyOpaque(..) - , Imported(..) + , HashMismatch(..) , ImportResolutionDisabled(..) - , PrettyHttpException(..) , MissingFile(..) , MissingEnvironmentVariable(..) , MissingImports(..) - , HashMismatch(..) + , PrettyHttpException(..) + , ReferentiallyOpaque(..) ) where import Control.Applicative (Alternative (..)) @@ -171,6 +183,7 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Typeable (Typeable) import Data.Void (Void, absurd) +import Dhall.Settings (EvaluateSettings, defaultEvaluateSettings) import Dhall.TypeCheck (TypeError) import Dhall.Util (printWarning) @@ -203,6 +216,17 @@ import Dhall.Import.Headers , toOriginHeaders ) import Dhall.Import.Types + ( CacheWarning (..) + , Chained (..) + , Depends (..) + , HTTPHeader + , ImportSemantics (..) + , Manager + , OriginHeaders + , PrettyHttpException(..) + , SemanticCacheMode(..) + , Status (..) + ) import Dhall.Parser ( ParseError (..) @@ -210,7 +234,7 @@ import Dhall.Parser , SourcedException (..) , Src (..) ) -import Lens.Micro.Mtl (zoom) +import Lens.Micro.Mtl (assign, modifying, use, zoom) import qualified Codec.CBOR.Write as Write import qualified Codec.Serialise @@ -227,12 +251,15 @@ import qualified Data.Text.IO import qualified Dhall.Binary import qualified Dhall.Core as Core import qualified Dhall.Crypto +import qualified Dhall.Import.Types import qualified Dhall.Map import qualified Dhall.Parser import qualified Dhall.Pretty.Internal +import qualified Dhall.Settings import qualified Dhall.Substitution import qualified Dhall.Syntax as Syntax import qualified Dhall.TypeCheck +import qualified Lens.Micro as Lens import qualified System.AtomicWrite.Writer.ByteString.Binary as AtomicWrite.Binary import qualified System.Directory as Directory import qualified System.Environment @@ -363,6 +390,11 @@ instance Show MissingImports where throwMissingImport :: (MonadCatch m, Exception e) => e -> m a throwMissingImport e = throwM (MissingImports [toException e]) +throwMissingImportM :: (Exception e, MonadCatch m, MonadState Status m) => e -> m a +throwMissingImportM e = do + stack <- use Dhall.Import.Types.stack + throwMissingImport (Imported stack e) + -- | Exception thrown when a HTTP url is imported but dhall was built without -- the @with-http@ Cabal flag. data CannotImportHTTPURL = @@ -525,7 +557,7 @@ loadImport import_ = do Just importSemantics -> return importSemantics Nothing -> do importSemantics <- loadImportWithSemanticCache import_ - zoom cache (State.modify (Dhall.Map.insert import_ importSemantics)) + modifying Dhall.Import.Types.cache (Dhall.Map.insert import_ importSemantics) return importSemantics -- | Load an import from the 'semantic cache'. Defers to @@ -546,7 +578,7 @@ loadImportWithSemanticCache mCached <- case _semanticCacheMode of UseSemanticCache -> - zoom cacheWarning (fetchFromSemanticCache semanticHash) + zoom Dhall.Import.Types.cacheWarning (fetchFromSemanticCache semanticHash) IgnoreSemanticCache -> pure Nothing @@ -584,12 +616,10 @@ loadImportWithSemanticCache if actualHash == expectedHash then do - zoom cacheWarning (writeToSemanticCache semanticHash bytes) + zoom Dhall.Import.Types.cacheWarning (writeToSemanticCache semanticHash bytes) else do - Status{ _stack } <- State.get - - throwMissingImport (Imported _stack HashMismatch{..}) + throwMissingImportM (HashMismatch{..}) return ImportSemantics{..} @@ -665,7 +695,7 @@ loadImportWithSemisemanticCache (Chained (Import (ImportHashed _ importType) Cod -- behind semi-semantic caching. let semisemanticHash = computeSemisemanticHash (Core.denote resolvedExpr) - mCached <- zoom cacheWarning (fetchFromSemisemanticCache semisemanticHash) + mCached <- zoom Dhall.Import.Types.cacheWarning (fetchFromSemisemanticCache semisemanticHash) importSemantics <- case mCached of Just bytesStrict -> do @@ -678,8 +708,10 @@ loadImportWithSemisemanticCache (Chained (Import (ImportHashed _ importType) Cod return importSemantics Nothing -> do + substitutions <- use Dhall.Settings.substitutions + let substitutedExpr = - Dhall.Substitution.substitute resolvedExpr _substitutions + Dhall.Substitution.substitute resolvedExpr substitutions case Core.shallowDenote parsedImport of -- If this import trivially wraps another import, we can skip @@ -689,16 +721,20 @@ loadImportWithSemisemanticCache (Chained (Import (ImportHashed _ importType) Cod return (Core.denote substitutedExpr) _ -> do - case Dhall.TypeCheck.typeWith _startingContext substitutedExpr of + startingContext <- use Dhall.Settings.startingContext + + case Dhall.TypeCheck.typeWith startingContext substitutedExpr of Left err -> throwMissingImport (Imported _stack err) Right _ -> return () + normalizer <- use Dhall.Settings.normalizer + let betaNormal = - Core.normalizeWith _normalizer substitutedExpr + Core.normalizeWith normalizer substitutedExpr let bytes = encodeExpression betaNormal - zoom cacheWarning (writeToSemisemanticCache semisemanticHash bytes) + zoom Dhall.Import.Types.cacheWarning (writeToSemisemanticCache semisemanticHash bytes) return betaNormal @@ -775,50 +811,45 @@ writeToSemisemanticCache semisemanticHash bytes = do -- | Fetch source code directly from disk/network fetchFresh :: ImportType -> StateT Status IO Text fetchFresh (Local prefix file) = do - Status { _stack } <- State.get path <- liftIO $ localToPath prefix file exists <- liftIO $ Directory.doesFileExist path if exists then liftIO $ Data.Text.IO.readFile path - else throwMissingImport (Imported _stack (MissingFile path)) + else throwMissingImportM (MissingFile path) fetchFresh (Remote url) = do - Status { _remote } <- State.get - _remote url + remote <- use Dhall.Import.Types.remote + remote url fetchFresh (Env env) = do - Status { _stack } <- State.get x <- liftIO $ System.Environment.lookupEnv (Text.unpack env) case x of Just string -> return (Text.pack string) Nothing -> - throwMissingImport (Imported _stack (MissingEnvironmentVariable env)) + throwMissingImportM (MissingEnvironmentVariable env) fetchFresh Missing = throwM (MissingImports []) -- | Like `fetchFresh`, except for `Dhall.Syntax.Expr.Bytes` fetchBytes :: ImportType -> StateT Status IO ByteString fetchBytes (Local prefix file) = do - Status { _stack } <- State.get path <- liftIO $ localToPath prefix file exists <- liftIO $ Directory.doesFileExist path if exists then liftIO $ Data.ByteString.readFile path - else throwMissingImport (Imported _stack (MissingFile path)) + else throwMissingImport (MissingFile path) fetchBytes (Remote url) = do - Status { _remoteBytes } <- State.get - _remoteBytes url + remoteBytes <- use Dhall.Import.Types.remoteBytes + remoteBytes url fetchBytes (Env env) = do - Status { _stack } <- State.get x <- liftIO $ System.Environment.lookupEnv (Text.unpack env) case x of Just string -> return (Encoding.encodeUtf8 (Text.pack string)) - Nothing -> - throwMissingImport (Imported _stack (MissingEnvironmentVariable env)) + Nothing -> throwMissingImport (MissingEnvironmentVariable env) fetchBytes Missing = throwM (MissingImports []) -- | Fetch the text contents of a URL @@ -827,11 +858,10 @@ fetchRemote :: URL -> StateT Status IO Data.Text.Text fetchRemote (url@URL { headers = maybeHeadersExpression }) = do let maybeHeaders = fmap toHeaders maybeHeadersExpression let urlString = Text.unpack (Core.pretty url) - Status { _stack } <- State.get - throwMissingImport (Imported _stack (CannotImportHTTPURL urlString maybeHeaders)) + throwMissingImportM (CannotImportHTTPURL urlString maybeHeaders) #else fetchRemote url = do - zoom remote (State.put fetchFromHTTP) + assign Dhall.Import.Types.remote fetchFromHTTP fetchFromHTTP url where fetchFromHTTP :: URL -> StateT Status IO Data.Text.Text @@ -846,11 +876,10 @@ fetchRemoteBytes :: URL -> StateT Status IO Data.ByteString.ByteString fetchRemoteBytes (url@URL { headers = maybeHeadersExpression }) = do let maybeHeaders = fmap toHeaders maybeHeadersExpression let urlString = Text.unpack (Core.pretty url) - Status { _stack } <- State.get - throwMissingImport (Imported _stack (CannotImportHTTPURL urlString maybeHeaders)) + throwMissingImportM (CannotImportHTTPURL urlString maybeHeaders) #else fetchRemoteBytes url = do - zoom remoteBytes (State.put fetchFromHTTP) + assign Dhall.Import.Types.remoteBytes fetchFromHTTP fetchFromHTTP url where fetchFromHTTP :: URL -> StateT Status IO Data.ByteString.ByteString @@ -1129,23 +1158,39 @@ originHeadersLoader headersExpr = do -- | Default starting `Status`, importing relative to the given directory. emptyStatus :: FilePath -> Status -emptyStatus = makeEmptyStatus defaultNewManager defaultOriginHeaders +emptyStatus = emptyStatusWith Dhall.Settings.defaultEvaluateSettings + +-- | A version of 'emptyStatus' that also takes some 'EvaluateSettings'. +emptyStatusWith + :: EvaluateSettings + -> FilePath + -> Status +emptyStatusWith settings = makeEmptyStatus settings defaultOriginHeaders --- | See 'emptyStatus' +-- | A version of 'emptyStatus' that also takes an action to create a new +-- 'Manager. emptyStatusWithManager :: IO Manager -> FilePath -> Status -emptyStatusWithManager newManager = makeEmptyStatus newManager defaultOriginHeaders +emptyStatusWithManager newManager = + emptyStatusWith + (Lens.set Dhall.Settings.newManager newManager defaultEvaluateSettings) --- | See 'emptyStatus'. +-- | Like 'emptyStatusWith', but also takes an action to retrieve a headers +-- expression. makeEmptyStatus - :: IO Manager + :: EvaluateSettings -> IO (Expr Src Import) -> FilePath -> Status -makeEmptyStatus newManager headersExpr rootDirectory = - emptyStatusWith newManager (originHeadersLoader headersExpr) fetchRemote fetchRemoteBytes rootImport +makeEmptyStatus settings headersExpr rootDirectory = + Dhall.Import.Types.emptyStatusWith + settings + (originHeadersLoader headersExpr) + fetchRemote + fetchRemoteBytes + rootImport where prefix = if FilePath.isRelative rootDirectory then Here @@ -1173,12 +1218,21 @@ remoteStatus :: URL -- ^ Public address of the server -> Status -remoteStatus = remoteStatusWithManager defaultNewManager +remoteStatus = remoteStatusWithManager Dhall.Import.Types.defaultNewManager -- | See `remoteStatus` remoteStatusWithManager :: IO Manager -> URL -> Status remoteStatusWithManager newManager url = - emptyStatusWith newManager (originHeadersLoader (pure emptyOriginHeaders)) fetchRemote fetchRemoteBytes rootImport + let settings = + Lens.set Dhall.Settings.newManager newManager defaultEvaluateSettings + + in + Dhall.Import.Types.emptyStatusWith + settings + (originHeadersLoader (pure emptyOriginHeaders)) + fetchRemote + fetchRemoteBytes + rootImport where rootImport = Import { importHashed = ImportHashed @@ -1219,15 +1273,16 @@ loadWith expr₀ = case expr₀ of then throwMissingImport (Imported _stack (Cycle import₀)) else return () - zoom graph . State.modify $ - -- Add the edge `parent -> child` to the import graph - \edges -> Depends parent child : edges + -- Add the edge `parent -> child` to the import graph + modifying Dhall.Import.Types.graph (Depends parent child :) let stackWithChild = NonEmpty.cons child _stack - zoom stack (State.put stackWithChild) + --zoom stack (State.put stackWithChild) + assign Dhall.Import.Types.stack stackWithChild ImportSemantics {..} <- loadImport child - zoom stack (State.put _stack) + --zoom stack (State.put _stack) + assign Dhall.Import.Types.stack _stack return (Core.renote importSemantics) @@ -1272,20 +1327,19 @@ loadWith expr₀ = case expr₀ of -- | Resolve all imports within an expression load :: Expr Src Import -> IO (Expr Src Void) -load = loadWithManager defaultNewManager +load = loadWithManager Dhall.Import.Types.defaultNewManager -- | See 'load'. loadWithManager :: IO Manager -> Expr Src Import -> IO (Expr Src Void) loadWithManager newManager = loadWithStatus - (makeEmptyStatus newManager defaultOriginHeaders ".") + (emptyStatusWithManager newManager ".") UseSemanticCache -- | Resolve all imports within an expression, importing relative to the given -- directory. loadRelativeTo :: FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void) -loadRelativeTo parentDirectory = loadWithStatus - (makeEmptyStatus defaultNewManager defaultOriginHeaders parentDirectory) +loadRelativeTo parentDirectory = loadWithStatus (emptyStatus parentDirectory) -- | See 'loadRelativeTo'. loadWithStatus @@ -1355,7 +1409,7 @@ assertNoImports expression = -} dependencyToFile :: Status -> Import -> IO (Maybe FilePath) dependencyToFile status import_ = flip State.evalStateT status $ do - parent :| _ <- zoom stack State.get + parent :| _ <- zoom Dhall.Import.Types.stack State.get child <- fmap chainedImport (hoist liftIO (chainImport parent import_)) diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index 8e4f786ed..4bbf36f5d 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -2,27 +2,19 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wall #-} - module Dhall.Import.Types where -import Control.Exception (Exception) +import Control.Exception (Exception, SomeException) import Control.Monad.Trans.State.Strict (StateT) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) -import Data.Dynamic import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty) +import Data.Typeable (Typeable) import Data.Void (Void) -import Dhall.Context (Context) -import Dhall.Core - ( Expr - , Import (..) - , ReifiedNormalizer (..) - , URL - ) +import Dhall.Core (Expr, Import (..), URL) import Dhall.Map (Map) -import Dhall.Parser (Src) +import Dhall.Settings import Lens.Micro (Lens', lens) import Prettyprinter (Pretty (..)) @@ -31,9 +23,7 @@ import qualified Dhall.Import.Manager #endif import qualified Data.Text -import qualified Dhall.Context import qualified Dhall.Map as Map -import qualified Dhall.Substitution -- | A fully \"chained\" import, i.e. if it contains a relative path that path -- is relative to the current directory. If it is a remote import with headers @@ -93,7 +83,10 @@ data CacheWarning = CacheNotWarned | CacheWarned -- | State threaded throughout the import process data Status = Status - { _stack :: NonEmpty Chained + { _evaluateSettings :: EvaluateSettings + -- ^ The 'EvaluateSettings' to use for the evaluation of imports. + + , _stack :: NonEmpty Chained -- ^ Stack of `Import`s that we've imported along the way to get to the -- current point @@ -105,11 +98,6 @@ data Status = Status -- ^ Cache of imported expressions with their node id in order to avoid -- importing the same expression twice with different values - , _newManager :: IO Manager - , _manager :: Maybe Manager - -- ^ Used to cache the `Dhall.Import.Manager.Manager` when making multiple - -- requests - , _loadOriginHeaders :: StateT Status IO OriginHeaders -- ^ Load the origin headers from environment or configuration file. -- After loading once, further evaluations return the cached version. @@ -120,12 +108,6 @@ data Status = Status , _remoteBytes :: URL -> StateT Status IO Data.ByteString.ByteString -- ^ Like `_remote`, except for `Dhall.Syntax.Expr.Bytes` - , _substitutions :: Dhall.Substitution.Substitutions Src Void - - , _normalizer :: Maybe (ReifiedNormalizer Void) - - , _startingContext :: Context (Expr Src Void) - , _semanticCacheMode :: SemanticCacheMode , _cacheWarning :: CacheWarning @@ -133,35 +115,29 @@ data Status = Status -- cache directory } +instance HasEvaluateSettings Status where + evaluateSettings = + lens _evaluateSettings (\s x -> s { _evaluateSettings = x }) + {-# INLINE evaluateSettings #-} + -- | Initial `Status`, parameterised over the HTTP 'Manager', -- the origin headers and the remote resolver, -- importing relative to the given root import. emptyStatusWith - :: IO Manager + :: EvaluateSettings -> StateT Status IO OriginHeaders -> (URL -> StateT Status IO Data.Text.Text) -> (URL -> StateT Status IO Data.ByteString.ByteString) -> Import -> Status -emptyStatusWith _newManager _loadOriginHeaders _remote _remoteBytes rootImport = Status {..} - where - _stack = pure (Chained rootImport) - - _graph = [] - - _cache = Map.empty - - _manager = Nothing - - _substitutions = Dhall.Substitution.empty - - _normalizer = Nothing - - _startingContext = Dhall.Context.empty - - _semanticCacheMode = UseSemanticCache - - _cacheWarning = CacheNotWarned +emptyStatusWith _evaluateSettings _loadOriginHeaders _remote _remoteBytes rootImport = Status + { _stack = pure (Chained rootImport) + , _graph = [] + , _cache = Map.empty + , _semanticCacheMode = UseSemanticCache + , _cacheWarning = CacheNotWarned + , .. + } -- | Lens from a `Status` to its `_stack` field stack :: Lens' Status (NonEmpty Chained) @@ -175,6 +151,10 @@ graph = lens _graph (\s x -> s { _graph = x }) cache :: Lens' Status (Map Chained ImportSemantics) cache = lens _cache (\s x -> s { _cache = x }) +-- | Lens from a `Status` to its `_loadOriginHeaders` field +loadOriginHeaders :: Lens' Status (StateT Status IO OriginHeaders) +loadOriginHeaders = lens _loadOriginHeaders (\s x -> s { _loadOriginHeaders = x }) + -- | Lens from a `Status` to its `_remote` field remote :: Lens' Status (URL -> StateT Status IO Data.Text.Text) remote = lens _remote (\s x -> s { _remote = x }) @@ -183,17 +163,9 @@ remote = lens _remote (\s x -> s { _remote = x }) remoteBytes :: Lens' Status (URL -> StateT Status IO Data.ByteString.ByteString) remoteBytes = lens _remoteBytes (\s x -> s { _remoteBytes = x }) --- | Lens from a `Status` to its `_substitutions` field -substitutions :: Lens' Status (Dhall.Substitution.Substitutions Src Void) -substitutions = lens _substitutions (\s x -> s { _substitutions = x }) - --- | Lens from a `Status` to its `_normalizer` field -normalizer :: Lens' Status (Maybe (ReifiedNormalizer Void)) -normalizer = lens _normalizer (\s x -> s {_normalizer = x}) - --- | Lens from a `Status` to its `_startingContext` field -startingContext :: Lens' Status (Context (Expr Src Void)) -startingContext = lens _startingContext (\s x -> s { _startingContext = x }) +-- | Lens from a `Status` to its `_semanticCacheMode` field +semanticCacheMode :: Lens' Status SemanticCacheMode +semanticCacheMode = lens _semanticCacheMode (\s x -> s { _semanticCacheMode = x }) -- | Lens from a `Status` to its `_cacheWarning` field cacheWarning :: Lens' Status CacheWarning @@ -235,8 +207,8 @@ instance Exception InternalError -- -- In order to keep the library API constant even when the @with-http@ Cabal -- flag is disabled the pretty error message is pre-rendered and the real --- 'Network.HTTP.Client.HttpException' is stored in a 'Dynamic' -data PrettyHttpException = PrettyHttpException String Dynamic +-- 'Network.HTTP.Client.HttpException' is stored in a 'SomeException' +data PrettyHttpException = PrettyHttpException String SomeException deriving (Typeable) instance Exception PrettyHttpException diff --git a/dhall/src/Dhall/Main.hs b/dhall/src/Dhall/Main.hs index d23427609..637684b5d 100644 --- a/dhall/src/Dhall/Main.hs +++ b/dhall/src/Dhall/Main.hs @@ -31,9 +31,9 @@ import Data.Monoid (Endo (..)) import Data.Text (Text) import Data.Void (Void) import Dhall.Freeze (Intent (..), Scope (..)) -import Dhall.Import +import Dhall.Import (Imported (..)) +import Dhall.Import.Types ( Depends (..) - , Imported (..) , SemanticCacheMode (..) , _semanticCacheMode ) diff --git a/dhall/src/Dhall/Settings.hs b/dhall/src/Dhall/Settings.hs new file mode 100644 index 000000000..8575a9b6e --- /dev/null +++ b/dhall/src/Dhall/Settings.hs @@ -0,0 +1,166 @@ +{-| This module proviedes the different settings used to evaluate a Dhall + expression. +-} + +module Dhall.Settings + ( -- * Input settings + InputSettings + , defaultInputSettings + , rootDirectory + , sourceName + , HasInputSettings (..) + + -- * Evaluation settings + , EvaluateSettings + , defaultEvaluateSettings + , newManager + , normalizer + , startingContext + , substitutions + , HasEvaluateSettings (..) + ) where + +import Data.Void (Void) +import Dhall.Src (Src) +import Dhall.Syntax (Expr) +import Lens.Micro (Lens', lens) +import qualified Dhall.Context +import qualified Dhall.Core +import qualified Dhall.Import.Manager +import qualified Dhall.Substitution + +-------------------------------------------------------------------------------- +-- Input settings +-------------------------------------------------------------------------------- + +-- | @since 1.16 +data InputSettings = InputSettings + { _rootDirectory :: FilePath + , _sourceName :: FilePath + , _evaluateSettings :: EvaluateSettings + } + +-- | Default input settings: Resolves imports relative to @.@ (the +-- current working directory), report errors as coming from @(input)@, +-- and default evaluation settings from 'defaultEvaluateSettings'. +-- +-- @since 1.16 +defaultInputSettings :: InputSettings +defaultInputSettings = InputSettings + { _rootDirectory = "." + , _sourceName = "(input)" + , _evaluateSettings = defaultEvaluateSettings + } + + +-- | Access the directory to resolve imports relative to. +-- +-- @since 1.16 +-- +-- @since 1.43: Work on all types that have an instance of 'HasInputSettings' +-- instead of 'InputSettings'. +rootDirectory + :: (HasInputSettings s) + => Lens' s FilePath +rootDirectory = + inputSettings + . lens _rootDirectory (\s x -> s { _rootDirectory = x }) + +-- | Access the name of the source to report locations from; this is +-- only used in error messages, so it's okay if this is a best guess +-- or something symbolic. +-- +-- @since 1.16 +-- +-- @since 1.43: Work on all types that have an instance of 'HasInputSettings' +-- instead of 'InputSettings'. +sourceName + :: (HasInputSettings s) + => Lens' s FilePath +sourceName = + inputSettings + . lens _sourceName (\s x -> s { _sourceName = x}) + +-- | @since 1.43 +class HasInputSettings s where + inputSettings :: Lens' s InputSettings + +instance HasInputSettings InputSettings where + inputSettings = id + + + +-------------------------------------------------------------------------------- +-- Evaluation settings +-------------------------------------------------------------------------------- + +-- | @since 1.16 +data EvaluateSettings = EvaluateSettings + { _newManager :: IO Dhall.Import.Manager.Manager + , _normalizer :: Maybe (Dhall.Core.ReifiedNormalizer Void) + , _startingContext :: Dhall.Context.Context (Expr Src Void) + , _substitutions :: Dhall.Substitution.Substitutions Src Void + } + +-- | Default evaluation settings: No extra entries in the initial +-- context, and no special normalizer behaviour. +-- +-- @since 1.16 +defaultEvaluateSettings :: EvaluateSettings +defaultEvaluateSettings = EvaluateSettings + { _newManager = Dhall.Import.Manager.defaultNewManager + , _normalizer = Nothing + , _startingContext = Dhall.Context.empty + , _substitutions = Dhall.Substitution.empty + } + +-- | Access the starting context used for evaluation and type-checking. +-- +-- @since 1.16 +startingContext + :: (HasEvaluateSettings s) + => Lens' s (Dhall.Context.Context (Expr Src Void)) +startingContext = + evaluateSettings + . lens _startingContext (\s x -> s { _startingContext = x}) + +-- | Access the custom substitutions. +-- +-- @since 1.30 +substitutions + :: (HasEvaluateSettings s) + => Lens' s (Dhall.Substitution.Substitutions Src Void) +substitutions = + evaluateSettings + . lens _substitutions (\s x -> s { _substitutions = x }) + +-- | Access the custom normalizer. +-- +-- @since 1.16 +normalizer + :: (HasEvaluateSettings s) + => Lens' s (Maybe (Dhall.Core.ReifiedNormalizer Void)) +normalizer = + evaluateSettings + . lens _normalizer (\s x -> s { _normalizer = x }) + +-- | Access the HTTP manager initializer. +-- +-- @since 1.36 +newManager + :: (HasEvaluateSettings s) + => Lens' s (IO Dhall.Import.Manager.Manager) +newManager = + evaluateSettings + . lens _newManager (\s x -> s { _newManager = x }) + +-- | @since 1.16 +class HasEvaluateSettings s where + evaluateSettings :: Lens' s EvaluateSettings + +instance HasEvaluateSettings InputSettings where + evaluateSettings = + lens _evaluateSettings (\s x -> s { _evaluateSettings = x }) + +instance HasEvaluateSettings EvaluateSettings where + evaluateSettings = id diff --git a/dhall/tests/Dhall/Test/Import.hs b/dhall/tests/Dhall/Test/Import.hs index 61bb72b7e..f91fecbc8 100644 --- a/dhall/tests/Dhall/Test/Import.hs +++ b/dhall/tests/Dhall/Test/Import.hs @@ -14,10 +14,12 @@ import qualified Control.Exception as Exception import qualified Control.Monad.Trans.State.Strict as State import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO +import qualified Dhall import qualified Dhall.Core as Core import qualified Dhall.Import as Import import qualified Dhall.Parser as Parser import qualified Dhall.Test.Util as Test.Util +import qualified Lens.Micro as Lens import qualified System.FilePath as FilePath import qualified System.IO.Temp as Temp import qualified Test.Tasty as Tasty @@ -147,9 +149,11 @@ successTest prefix = do HTTP.tlsManagerSettings { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (120 * 1000 * 1000) } + let settings = Lens.set Dhall.newManager httpManager Dhall.defaultEvaluateSettings + let status = Import.makeEmptyStatus - httpManager + settings (pure Import.envOriginHeaders) directoryString #else diff --git a/dhall/tests/Dhall/Test/Util.hs b/dhall/tests/Dhall/Test/Util.hs index 3f45f8ec6..a38014a42 100644 --- a/dhall/tests/Dhall/Test/Util.hs +++ b/dhall/tests/Dhall/Test/Util.hs @@ -43,8 +43,9 @@ import Dhall.Core , Normalizer , ReifiedNormalizer (..) ) -import Dhall.Import (SemanticCacheMode (..), Status (..)) +import Dhall.Import (SemanticCacheMode (..), Status) import Dhall.Parser (Src) +import Lens.Micro (set) import System.IO.Error (isDoesNotExistError) import Test.Tasty (TestTree) import Test.Tasty.HUnit @@ -108,7 +109,7 @@ loadRelativeTo :: FilePath.FilePath -> SemanticCacheMode -> Expr Src Import -> I loadRelativeTo rootDirectory semanticCacheMode expression = State.evalStateT (loadWith expression) - (Dhall.Import.emptyStatus rootDirectory) { _semanticCacheMode = semanticCacheMode } + (set Dhall.Import.semanticCacheMode semanticCacheMode (Dhall.Import.emptyStatus rootDirectory)) #if defined(WITH_HTTP) && defined(NETWORK_TESTS) loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void)