From a5935dc2552932fadf6b0a2d1865854fa1ac27be Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 27 Feb 2025 16:15:40 +0100 Subject: [PATCH 1/4] Removed _manager field from Dhall.Import.Types.Status Simply replace the value of `_newManager` with `return manager` for caching an already acquired `manager`. --- dhall/ghc-src/Dhall/Import/HTTP.hs | 15 +++++---------- dhall/src/Dhall/Import/Types.hs | 3 --- 2 files changed, 5 insertions(+), 13 deletions(-) diff --git a/dhall/ghc-src/Dhall/Import/HTTP.hs b/dhall/ghc-src/Dhall/Import/HTTP.hs index 4438a055e..4bf410b42 100644 --- a/dhall/ghc-src/Dhall/Import/HTTP.hs +++ b/dhall/ghc-src/Dhall/Import/HTTP.hs @@ -162,18 +162,13 @@ renderPrettyHttpException url (HttpExceptionRequest _ e) = newManager :: StateT Status IO Manager newManager = do - Status { _manager = oldManager, ..} <- State.get - - case oldManager of - Nothing -> do - manager <- liftIO _newManager + Status {..} <- State.get - State.put (Status { _manager = Just manager , ..}) + manager <- liftIO _newManager - return manager + State.put (Status { _newManager = return manager , ..}) - Just manager -> - return manager + return manager data NotCORSCompliant = NotCORSCompliant { expectedOrigins :: [ByteString] @@ -255,7 +250,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)) diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index 8e4f786ed..37991f36d 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -106,7 +106,6 @@ data Status = Status -- 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 @@ -151,8 +150,6 @@ emptyStatusWith _newManager _loadOriginHeaders _remote _remoteBytes rootImport = _cache = Map.empty - _manager = Nothing - _substitutions = Dhall.Substitution.empty _normalizer = Nothing From 80baaab2557f86c02e4bdd5d195fc62ae11cf09c Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 27 Feb 2025 17:27:19 +0100 Subject: [PATCH 2/4] Do not export data constructor of Dhall.Import.Types.Status --- dhall-nixpkgs/Main.hs | 2 +- dhall/src/Dhall/Import.hs | 112 +++++++++++++++++++------------- dhall/src/Dhall/Import/Types.hs | 32 +++++---- dhall/src/Dhall/Main.hs | 4 +- dhall/tests/Dhall/Test/Util.hs | 5 +- 5 files changed, 89 insertions(+), 66 deletions(-) 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/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 7627b8531..57f0f4c8f 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -114,44 +114,55 @@ 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 , 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.Import.Types.substitutions + , Dhall.Import.Types.normalizer + , Dhall.Import.Types.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 (..)) @@ -203,6 +214,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 +232,7 @@ import Dhall.Parser , SourcedException (..) , Src (..) ) -import Lens.Micro.Mtl (zoom) +import Lens.Micro.Mtl (assign, modifying, zoom) import qualified Codec.CBOR.Write as Write import qualified Codec.Serialise @@ -227,6 +249,7 @@ 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 @@ -525,7 +548,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 +569,7 @@ loadImportWithSemanticCache mCached <- case _semanticCacheMode of UseSemanticCache -> - zoom cacheWarning (fetchFromSemanticCache semanticHash) + zoom Dhall.Import.Types.cacheWarning (fetchFromSemanticCache semanticHash) IgnoreSemanticCache -> pure Nothing @@ -584,7 +607,7 @@ 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 @@ -665,7 +688,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 @@ -698,7 +721,7 @@ loadImportWithSemisemanticCache (Chained (Import (ImportHashed _ importType) Cod let bytes = encodeExpression betaNormal - zoom cacheWarning (writeToSemisemanticCache semisemanticHash bytes) + zoom Dhall.Import.Types.cacheWarning (writeToSemisemanticCache semisemanticHash bytes) return betaNormal @@ -831,7 +854,7 @@ fetchRemote (url@URL { headers = maybeHeadersExpression }) = do throwMissingImport (Imported _stack (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 @@ -850,7 +873,7 @@ fetchRemoteBytes (url@URL { headers = maybeHeadersExpression }) = do throwMissingImport (Imported _stack (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,7 +1152,7 @@ originHeadersLoader headersExpr = do -- | Default starting `Status`, importing relative to the given directory. emptyStatus :: FilePath -> Status -emptyStatus = makeEmptyStatus defaultNewManager defaultOriginHeaders +emptyStatus = makeEmptyStatus Dhall.Import.Types.defaultNewManager defaultOriginHeaders -- | See 'emptyStatus' emptyStatusWithManager @@ -1145,7 +1168,7 @@ makeEmptyStatus -> FilePath -> Status makeEmptyStatus newManager headersExpr rootDirectory = - emptyStatusWith newManager (originHeadersLoader headersExpr) fetchRemote fetchRemoteBytes rootImport + Dhall.Import.Types.emptyStatusWith newManager (originHeadersLoader headersExpr) fetchRemote fetchRemoteBytes rootImport where prefix = if FilePath.isRelative rootDirectory then Here @@ -1173,12 +1196,12 @@ 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 + Dhall.Import.Types.emptyStatusWith newManager (originHeadersLoader (pure emptyOriginHeaders)) fetchRemote fetchRemoteBytes rootImport where rootImport = Import { importHashed = ImportHashed @@ -1219,15 +1242,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,7 +1296,7 @@ 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) @@ -1285,7 +1309,7 @@ loadWithManager newManager = -- directory. loadRelativeTo :: FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void) loadRelativeTo parentDirectory = loadWithStatus - (makeEmptyStatus defaultNewManager defaultOriginHeaders parentDirectory) + (makeEmptyStatus Dhall.Import.Types.defaultNewManager defaultOriginHeaders parentDirectory) -- | See 'loadRelativeTo'. loadWithStatus @@ -1355,7 +1379,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 37991f36d..256315ffa 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -142,23 +142,17 @@ emptyStatusWith -> (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 - - _substitutions = Dhall.Substitution.empty - - _normalizer = Nothing - - _startingContext = Dhall.Context.empty - - _semanticCacheMode = UseSemanticCache - - _cacheWarning = CacheNotWarned +emptyStatusWith _newManager _loadOriginHeaders _remote _remoteBytes rootImport = Status + { _stack = pure (Chained rootImport) + , _graph = [] + , _cache = Map.empty + , _substitutions = Dhall.Substitution.empty + , _normalizer = Nothing + , _startingContext = Dhall.Context.empty + , _semanticCacheMode = UseSemanticCache + , _cacheWarning = CacheNotWarned + , .. + } -- | Lens from a `Status` to its `_stack` field stack :: Lens' Status (NonEmpty Chained) @@ -192,6 +186,10 @@ normalizer = lens _normalizer (\s x -> s {_normalizer = x}) 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 cacheWarning = lens _cacheWarning (\s x -> s { _cacheWarning = x }) 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/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) From 92b3b6aae3dd346b35f3012d5f2dfd0f5faf6660 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 27 Feb 2025 18:06:16 +0100 Subject: [PATCH 3/4] Dhall.Import namespace: Use more lenses --- dhall/ghc-src/Dhall/Import/HTTP.hs | 33 +++++++++++++------------- dhall/src/Dhall/Import.hs | 38 +++++++++++++----------------- dhall/src/Dhall/Import/Types.hs | 16 +++++++++---- 3 files changed, 45 insertions(+), 42 deletions(-) diff --git a/dhall/ghc-src/Dhall/Import/HTTP.hs b/dhall/ghc-src/Dhall/Import/HTTP.hs index 4bf410b42..b5e859511 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,34 @@ 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.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,12 +170,8 @@ renderPrettyHttpException url (HttpExceptionRequest _ e) = newManager :: StateT Status IO Manager newManager = do - Status {..} <- State.get - - manager <- liftIO _newManager - - State.put (Status { _newManager = return manager , ..}) - + manager <- liftIO =<< use Dhall.Import.Types.newManager + assign Dhall.Import.Types.newManager (return manager) return manager data NotCORSCompliant = NotCORSCompliant @@ -264,10 +268,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) @@ -284,9 +285,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/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 57f0f4c8f..c0486b385 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -232,7 +232,7 @@ import Dhall.Parser , SourcedException (..) , Src (..) ) -import Lens.Micro.Mtl (assign, modifying, zoom) +import Lens.Micro.Mtl (assign, modifying, use, zoom) import qualified Codec.CBOR.Write as Write import qualified Codec.Serialise @@ -386,6 +386,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 = @@ -610,9 +615,7 @@ loadImportWithSemanticCache zoom Dhall.Import.Types.cacheWarning (writeToSemanticCache semanticHash bytes) else do - Status{ _stack } <- State.get - - throwMissingImport (Imported _stack HashMismatch{..}) + throwMissingImportM (HashMismatch{..}) return ImportSemantics{..} @@ -798,50 +801,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 @@ -850,8 +848,7 @@ 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 assign Dhall.Import.Types.remote fetchFromHTTP @@ -869,8 +866,7 @@ 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 assign Dhall.Import.Types.remoteBytes fetchFromHTTP diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index 256315ffa..bbdea7005 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -6,13 +6,13 @@ 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 @@ -166,6 +166,14 @@ 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 `_newManager` field +newManager :: Lens' Status (IO Manager) +newManager = lens _newManager (\s x -> s { _newManager = 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 }) @@ -230,8 +238,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 From 25d60c6a8247b9ce37362b11342bc8c266175974 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 28 Feb 2025 15:52:21 +0100 Subject: [PATCH 4/4] Moved EvaluateSettings and InputSettings to own module Those settings as well as the lenses necessary to access their fields live now in an own internal module Dhall.Settings. This enables us to remove all fields from Dhall.Import.Status that were in fact duplicates of the fields of EvaluateSettings. --- dhall/dhall.cabal | 1 + dhall/ghc-src/Dhall/Import/HTTP.hs | 5 +- dhall/ghcjs-src/Dhall/Import/Manager.hs | 13 +- dhall/src/Dhall.hs | 230 +++++++++--------------- dhall/src/Dhall/Import.hs | 68 +++++-- dhall/src/Dhall/Import/Types.hs | 57 ++---- dhall/src/Dhall/Settings.hs | 166 +++++++++++++++++ dhall/tests/Dhall/Test/Import.hs | 6 +- 8 files changed, 327 insertions(+), 219 deletions(-) create mode 100644 dhall/src/Dhall/Settings.hs 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 b5e859511..8d977c958 100644 --- a/dhall/ghc-src/Dhall/Import/HTTP.hs +++ b/dhall/ghc-src/Dhall/Import/HTTP.hs @@ -51,6 +51,7 @@ 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 @@ -170,8 +171,8 @@ renderPrettyHttpException url (HttpExceptionRequest _ e) = newManager :: StateT Status IO Manager newManager = do - manager <- liftIO =<< use Dhall.Import.Types.newManager - assign Dhall.Import.Types.newManager (return manager) + manager <- liftIO =<< use Dhall.Settings.newManager + assign Dhall.Settings.newManager (return manager) return manager data NotCORSCompliant = NotCORSCompliant 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 c0486b385..f8987c628 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -132,6 +132,7 @@ module Dhall.Import ( -- * Import status , Status , emptyStatus + , emptyStatusWith , emptyStatusWithManager , makeEmptyStatus , remoteStatus @@ -143,9 +144,9 @@ module Dhall.Import ( , Dhall.Import.Types.cache , Dhall.Import.Types.remote , Dhall.Import.Types.remoteBytes - , Dhall.Import.Types.substitutions - , Dhall.Import.Types.normalizer - , Dhall.Import.Types.startingContext + , Dhall.Settings.substitutions + , Dhall.Settings.normalizer + , Dhall.Settings.startingContext , Dhall.Import.Types.semanticCacheMode -- ** Auxiliary definitions used by the import status @@ -182,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) @@ -253,9 +255,11 @@ 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 @@ -704,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 @@ -715,12 +721,16 @@ 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 @@ -1148,23 +1158,39 @@ originHeadersLoader headersExpr = do -- | Default starting `Status`, importing relative to the given directory. emptyStatus :: FilePath -> Status -emptyStatus = makeEmptyStatus Dhall.Import.Types.defaultNewManager defaultOriginHeaders +emptyStatus = emptyStatusWith Dhall.Settings.defaultEvaluateSettings --- | See 'emptyStatus' +-- | A version of 'emptyStatus' that also takes some 'EvaluateSettings'. +emptyStatusWith + :: EvaluateSettings + -> FilePath + -> Status +emptyStatusWith settings = makeEmptyStatus settings defaultOriginHeaders + +-- | 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 = - Dhall.Import.Types.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 @@ -1197,7 +1223,16 @@ remoteStatus = remoteStatusWithManager Dhall.Import.Types.defaultNewManager -- | See `remoteStatus` remoteStatusWithManager :: IO Manager -> URL -> Status remoteStatusWithManager newManager url = - Dhall.Import.Types.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 @@ -1298,14 +1333,13 @@ load = loadWithManager Dhall.Import.Types.defaultNewManager 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 Dhall.Import.Types.defaultNewManager defaultOriginHeaders parentDirectory) +loadRelativeTo parentDirectory = loadWithStatus (emptyStatus parentDirectory) -- | See 'loadRelativeTo'. loadWithStatus diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index bbdea7005..4bbf36f5d 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -2,8 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wall #-} - module Dhall.Import.Types where import Control.Exception (Exception, SomeException) @@ -14,15 +12,9 @@ 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,10 +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 - -- ^ 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. @@ -119,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 @@ -132,23 +115,25 @@ 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 +emptyStatusWith _evaluateSettings _loadOriginHeaders _remote _remoteBytes rootImport = Status { _stack = pure (Chained rootImport) , _graph = [] , _cache = Map.empty - , _substitutions = Dhall.Substitution.empty - , _normalizer = Nothing - , _startingContext = Dhall.Context.empty , _semanticCacheMode = UseSemanticCache , _cacheWarning = CacheNotWarned , .. @@ -166,10 +151,6 @@ 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 `_newManager` field -newManager :: Lens' Status (IO Manager) -newManager = lens _newManager (\s x -> s { _newManager = x }) - -- | Lens from a `Status` to its `_loadOriginHeaders` field loadOriginHeaders :: Lens' Status (StateT Status IO OriginHeaders) loadOriginHeaders = lens _loadOriginHeaders (\s x -> s { _loadOriginHeaders = x }) @@ -182,18 +163,6 @@ 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 }) 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