Add various functions explicitly taking a root directory.

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.

src/Dhall/Import.hs

@@ -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 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 using a custom typing context.
+-- | 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₀

src/Dhall/Import/Types.hs

@@ -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
-
-stack :: Functor f => LensLike' f Status [Import]
+-- | 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 (NonEmpty Import)
 stack k s = fmap (\x -> s { _stack = x }) (k (_stack s))
 
 cache :: Functor f => LensLike' f Status (Map Import (Expr Src X))