Allow setting the root directory to not be CWD (#508)
* Add various functions explicitly taking a root directory. Now the importing code is not tied to the current working directory: it can resolve imports relative to any directory passed to it. Fixes #507. * Test for being able to set the base directory * Refactor the loadDir* variants slightly. * Re-implement CWD independence by having a fake root import Imports resolve directories relative to their parent import. Hence, we can put in a fake import at the root to control the resolution of relative imports. * Correct the error display for imports. My understanding of the previous code was wrong: it was dropping the outermost import because `canonicalizeImport` was already using the fake import trick. * Undo incidental whitespace and punctuation changes. * Refactor loadStaticWith slightly. * One more loadStaticWith refactor. * Correct @since entries.
This commit is contained in:
quasicomputational
GitHub
parent
73c055953b
commit
8c15d8f055
63
src/Dhall.hs
63
src/Dhall.hs
|
|
@ -22,8 +22,10 @@ module Dhall
|
|||
, inputFrom
|
||||
, inputWith
|
||||
, inputFromWith
|
||||
, inputDirFromWith
|
||||
, inputExpr
|
||||
, inputExprWith
|
||||
, inputExprDirWith
|
||||
, detailed
|
||||
|
||||
-- * Types
|
||||
|
|
@ -149,6 +151,8 @@ instance Exception InvalidType
|
|||
|
||||
>>> input auto "True" :: IO Bool
|
||||
True
|
||||
|
||||
Resolves imports relative to @.@ (the current working directory).
|
||||
-}
|
||||
input
|
||||
:: Type a
|
||||
|
|
@ -160,6 +164,7 @@ input
|
|||
input =
|
||||
inputFrom "(input)"
|
||||
|
||||
-- | Resolves imports relative to @.@ (the current working directory).
|
||||
inputFrom
|
||||
:: FilePath
|
||||
-- ^ The source file to report locations from; only used in error messages
|
||||
|
|
@ -174,6 +179,8 @@ inputFrom filename ty txt =
|
|||
|
||||
{-| Extend 'input' with a custom typing context and normalization process.
|
||||
|
||||
Resolves imports relative to @.@ (the current working directory).
|
||||
|
||||
-}
|
||||
inputWith
|
||||
:: Type a
|
||||
|
|
@ -190,6 +197,8 @@ inputWith =
|
|||
|
||||
{-| Extend 'inputFrom' with a custom typing context and normalization process.
|
||||
|
||||
Resolves imports relative to @.@ (the current working directory).
|
||||
|
||||
-}
|
||||
inputFromWith
|
||||
:: FilePath
|
||||
|
|
@ -203,9 +212,32 @@ inputFromWith
|
|||
-- ^ The Dhall program
|
||||
-> IO a
|
||||
-- ^ The decoded value in Haskell
|
||||
inputFromWith filename (Type {..}) ctx n txt = do
|
||||
inputFromWith filename ty ctx n txt =
|
||||
inputDirFromWith "." filename ty ctx n txt
|
||||
|
||||
{-| Extend 'inputFrom' with a root directory to resolve imports relative
|
||||
to, a file to mention in errors as the source, a custom typing
|
||||
context, and a custom normalization process.
|
||||
|
||||
@since 1.16
|
||||
-}
|
||||
inputDirFromWith
|
||||
:: FilePath
|
||||
-- ^ The directory to resolve imports relative to.
|
||||
-> FilePath
|
||||
-- ^ The source file to report locations from; only used in error messages
|
||||
-> Type a
|
||||
-- ^ The type of value to decode from Dhall to Haskell
|
||||
-> Dhall.Context.Context (Expr Src X)
|
||||
-- ^ The starting context for type-checking
|
||||
-> Dhall.Core.Normalizer X
|
||||
-> Text
|
||||
-- ^ The Dhall program
|
||||
-> IO a
|
||||
-- ^ The decoded value in Haskell
|
||||
inputDirFromWith dir filename (Type {..}) ctx n txt = do
|
||||
expr <- throws (Dhall.Parser.exprFromText filename txt)
|
||||
expr' <- Dhall.Import.loadWithContext ctx n expr
|
||||
expr' <- Dhall.Import.loadDirWith dir Dhall.Import.exprFromImport ctx n expr
|
||||
let suffix = Dhall.Pretty.Internal.prettyToStrictText expected
|
||||
let annot = case expr' of
|
||||
Note (Src begin end bytes) _ ->
|
||||
|
|
@ -221,6 +253,9 @@ inputFromWith filename (Type {..}) ctx n txt = do
|
|||
|
||||
{-| Similar to `input`, but without interpreting the Dhall `Expr` into a Haskell
|
||||
type.
|
||||
|
||||
Resolves imports relative to @.@ (the current working directory).
|
||||
|
||||
-}
|
||||
inputExpr
|
||||
:: Text
|
||||
|
|
@ -230,6 +265,9 @@ inputExpr
|
|||
inputExpr = inputExprWith Dhall.Context.empty (const Nothing)
|
||||
|
||||
{-| Extend `inputExpr` with a custom typing context and normalization process.
|
||||
|
||||
Resolves imports relative to @.@ (the current working directory).
|
||||
|
||||
-}
|
||||
inputExprWith
|
||||
:: Dhall.Context.Context (Expr Src X)
|
||||
|
|
@ -240,11 +278,30 @@ inputExprWith
|
|||
-> IO (Expr Src X)
|
||||
-- ^ The fully normalized AST
|
||||
inputExprWith ctx n txt = do
|
||||
inputExprDirWith "." ctx n txt
|
||||
|
||||
{-| Extend `inputExpr` with a directory to resolve imports relative to,
|
||||
custom typing context and normalization process.
|
||||
|
||||
@since 1.16
|
||||
-}
|
||||
inputExprDirWith
|
||||
:: FilePath
|
||||
-- ^ The directory to resolve imports relative to.
|
||||
-> Dhall.Context.Context (Expr Src X)
|
||||
-- ^ The starting context for type-checking
|
||||
-> Dhall.Core.Normalizer X
|
||||
-> Text
|
||||
-- ^ The Dhall program
|
||||
-> IO (Expr Src X)
|
||||
-- ^ The fully normalized AST
|
||||
inputExprDirWith dir ctx n txt = do
|
||||
expr <- throws (Dhall.Parser.exprFromText "(input)" txt)
|
||||
expr' <- Dhall.Import.loadWithContext ctx n expr
|
||||
expr' <- Dhall.Import.loadDirWith dir Dhall.Import.exprFromImport ctx n expr
|
||||
_ <- throws (Dhall.TypeCheck.typeWith ctx expr')
|
||||
pure (Dhall.Core.normalizeWith n expr')
|
||||
|
||||
|
||||
-- | Use this function to extract Haskell values directly from Dhall AST.
|
||||
-- The intended use case is to allow easy extraction of Dhall values for
|
||||
-- making the function `Dhall.Core.normalizeWith` easier to use.
|
||||
|
|
|
|||
|
|
@ -102,6 +102,7 @@ module Dhall.Import (
|
|||
exprFromImport
|
||||
, load
|
||||
, loadWith
|
||||
, loadDirWith
|
||||
, loadWithContext
|
||||
, hashExpression
|
||||
, hashExpressionToCode
|
||||
|
|
@ -158,8 +159,8 @@ import qualified Data.ByteString
|
|||
import qualified Data.CaseInsensitive
|
||||
import qualified Data.Foldable
|
||||
|
||||
import qualified Data.List as List
|
||||
import qualified Data.HashMap.Strict.InsOrd
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text.Encoding
|
||||
import qualified Data.Text as Text
|
||||
|
|
@ -225,23 +226,23 @@ instance Show ReferentiallyOpaque where
|
|||
|
||||
-- | Extend another exception with the current import stack
|
||||
data Imported e = Imported
|
||||
{ importStack :: [Import] -- ^ Imports resolved so far, in reverse order
|
||||
, nested :: e -- ^ The nested exception
|
||||
{ importStack :: NonEmpty Import -- ^ Imports resolved so far, in reverse order
|
||||
, nested :: e -- ^ The nested exception
|
||||
} deriving (Typeable)
|
||||
|
||||
instance Exception e => Exception (Imported e)
|
||||
|
||||
instance Show e => Show (Imported e) where
|
||||
show (Imported imports e) =
|
||||
(case imports of [] -> ""; _ -> "\n")
|
||||
++ unlines (map indent imports')
|
||||
++ show e
|
||||
concat (zipWith indent [0..] toDisplay)
|
||||
++ show e
|
||||
where
|
||||
indent (n, import_) =
|
||||
take (2 * n) (repeat ' ') ++ "↳ " ++ Dhall.Pretty.Internal.prettyToString import_
|
||||
-- Canonicalize all imports
|
||||
imports' = zip [0..] (drop 1 (reverse (canonicalizeAll imports)))
|
||||
|
||||
indent n import_ =
|
||||
"\n" ++ replicate (2 * n) ' ' ++ "↳ " ++ Dhall.Pretty.Internal.prettyToString import_
|
||||
canonical = NonEmpty.toList (canonicalizeAll imports)
|
||||
-- Tthe final (outermost) import is fake to establish the base
|
||||
-- directory. Also, we need outermost-first.
|
||||
toDisplay = drop 1 (reverse canonical)
|
||||
|
||||
-- | Exception thrown when an imported file is missing
|
||||
data MissingFile = MissingFile FilePath
|
||||
|
|
@ -312,8 +313,10 @@ instance Show CannotImportHTTPURL where
|
|||
<> url
|
||||
<> "\n"
|
||||
|
||||
canonicalizeAll :: [Import] -> [Import]
|
||||
canonicalizeAll = map canonicalizeImport . List.tails
|
||||
canonicalizeAll :: NonEmpty Import -> NonEmpty Import
|
||||
canonicalizeAll = NonEmpty.scanr1 step
|
||||
where
|
||||
step a parent = canonicalizeImport (a :| [parent])
|
||||
|
||||
{-|
|
||||
> canonicalize (canonicalize x) = canonicalize x
|
||||
|
|
@ -369,18 +372,9 @@ instance Canonicalize Import where
|
|||
canonicalize (Import importHashed importMode) =
|
||||
Import (canonicalize importHashed) importMode
|
||||
|
||||
canonicalizeImport :: [Import] -> Import
|
||||
canonicalizeImport :: NonEmpty Import -> Import
|
||||
canonicalizeImport imports =
|
||||
canonicalize (sconcat (defaultImport :| reverse imports))
|
||||
where
|
||||
defaultImport =
|
||||
Import
|
||||
{ importMode = Code
|
||||
, importHashed = ImportHashed
|
||||
{ hash = Nothing
|
||||
, importType = Local Here (File (Directory []) ".")
|
||||
}
|
||||
}
|
||||
canonicalize (sconcat (NonEmpty.reverse imports))
|
||||
|
||||
toHeaders
|
||||
:: Expr s a
|
||||
|
|
@ -534,8 +528,11 @@ exprFromImport (Import {..}) = do
|
|||
RawText -> do
|
||||
return (TextLit (Chunks [] text))
|
||||
|
||||
-- | Resolve all imports within an expression using a custom typing context and
|
||||
-- `Import`-resolving callback in arbitrary `MonadCatch` monad.
|
||||
-- | Resolve all imports within an expression using a custom typing
|
||||
-- context and `Import`-resolving callback in arbitrary `MonadCatch`
|
||||
-- monad.
|
||||
--
|
||||
-- This resolves imports relative to @.@ (the current working directory).
|
||||
loadWith
|
||||
:: MonadCatch m
|
||||
=> (Import -> StateT Status m (Expr Src Import))
|
||||
|
|
@ -544,9 +541,26 @@ loadWith
|
|||
-> Expr Src Import
|
||||
-> m (Expr Src X)
|
||||
loadWith from_import ctx n expr =
|
||||
State.evalStateT (loadStaticWith from_import ctx n expr) emptyStatus
|
||||
loadDirWith "." from_import ctx n expr
|
||||
|
||||
-- | Resolve all imports within an expression using a custom typing context.
|
||||
-- | Resolve all imports within an expression using a custom typing
|
||||
-- context and `Import`-resolving callback in arbitrary `MonadCatch`
|
||||
-- monad, relative to a given directory.
|
||||
--
|
||||
-- @since 1.16
|
||||
loadDirWith
|
||||
:: MonadCatch m
|
||||
=> FilePath
|
||||
-> (Import -> StateT Status m (Expr Src Import))
|
||||
-> Dhall.Context.Context (Expr Src X)
|
||||
-> Dhall.Core.Normalizer X
|
||||
-> Expr Src Import
|
||||
-> m (Expr Src X)
|
||||
loadDirWith dir from_import ctx n expr = do
|
||||
State.evalStateT (loadStaticWith from_import ctx n expr) (emptyStatus dir)
|
||||
|
||||
-- | Resolve all imports within an expression, relative to @.@ (the
|
||||
-- current working directory), using a custom typing context.
|
||||
--
|
||||
-- @load = loadWithContext Dhall.Context.empty@
|
||||
loadWithContext
|
||||
|
|
@ -555,7 +569,8 @@ loadWithContext
|
|||
-> Expr Src Import
|
||||
-> IO (Expr Src X)
|
||||
loadWithContext ctx n expr =
|
||||
State.evalStateT (loadStaticWith exprFromImport ctx n expr) emptyStatus
|
||||
loadDirWith "." exprFromImport ctx n expr
|
||||
|
||||
|
||||
-- | This loads a \"static\" expression (i.e. an expression free of imports)
|
||||
loadStaticWith
|
||||
|
|
@ -574,8 +589,9 @@ loadStaticWith from_import ctx n expr₀ = case expr₀ of
|
|||
local (Import (ImportHashed _ (Env {})) _) = True
|
||||
local (Import (ImportHashed _ (Missing {})) _) = True
|
||||
|
||||
let parent = canonicalizeImport imports
|
||||
let here = canonicalizeImport (import_:imports)
|
||||
let parent = canonicalizeImport imports
|
||||
let imports' = NonEmpty.cons import_ imports
|
||||
let here = canonicalizeImport imports'
|
||||
|
||||
if local here && not (local parent)
|
||||
then throwMissingImport (Imported imports (ReferentiallyOpaque import_))
|
||||
|
|
@ -601,27 +617,26 @@ loadStaticWith from_import ctx n expr₀ = case expr₀ of
|
|||
-> StateT Status m (Expr Src Import)
|
||||
handler₀ e@(MissingImports []) = throwM e
|
||||
handler₀ (MissingImports [e]) =
|
||||
throwMissingImport (Imported (import_:imports) e)
|
||||
throwMissingImport (Imported imports' e)
|
||||
handler₀ (MissingImports es) = throwM
|
||||
(MissingImports
|
||||
(fmap
|
||||
(\e -> (toException (Imported (import_:imports) e)))
|
||||
(\e -> (toException (Imported imports' e)))
|
||||
es))
|
||||
handler₁
|
||||
:: (MonadCatch m)
|
||||
=> SomeException
|
||||
-> StateT Status m (Expr Src Import)
|
||||
handler₁ e =
|
||||
throwMissingImport (Imported (import_:imports) e)
|
||||
throwMissingImport (Imported imports' e)
|
||||
|
||||
-- This loads a \"dynamic\" expression (i.e. an expression
|
||||
-- that might still contain imports)
|
||||
let loadDynamic =
|
||||
from_import (canonicalizeImport (import_:imports))
|
||||
from_import here
|
||||
|
||||
expr' <- loadDynamic `catches` [ Handler handler₀, Handler handler₁ ]
|
||||
|
||||
let imports' = import_:imports
|
||||
zoom stack (State.put imports')
|
||||
expr'' <- loadStaticWith from_import ctx n expr'
|
||||
zoom stack (State.put imports)
|
||||
|
|
@ -637,7 +652,7 @@ loadStaticWith from_import ctx n expr₀ = case expr₀ of
|
|||
-- There is no need to check expressions that have been
|
||||
-- cached, since they have already been checked
|
||||
expr''' <- case Dhall.TypeCheck.typeWith ctx expr'' of
|
||||
Left err -> throwM (Imported (import_:imports) err)
|
||||
Left err -> throwM (Imported imports' err)
|
||||
Right _ -> return (Dhall.Core.normalizeWith n expr'')
|
||||
zoom cache (State.put $! Map.insert here expr''' m)
|
||||
return expr'''
|
||||
|
|
@ -649,7 +664,7 @@ loadStaticWith from_import ctx n expr₀ = case expr₀ of
|
|||
let actualHash = hashExpression expr
|
||||
if expectedHash == actualHash
|
||||
then return ()
|
||||
else throwMissingImport (Imported (import_:imports) (HashMismatch {..}))
|
||||
else throwMissingImport (Imported imports' (HashMismatch {..}))
|
||||
|
||||
return expr
|
||||
ImportAlt a b -> loop a `catch` handler₀
|
||||
|
|
|
|||
|
|
@ -1,23 +1,30 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -Wall #-}
|
||||
|
||||
module Dhall.Import.Types where
|
||||
|
||||
import Control.Exception (Exception)
|
||||
import Data.Dynamic
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Map (Map)
|
||||
import Data.Semigroup ((<>))
|
||||
import Lens.Family (LensLike')
|
||||
import System.FilePath (isRelative, splitDirectories)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text
|
||||
|
||||
import Dhall.Core (Import, Expr)
|
||||
import Dhall.Core
|
||||
( Directory (..), Expr, File (..), FilePrefix (..), Import (..)
|
||||
, ImportHashed (..), ImportMode (..), ImportType (..)
|
||||
)
|
||||
import Dhall.Parser (Src)
|
||||
import Dhall.TypeCheck (X)
|
||||
|
||||
|
||||
-- | State threaded throughout the import process
|
||||
data Status = Status
|
||||
{ _stack :: [Import]
|
||||
{ _stack :: NonEmpty Import
|
||||
-- ^ Stack of `Import`s that we've imported along the way to get to the
|
||||
-- current point
|
||||
, _cache :: Map Import (Expr Src X)
|
||||
|
|
@ -27,11 +34,26 @@ data Status = Status
|
|||
-- ^ Cache for the HTTP `Manager` so that we only acquire it once
|
||||
}
|
||||
|
||||
-- | Default starting `Status`
|
||||
emptyStatus :: Status
|
||||
emptyStatus = Status [] Map.empty Nothing
|
||||
-- | Default starting `Status`, importing relative to the given directory.
|
||||
emptyStatus :: FilePath -> Status
|
||||
emptyStatus dir = Status (pure rootImport) Map.empty Nothing
|
||||
where
|
||||
prefix = if isRelative dir
|
||||
then Here
|
||||
else Absolute
|
||||
pathComponents = fmap Data.Text.pack (reverse (splitDirectories dir))
|
||||
dirAsFile = File (Directory pathComponents) "."
|
||||
-- Fake import to set the directory we're relative to.
|
||||
rootImport = Import
|
||||
{ importHashed = ImportHashed
|
||||
{ hash = Nothing
|
||||
, importType = Local prefix dirAsFile
|
||||
}
|
||||
, importMode = Code
|
||||
}
|
||||
|
||||
stack :: Functor f => LensLike' f Status [Import]
|
||||
|
||||
stack :: Functor f => LensLike' f Status (NonEmpty Import)
|
||||
stack k s = fmap (\x -> s { _stack = x }) (k (_stack s))
|
||||
|
||||
cache :: Functor f => LensLike' f Status (Map Import (Expr Src X))
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@ import Data.Monoid ((<>))
|
|||
|
||||
import qualified Data.Text
|
||||
import qualified Data.Text.IO
|
||||
import qualified Dhall.Context
|
||||
import qualified Dhall.Parser
|
||||
import qualified Dhall.Import
|
||||
import qualified Test.Tasty
|
||||
|
|
@ -41,6 +42,12 @@ importTests =
|
|||
"alternative of a Natural and missing"
|
||||
"./tests/import/alternativeNatural.dhall"
|
||||
]
|
||||
, Test.Tasty.testGroup "import relative to argument"
|
||||
[ shouldNotFailRelative
|
||||
"works"
|
||||
"./tests/import/data/foo/bar"
|
||||
"./tests/import/relative.dhall"
|
||||
]
|
||||
]
|
||||
|
||||
shouldNotFail :: Text -> FilePath -> TestTree
|
||||
|
|
@ -52,6 +59,15 @@ shouldNotFail name path = Test.Tasty.HUnit.testCase (Data.Text.unpack name) (do
|
|||
_ <- Dhall.Import.load actualExpr
|
||||
return ())
|
||||
|
||||
shouldNotFailRelative :: Text -> FilePath -> FilePath -> TestTree
|
||||
shouldNotFailRelative name dir path = Test.Tasty.HUnit.testCase (Data.Text.unpack name) (do
|
||||
text <- Data.Text.IO.readFile path
|
||||
expr <- case Dhall.Parser.exprFromText mempty text of
|
||||
Left err -> throwIO err
|
||||
Right expr -> return expr
|
||||
_ <- Dhall.Import.loadDirWith dir Dhall.Import.exprFromImport Dhall.Context.empty (const Nothing) expr
|
||||
return ())
|
||||
|
||||
shouldFail :: Int -> Text -> FilePath -> TestTree
|
||||
shouldFail failures name path = Test.Tasty.HUnit.testCase (Data.Text.unpack name) (do
|
||||
text <- Data.Text.IO.readFile path
|
||||
|
|
|
|||
1
tests/import/data/foo/bar/a.dhall
Normal file
1
tests/import/data/foo/bar/a.dhall
Normal file
|
|
@ -0,0 +1 @@
|
|||
42
|
||||
2
tests/import/relative.dhall
Normal file
2
tests/import/relative.dhall
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
-- This file assumes its base directory is actually ./data/foo/bar/
|
||||
./a.dhall : Natural
|
||||
Loading…
Reference in New Issue
Block a user