{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wall #-}
module Dhall.Import (
load
, loadWithManager
, loadRelativeTo
, loadWithStatus
, loadWith
, localToPath
, hashExpression
, hashExpressionToCode
, writeExpressionToSemanticCache
, assertNoImports
, Manager
, defaultNewManager
, CacheWarning(..)
, Status(..)
, SemanticCacheMode(..)
, Chained
, chainedImport
, chainedFromLocalHere
, chainedChangeMode
, emptyStatus
, emptyStatusWithManager
, envOriginHeaders
, makeEmptyStatus
, remoteStatus
, remoteStatusWithManager
, fetchRemote
, stack
, cache
, Depends(..)
, graph
, remote
, toHeaders
, substitutions
, normalizer
, startingContext
, chainImport
, dependencyToFile
, ImportSemantics
, HTTPHeader
, Cycle(..)
, ReferentiallyOpaque(..)
, Imported(..)
, ImportResolutionDisabled(..)
, PrettyHttpException(..)
, MissingFile(..)
, MissingEnvironmentVariable(..)
, MissingImports(..)
, HashMismatch(..)
) where
import Control.Applicative (Alternative (..))
import Control.Exception
( Exception
, IOException
, SomeException
, toException
)
import Control.Monad.Catch (MonadCatch (catch), handle, throwM)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Morph (hoist)
import Control.Monad.State.Strict (MonadState, StateT)
import Data.ByteString (ByteString)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Data.Void (Void, absurd)
import Dhall.TypeCheck (TypeError)
import Dhall.Syntax
( Chunks (..)
, Directory (..)
, Expr (..)
, File (..)
, FilePrefix (..)
, Import (..)
, ImportHashed (..)
, ImportMode (..)
, ImportType (..)
, URL (..)
, bindingExprs
, functionBindingExprs
, recordFieldExprs
)
import System.FilePath ((</>))
import Text.Megaparsec (SourcePos (SourcePos), mkPos)
#ifdef WITH_HTTP
import Dhall.Import.HTTP
#endif
import Dhall.Import.Headers
( normalizeHeaders
, originHeadersTypeExpr
, toHeaders
, toOriginHeaders
)
import Dhall.Import.Types
import Dhall.Parser
( ParseError (..)
, Parser (..)
, SourcedException (..)
, Src (..)
)
import Lens.Family.State.Strict (zoom)
import qualified Codec.CBOR.Write as Write
import qualified Codec.Serialise
import qualified Control.Exception as Exception
import qualified Control.Monad.State.Strict as State
import qualified Control.Monad.Trans.Maybe as Maybe
import qualified Data.ByteString
import qualified Data.ByteString.Lazy
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Encoding
import qualified Data.Text.IO
import qualified Dhall.Binary
import qualified Dhall.Core as Core
import qualified Dhall.Crypto
import qualified Dhall.Map
import qualified Dhall.Parser
import qualified Dhall.Pretty.Internal
import qualified Dhall.Substitution
import qualified Dhall.Syntax as Syntax
import qualified Dhall.TypeCheck
import qualified System.AtomicWrite.Writer.ByteString.Binary as AtomicWrite.Binary
import qualified System.Directory as Directory
import qualified System.Environment
import qualified System.FilePath as FilePath
import qualified System.Info
import qualified System.IO
import qualified Text.Megaparsec
import qualified Text.Parser.Combinators
import qualified Text.Parser.Token
newtype Cycle = Cycle
{ Cycle -> Import
cyclicImport :: Import
}
deriving (Typeable)
instance Exception Cycle
instance Show Cycle where
show :: Cycle -> String
show (Cycle Import
import_) =
String
"\nCyclic import: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
Dhall.Pretty.Internal.prettyToString Import
import_
newtype ReferentiallyOpaque = ReferentiallyOpaque
{ ReferentiallyOpaque -> Import
opaqueImport :: Import
} deriving (Typeable)
instance Exception ReferentiallyOpaque
instance Show ReferentiallyOpaque where
show :: ReferentiallyOpaque -> String
show (ReferentiallyOpaque Import
import_) =
String
"\nLocal imports are not permitted from remote imports: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
Dhall.Pretty.Internal.prettyToString Import
import_
data Imported e = Imported
{ forall e. Imported e -> NonEmpty Chained
importStack :: NonEmpty Chained
, forall e. Imported e -> e
nested :: e
} deriving (Typeable)
instance Exception e => Exception (Imported e)
instance Show e => Show (Imported e) where
show :: Imported e -> String
show (Imported NonEmpty Chained
canonicalizedImports e
e) =
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a}. Pretty a => Int -> a -> String
indent [Int
0..] [Chained]
toDisplay)
forall a. [a] -> [a] -> [a]
++ String
"\n"
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show e
e
where
indent :: Int -> a -> String
indent Int
n a
import_ =
String
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
2 forall a. Num a => a -> a -> a
* Int
n) Char
' ' forall a. [a] -> [a] -> [a]
++ String
"↳ " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
Dhall.Pretty.Internal.prettyToString a
import_
canonical :: [Chained]
canonical = forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Chained
canonicalizedImports
toDisplay :: [Chained]
toDisplay = forall a. Int -> [a] -> [a]
drop Int
1 (forall a. [a] -> [a]
reverse [Chained]
canonical)
newtype MissingFile = MissingFile FilePath
deriving (Typeable)
instance Exception MissingFile
instance Show MissingFile where
show :: MissingFile -> String
show (MissingFile String
path) =
String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;31mError\ESC[0m: Missing file "
forall a. Semigroup a => a -> a -> a
<> String
path
newtype MissingEnvironmentVariable = MissingEnvironmentVariable { MissingEnvironmentVariable -> Text
name :: Text }
deriving (Typeable)
instance Exception MissingEnvironmentVariable
instance Show MissingEnvironmentVariable where
show :: MissingEnvironmentVariable -> String
show MissingEnvironmentVariable{Text
name :: Text
name :: MissingEnvironmentVariable -> Text
..} =
String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;31mError\ESC[0m: Missing environment variable\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"↳ " forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
name
newtype MissingImports = MissingImports [SomeException]
instance Exception MissingImports
instance Show MissingImports where
show :: MissingImports -> String
show (MissingImports []) =
String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;31mError\ESC[0m: No valid imports"
show (MissingImports [SomeException
e]) = forall a. Show a => a -> String
show SomeException
e
show (MissingImports [SomeException]
es) =
String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;31mError\ESC[0m: Failed to resolve imports. Error list:"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\SomeException
e -> String
"\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SomeException
e forall a. Semigroup a => a -> a -> a
<> String
"\n") [SomeException]
es
throwMissingImport :: (MonadCatch m, Exception e) => e -> m a
throwMissingImport :: forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport e
e = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([SomeException] -> MissingImports
MissingImports [forall e. Exception e => e -> SomeException
toException e
e])
data CannotImportHTTPURL =
CannotImportHTTPURL
String
(Maybe [HTTPHeader])
deriving (Typeable)
instance Exception CannotImportHTTPURL
instance Show CannotImportHTTPURL where
show :: CannotImportHTTPURL -> String
show (CannotImportHTTPURL String
url Maybe [HTTPHeader]
_mheaders) =
String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;31mError\ESC[0m: Cannot import HTTP URL.\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"Dhall was compiled without the 'with-http' flag.\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"The requested URL was: "
forall a. Semigroup a => a -> a -> a
<> String
url
forall a. Semigroup a => a -> a -> a
<> String
"\n"
class Semigroup path => Canonicalize path where
canonicalize :: path -> path
instance Canonicalize Directory where
canonicalize :: Directory -> Directory
canonicalize (Directory []) = [Text] -> Directory
Directory []
canonicalize (Directory (Text
"." : [Text]
components₀)) =
forall path. Canonicalize path => path -> path
canonicalize ([Text] -> Directory
Directory [Text]
components₀)
canonicalize (Directory (Text
".." : [Text]
components₀)) =
case forall path. Canonicalize path => path -> path
canonicalize ([Text] -> Directory
Directory [Text]
components₀) of
Directory [] ->
[Text] -> Directory
Directory [ Text
".." ]
Directory (Text
".." : [Text]
components₁) ->
[Text] -> Directory
Directory (Text
".." forall a. a -> [a] -> [a]
: Text
".." forall a. a -> [a] -> [a]
: [Text]
components₁)
Directory (Text
_ : [Text]
components₁) ->
[Text] -> Directory
Directory [Text]
components₁
canonicalize (Directory (Text
component : [Text]
components₀)) =
[Text] -> Directory
Directory (Text
component forall a. a -> [a] -> [a]
: [Text]
components₁)
where
Directory [Text]
components₁ = forall path. Canonicalize path => path -> path
canonicalize ([Text] -> Directory
Directory [Text]
components₀)
instance Canonicalize File where
canonicalize :: File -> File
canonicalize (File { Directory
directory :: File -> Directory
directory :: Directory
directory, Text
file :: File -> Text
file :: Text
.. }) =
File { directory :: Directory
directory = forall path. Canonicalize path => path -> path
canonicalize Directory
directory, Text
file :: Text
file :: Text
.. }
instance Canonicalize ImportType where
canonicalize :: ImportType -> ImportType
canonicalize (Local FilePrefix
prefix File
file) =
FilePrefix -> File -> ImportType
Local FilePrefix
prefix (forall path. Canonicalize path => path -> path
canonicalize File
file)
canonicalize (Remote (URL {Maybe Text
Maybe (Expr Src Import)
Text
Scheme
File
headers :: URL -> Maybe (Expr Src Import)
query :: URL -> Maybe Text
path :: URL -> File
authority :: URL -> Text
scheme :: URL -> Scheme
headers :: Maybe (Expr Src Import)
query :: Maybe Text
path :: File
authority :: Text
scheme :: Scheme
..})) =
URL -> ImportType
Remote (URL { path :: File
path = forall path. Canonicalize path => path -> path
canonicalize File
path, headers :: Maybe (Expr Src Import)
headers = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall path. Canonicalize path => path -> path
canonicalize) Maybe (Expr Src Import)
headers, Maybe Text
Text
Scheme
query :: Maybe Text
authority :: Text
scheme :: Scheme
query :: Maybe Text
authority :: Text
scheme :: Scheme
..})
canonicalize (Env Text
name) =
Text -> ImportType
Env Text
name
canonicalize ImportType
Missing =
ImportType
Missing
instance Canonicalize ImportHashed where
canonicalize :: ImportHashed -> ImportHashed
canonicalize (ImportHashed Maybe SHA256Digest
hash ImportType
importType) =
Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed Maybe SHA256Digest
hash (forall path. Canonicalize path => path -> path
canonicalize ImportType
importType)
instance Canonicalize Import where
canonicalize :: Import -> Import
canonicalize (Import ImportHashed
importHashed ImportMode
importMode) =
ImportHashed -> ImportMode -> Import
Import (forall path. Canonicalize path => path -> path
canonicalize ImportHashed
importHashed) ImportMode
importMode
data HashMismatch = HashMismatch
{ HashMismatch -> SHA256Digest
expectedHash :: Dhall.Crypto.SHA256Digest
, HashMismatch -> SHA256Digest
actualHash :: Dhall.Crypto.SHA256Digest
} deriving (Typeable)
instance Exception HashMismatch
instance Show HashMismatch where
show :: HashMismatch -> String
show HashMismatch{SHA256Digest
actualHash :: SHA256Digest
expectedHash :: SHA256Digest
actualHash :: HashMismatch -> SHA256Digest
expectedHash :: HashMismatch -> SHA256Digest
..} =
String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;31mError\ESC[0m: " forall a. Semigroup a => a -> a -> a
<> SHA256Digest -> SHA256Digest -> String
makeHashMismatchMessage SHA256Digest
expectedHash SHA256Digest
actualHash
makeHashMismatchMessage :: Dhall.Crypto.SHA256Digest -> Dhall.Crypto.SHA256Digest -> String
makeHashMismatchMessage :: SHA256Digest -> SHA256Digest -> String
makeHashMismatchMessage SHA256Digest
expectedHash SHA256Digest
actualHash =
String
"Import integrity check failed\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"Expected hash:\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"↳ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SHA256Digest
expectedHash forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"Actual hash:\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"↳ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SHA256Digest
actualHash forall a. Semigroup a => a -> a -> a
<> String
"\n"
localToPath :: MonadIO io => FilePrefix -> File -> io FilePath
localToPath :: forall (io :: * -> *).
MonadIO io =>
FilePrefix -> File -> io String
localToPath FilePrefix
prefix File
file_ = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let File {Text
Directory
file :: Text
directory :: Directory
file :: File -> Text
directory :: File -> Directory
..} = File
file_
let Directory {[Text]
components :: Directory -> [Text]
components :: [Text]
..} = Directory
directory
String
prefixPath <- case FilePrefix
prefix of
FilePrefix
Home ->
IO String
Directory.getHomeDirectory
FilePrefix
Absolute ->
forall (m :: * -> *) a. Monad m => a -> m a
return String
"/"
FilePrefix
Parent ->
forall (m :: * -> *) a. Monad m => a -> m a
return String
".."
FilePrefix
Here ->
forall (m :: * -> *) a. Monad m => a -> m a
return String
"."
let cs :: [String]
cs = forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Text.unpack (Text
file forall a. a -> [a] -> [a]
: [Text]
components)
let cons :: String -> ShowS
cons String
component String
dir = String
dir String -> ShowS
</> String
component
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> ShowS
cons String
prefixPath [String]
cs)
chainedFromLocalHere :: FilePrefix -> File -> ImportMode -> Chained
chainedFromLocalHere :: FilePrefix -> File -> ImportMode -> Chained
chainedFromLocalHere FilePrefix
prefix File
file ImportMode
mode = Import -> Chained
Chained forall a b. (a -> b) -> a -> b
$
ImportHashed -> ImportMode -> Import
Import (Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed forall a. Maybe a
Nothing (FilePrefix -> File -> ImportType
Local FilePrefix
prefix (forall path. Canonicalize path => path -> path
canonicalize File
file))) ImportMode
mode
chainedChangeMode :: ImportMode -> Chained -> Chained
chainedChangeMode :: ImportMode -> Chained -> Chained
chainedChangeMode ImportMode
mode (Chained (Import ImportHashed
importHashed ImportMode
_)) =
Import -> Chained
Chained (ImportHashed -> ImportMode -> Import
Import ImportHashed
importHashed ImportMode
mode)
chainImport :: Chained -> Import -> StateT Status IO Chained
chainImport :: Chained -> Import -> StateT Status IO Chained
chainImport (Chained Import
parent) child :: Import
child@(Import importHashed :: ImportHashed
importHashed@(ImportHashed Maybe SHA256Digest
_ (Remote URL
url)) ImportMode
_) = do
URL
url' <- URL -> StateT Status IO URL
normalizeHeadersIn URL
url
let child' :: Import
child' = Import
child { importHashed :: ImportHashed
importHashed = ImportHashed
importHashed { importType :: ImportType
importType = URL -> ImportType
Remote URL
url' } }
forall (m :: * -> *) a. Monad m => a -> m a
return (Import -> Chained
Chained (forall path. Canonicalize path => path -> path
canonicalize (Import
parent forall a. Semigroup a => a -> a -> a
<> Import
child')))
chainImport (Chained Import
parent) Import
child =
forall (m :: * -> *) a. Monad m => a -> m a
return (Import -> Chained
Chained (forall path. Canonicalize path => path -> path
canonicalize (Import
parent forall a. Semigroup a => a -> a -> a
<> Import
child)))
loadImport :: Chained -> StateT Status IO ImportSemantics
loadImport :: Chained -> StateT Status IO ImportSemantics
loadImport Chained
import_ = do
Status {[Depends]
Maybe Manager
Maybe (ReifiedNormalizer Void)
IO Manager
NonEmpty Chained
StateT Status IO OriginHeaders
Context (Expr Src Void)
Substitutions Src Void
Map Chained ImportSemantics
CacheWarning
SemanticCacheMode
URL -> StateT Status IO ByteString
URL -> StateT Status IO Text
_cacheWarning :: Status -> CacheWarning
_semanticCacheMode :: Status -> SemanticCacheMode
_startingContext :: Status -> Context (Expr Src Void)
_normalizer :: Status -> Maybe (ReifiedNormalizer Void)
_substitutions :: Status -> Substitutions Src Void
_remoteBytes :: Status -> URL -> StateT Status IO ByteString
_remote :: Status -> URL -> StateT Status IO Text
_loadOriginHeaders :: Status -> StateT Status IO OriginHeaders
_manager :: Status -> Maybe Manager
_newManager :: Status -> IO Manager
_cache :: Status -> Map Chained ImportSemantics
_graph :: Status -> [Depends]
_stack :: Status -> NonEmpty Chained
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remoteBytes :: URL -> StateT Status IO ByteString
_remote :: URL -> StateT Status IO Text
_loadOriginHeaders :: StateT Status IO OriginHeaders
_manager :: Maybe Manager
_newManager :: IO Manager
_cache :: Map Chained ImportSemantics
_graph :: [Depends]
_stack :: NonEmpty Chained
..} <- forall s (m :: * -> *). MonadState s m => m s
State.get
case forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Chained
import_ Map Chained ImportSemantics
_cache of
Just ImportSemantics
importSemantics -> forall (m :: * -> *) a. Monad m => a -> m a
return ImportSemantics
importSemantics
Maybe ImportSemantics
Nothing -> do
ImportSemantics
importSemantics <- Chained -> StateT Status IO ImportSemantics
loadImportWithSemanticCache Chained
import_
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom forall (f :: * -> *).
Functor f =>
LensLike' f Status (Map Chained ImportSemantics)
cache (forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (forall k v. Ord k => k -> v -> Map k v -> Map k v
Dhall.Map.insert Chained
import_ ImportSemantics
importSemantics))
forall (m :: * -> *) a. Monad m => a -> m a
return ImportSemantics
importSemantics
loadImportWithSemanticCache :: Chained -> StateT Status IO ImportSemantics
loadImportWithSemanticCache :: Chained -> StateT Status IO ImportSemantics
loadImportWithSemanticCache
import_ :: Chained
import_@(Chained (Import (ImportHashed Maybe SHA256Digest
Nothing ImportType
_) ImportMode
_)) =
Chained -> StateT Status IO ImportSemantics
loadImportWithSemisemanticCache Chained
import_
loadImportWithSemanticCache
import_ :: Chained
import_@(Chained (Import ImportHashed
_ ImportMode
Location)) =
Chained -> StateT Status IO ImportSemantics
loadImportWithSemisemanticCache Chained
import_
loadImportWithSemanticCache
import_ :: Chained
import_@(Chained (Import (ImportHashed (Just SHA256Digest
semanticHash) ImportType
_) ImportMode
_)) = do
Status { [Depends]
Maybe Manager
Maybe (ReifiedNormalizer Void)
IO Manager
NonEmpty Chained
StateT Status IO OriginHeaders
Context (Expr Src Void)
Substitutions Src Void
Map Chained ImportSemantics
CacheWarning
SemanticCacheMode
URL -> StateT Status IO ByteString
URL -> StateT Status IO Text
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remoteBytes :: URL -> StateT Status IO ByteString
_remote :: URL -> StateT Status IO Text
_loadOriginHeaders :: StateT Status IO OriginHeaders
_manager :: Maybe Manager
_newManager :: IO Manager
_cache :: Map Chained ImportSemantics
_graph :: [Depends]
_stack :: NonEmpty Chained
_cacheWarning :: Status -> CacheWarning
_semanticCacheMode :: Status -> SemanticCacheMode
_startingContext :: Status -> Context (Expr Src Void)
_normalizer :: Status -> Maybe (ReifiedNormalizer Void)
_substitutions :: Status -> Substitutions Src Void
_remoteBytes :: Status -> URL -> StateT Status IO ByteString
_remote :: Status -> URL -> StateT Status IO Text
_loadOriginHeaders :: Status -> StateT Status IO OriginHeaders
_manager :: Status -> Maybe Manager
_newManager :: Status -> IO Manager
_cache :: Status -> Map Chained ImportSemantics
_graph :: Status -> [Depends]
_stack :: Status -> NonEmpty Chained
.. } <- forall s (m :: * -> *). MonadState s m => m s
State.get
Maybe ByteString
mCached <-
case SemanticCacheMode
_semanticCacheMode of
SemanticCacheMode
UseSemanticCache ->
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom forall (f :: * -> *). Functor f => LensLike' f Status CacheWarning
cacheWarning (forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> m (Maybe ByteString)
fetchFromSemanticCache SHA256Digest
semanticHash)
SemanticCacheMode
IgnoreSemanticCache ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
case Maybe ByteString
mCached of
Just ByteString
bytesStrict -> do
let actualHash :: SHA256Digest
actualHash = ByteString -> SHA256Digest
Dhall.Crypto.sha256Hash ByteString
bytesStrict
if SHA256Digest
semanticHash forall a. Eq a => a -> a -> Bool
== SHA256Digest
actualHash
then do
let bytesLazy :: ByteString
bytesLazy = ByteString -> ByteString
Data.ByteString.Lazy.fromStrict ByteString
bytesStrict
Expr Void Void
importSemantics <- case forall s a.
Serialise (Expr s a) =>
ByteString -> Either DecodingFailure (Expr s a)
Dhall.Binary.decodeExpression ByteString
bytesLazy of
Left DecodingFailure
err -> forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack DecodingFailure
err)
Right Expr Void Void
e -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr Void Void
e
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportSemantics {Expr Void Void
importSemantics :: Expr Void Void
importSemantics :: Expr Void Void
..})
else do
forall (m :: * -> *). MonadIO m => String -> m ()
printWarning forall a b. (a -> b) -> a -> b
$
SHA256Digest -> SHA256Digest -> String
makeHashMismatchMessage SHA256Digest
semanticHash SHA256Digest
actualHash
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"The interpreter will attempt to fix the cached import\n"
StateT Status IO ImportSemantics
fetch
Maybe ByteString
Nothing -> StateT Status IO ImportSemantics
fetch
where
fetch :: StateT Status IO ImportSemantics
fetch = do
ImportSemantics{ Expr Void Void
importSemantics :: Expr Void Void
importSemantics :: ImportSemantics -> Expr Void Void
importSemantics } <- Chained -> StateT Status IO ImportSemantics
loadImportWithSemisemanticCache Chained
import_
let bytes :: ByteString
bytes = Expr Void Void -> ByteString
encodeExpression (forall s a. Expr s a -> Expr s a
Core.alphaNormalize Expr Void Void
importSemantics)
let actualHash :: SHA256Digest
actualHash = ByteString -> SHA256Digest
Dhall.Crypto.sha256Hash ByteString
bytes
let expectedHash :: SHA256Digest
expectedHash = SHA256Digest
semanticHash
if SHA256Digest
actualHash forall a. Eq a => a -> a -> Bool
== SHA256Digest
expectedHash
then do
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom forall (f :: * -> *). Functor f => LensLike' f Status CacheWarning
cacheWarning (forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> ByteString -> m ()
writeToSemanticCache SHA256Digest
semanticHash ByteString
bytes)
else do
Status{ NonEmpty Chained
_stack :: NonEmpty Chained
_stack :: Status -> NonEmpty Chained
_stack } <- forall s (m :: * -> *). MonadState s m => m s
State.get
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack HashMismatch{SHA256Digest
expectedHash :: SHA256Digest
actualHash :: SHA256Digest
actualHash :: SHA256Digest
expectedHash :: SHA256Digest
..})
forall (m :: * -> *) a. Monad m => a -> m a
return ImportSemantics{Expr Void Void
importSemantics :: Expr Void Void
importSemantics :: Expr Void Void
..}
fetchFromSemanticCache
:: (MonadState CacheWarning m, MonadCatch m, MonadIO m)
=> Dhall.Crypto.SHA256Digest
-> m (Maybe Data.ByteString.ByteString)
fetchFromSemanticCache :: forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> m (Maybe ByteString)
fetchFromSemanticCache SHA256Digest
expectedHash = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Maybe.runMaybeT forall a b. (a -> b) -> a -> b
$ do
String
cacheFile <- forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
MonadIO m) =>
String -> SHA256Digest -> m String
getCacheFile String
"dhall" SHA256Digest
expectedHash
Bool
True <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
Directory.doesFileExist String
cacheFile)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
Data.ByteString.readFile String
cacheFile)
writeExpressionToSemanticCache :: Expr Void Void -> IO ()
writeExpressionToSemanticCache :: Expr Void Void -> IO ()
writeExpressionToSemanticCache Expr Void Void
expression =
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT (forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> ByteString -> m ()
writeToSemanticCache SHA256Digest
hash ByteString
bytes) CacheWarning
CacheWarned
where
bytes :: ByteString
bytes = Expr Void Void -> ByteString
encodeExpression Expr Void Void
expression
hash :: SHA256Digest
hash = ByteString -> SHA256Digest
Dhall.Crypto.sha256Hash ByteString
bytes
writeToSemanticCache
:: (MonadState CacheWarning m, MonadCatch m, MonadIO m)
=> Dhall.Crypto.SHA256Digest
-> Data.ByteString.ByteString
-> m ()
writeToSemanticCache :: forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> ByteString -> m ()
writeToSemanticCache SHA256Digest
hash ByteString
bytes = do
Maybe ()
_ <- forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Maybe.runMaybeT forall a b. (a -> b) -> a -> b
$ do
String
cacheFile <- forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
MonadIO m) =>
String -> SHA256Digest -> m String
getCacheFile String
"dhall" SHA256Digest
hash
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> ByteString -> IO ()
AtomicWrite.Binary.atomicWriteFile String
cacheFile ByteString
bytes)
forall (m :: * -> *) a. Monad m => a -> m a
return ()
loadImportWithSemisemanticCache
:: Chained -> StateT Status IO ImportSemantics
loadImportWithSemisemanticCache :: Chained -> StateT Status IO ImportSemantics
loadImportWithSemisemanticCache (Chained (Import (ImportHashed Maybe SHA256Digest
_ ImportType
importType) ImportMode
Code)) = do
Text
text <- ImportType -> StateT Status IO Text
fetchFresh ImportType
importType
Status {[Depends]
Maybe Manager
Maybe (ReifiedNormalizer Void)
IO Manager
NonEmpty Chained
StateT Status IO OriginHeaders
Context (Expr Src Void)
Substitutions Src Void
Map Chained ImportSemantics
CacheWarning
SemanticCacheMode
URL -> StateT Status IO ByteString
URL -> StateT Status IO Text
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remoteBytes :: URL -> StateT Status IO ByteString
_remote :: URL -> StateT Status IO Text
_loadOriginHeaders :: StateT Status IO OriginHeaders
_manager :: Maybe Manager
_newManager :: IO Manager
_cache :: Map Chained ImportSemantics
_graph :: [Depends]
_stack :: NonEmpty Chained
_cacheWarning :: Status -> CacheWarning
_semanticCacheMode :: Status -> SemanticCacheMode
_startingContext :: Status -> Context (Expr Src Void)
_normalizer :: Status -> Maybe (ReifiedNormalizer Void)
_substitutions :: Status -> Substitutions Src Void
_remoteBytes :: Status -> URL -> StateT Status IO ByteString
_remote :: Status -> URL -> StateT Status IO Text
_loadOriginHeaders :: Status -> StateT Status IO OriginHeaders
_manager :: Status -> Maybe Manager
_newManager :: Status -> IO Manager
_cache :: Status -> Map Chained ImportSemantics
_graph :: Status -> [Depends]
_stack :: Status -> NonEmpty Chained
..} <- forall s (m :: * -> *). MonadState s m => m s
State.get
String
path <- case ImportType
importType of
Local FilePrefix
prefix File
file -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
String
path <- forall (io :: * -> *).
MonadIO io =>
FilePrefix -> File -> io String
localToPath FilePrefix
prefix File
file
String
absolutePath <- String -> IO String
Directory.makeAbsolute String
path
forall (m :: * -> *) a. Monad m => a -> m a
return String
absolutePath
Remote URL
url -> do
let urlText :: Text
urlText = forall a. Pretty a => a -> Text
Core.pretty (URL
url { headers :: Maybe (Expr Src Import)
headers = forall a. Maybe a
Nothing })
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> String
Text.unpack Text
urlText)
Env Text
env -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
env
ImportType
Missing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([SomeException] -> MissingImports
MissingImports [])
let parser :: Parsec Void Text (Expr Src Import)
parser = forall a. Parser a -> Parsec Void Text a
unParser forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). TokenParsing m => m ()
Text.Parser.Token.whiteSpace
Expr Src Import
r <- Parser (Expr Src Import)
Dhall.Parser.expr
forall (m :: * -> *). Parsing m => m ()
Text.Parser.Combinators.eof
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
r
Expr Src Import
parsedImport <- case forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Text.Megaparsec.parse Parsec Void Text (Expr Src Import)
parser String
path Text
text of
Left ParseErrorBundle Text Void
errInfo ->
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (ParseErrorBundle Text Void -> Text -> ParseError
ParseError ParseErrorBundle Text Void
errInfo Text
text))
Right Expr Src Import
expr -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
expr
Expr Src Void
resolvedExpr <- Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
parsedImport
let semisemanticHash :: SHA256Digest
semisemanticHash = Expr Void Void -> SHA256Digest
computeSemisemanticHash (forall s a t. Expr s a -> Expr t a
Core.denote Expr Src Void
resolvedExpr)
Maybe ByteString
mCached <- forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom forall (f :: * -> *). Functor f => LensLike' f Status CacheWarning
cacheWarning (forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> m (Maybe ByteString)
fetchFromSemisemanticCache SHA256Digest
semisemanticHash)
Expr Void Void
importSemantics <- case Maybe ByteString
mCached of
Just ByteString
bytesStrict -> do
let bytesLazy :: ByteString
bytesLazy = ByteString -> ByteString
Data.ByteString.Lazy.fromStrict ByteString
bytesStrict
Expr Void Void
importSemantics <- case forall s a.
Serialise (Expr s a) =>
ByteString -> Either DecodingFailure (Expr s a)
Dhall.Binary.decodeExpression ByteString
bytesLazy of
Left DecodingFailure
err -> forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack DecodingFailure
err)
Right Expr Void Void
sem -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr Void Void
sem
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Void Void
importSemantics
Maybe ByteString
Nothing -> do
let substitutedExpr :: Expr Src Void
substitutedExpr =
forall s a. Expr s a -> Substitutions s a -> Expr s a
Dhall.Substitution.substitute Expr Src Void
resolvedExpr Substitutions Src Void
_substitutions
case forall s a. Expr s a -> Expr s a
Core.shallowDenote Expr Src Import
parsedImport of
Embed Import
_ ->
forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a t. Expr s a -> Expr t a
Core.denote Expr Src Void
substitutedExpr)
Expr Src Import
_ -> do
case forall s.
Context (Expr s Void)
-> Expr s Void -> Either (TypeError s Void) (Expr s Void)
Dhall.TypeCheck.typeWith Context (Expr Src Void)
_startingContext Expr Src Void
substitutedExpr of
Left TypeError Src Void
err -> forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack TypeError Src Void
err)
Right Expr Src Void
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
let betaNormal :: Expr t Void
betaNormal =
forall a s t.
Eq a =>
Maybe (ReifiedNormalizer a) -> Expr s a -> Expr t a
Core.normalizeWith Maybe (ReifiedNormalizer Void)
_normalizer Expr Src Void
substitutedExpr
let bytes :: ByteString
bytes = Expr Void Void -> ByteString
encodeExpression forall {t}. Expr t Void
betaNormal
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom forall (f :: * -> *). Functor f => LensLike' f Status CacheWarning
cacheWarning (forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> ByteString -> m ()
writeToSemisemanticCache SHA256Digest
semisemanticHash ByteString
bytes)
forall (m :: * -> *) a. Monad m => a -> m a
return forall {t}. Expr t Void
betaNormal
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportSemantics {Expr Void Void
importSemantics :: Expr Void Void
importSemantics :: Expr Void Void
..})
loadImportWithSemisemanticCache (Chained (Import (ImportHashed Maybe SHA256Digest
_ ImportType
importType) ImportMode
RawText)) = do
Text
text <- ImportType -> StateT Status IO Text
fetchFresh ImportType
importType
let importSemantics :: Expr s a
importSemantics = forall s a. Chunks s a -> Expr s a
TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] Text
text)
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportSemantics {forall {s} {a}. Expr s a
importSemantics :: forall {s} {a}. Expr s a
importSemantics :: Expr Void Void
..})
loadImportWithSemisemanticCache (Chained (Import (ImportHashed Maybe SHA256Digest
_ ImportType
importType) ImportMode
RawBytes)) = do
ByteString
bytes <- ImportType -> StateT Status IO ByteString
fetchBytes ImportType
importType
let importSemantics :: Expr s a
importSemantics = forall s a. ByteString -> Expr s a
BytesLit ByteString
bytes
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportSemantics {forall {s} {a}. Expr s a
importSemantics :: forall {s} {a}. Expr s a
importSemantics :: Expr Void Void
..})
loadImportWithSemisemanticCache (Chained (Import (ImportHashed Maybe SHA256Digest
_ ImportType
importType) ImportMode
Location)) = do
let locationType :: Expr s a
locationType = forall s a. Map Text (Maybe (Expr s a)) -> Expr s a
Union forall a b. (a -> b) -> a -> b
$ forall k v. Ord k => [(k, v)] -> Map k v
Dhall.Map.fromList
[ (Text
"Environment", forall a. a -> Maybe a
Just forall {s} {a}. Expr s a
Text)
, (Text
"Remote", forall a. a -> Maybe a
Just forall {s} {a}. Expr s a
Text)
, (Text
"Local", forall a. a -> Maybe a
Just forall {s} {a}. Expr s a
Text)
, (Text
"Missing", forall a. Maybe a
Nothing)
]
let importSemantics :: Expr s a
importSemantics = case ImportType
importType of
ImportType
Missing -> forall s a. Expr s a -> FieldSelection s -> Expr s a
Field forall {s} {a}. Expr s a
locationType forall a b. (a -> b) -> a -> b
$ forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
"Missing"
local :: ImportType
local@(Local FilePrefix
_ File
_) ->
forall s a. Expr s a -> Expr s a -> Expr s a
App (forall s a. Expr s a -> FieldSelection s -> Expr s a
Field forall {s} {a}. Expr s a
locationType forall a b. (a -> b) -> a -> b
$ forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
"Local")
(forall s a. Chunks s a -> Expr s a
TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] (forall a. Pretty a => a -> Text
Core.pretty ImportType
local)))
remote_ :: ImportType
remote_@(Remote URL
_) ->
forall s a. Expr s a -> Expr s a -> Expr s a
App (forall s a. Expr s a -> FieldSelection s -> Expr s a
Field forall {s} {a}. Expr s a
locationType forall a b. (a -> b) -> a -> b
$ forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
"Remote")
(forall s a. Chunks s a -> Expr s a
TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] (forall a. Pretty a => a -> Text
Core.pretty ImportType
remote_)))
Env Text
env ->
forall s a. Expr s a -> Expr s a -> Expr s a
App (forall s a. Expr s a -> FieldSelection s -> Expr s a
Field forall {s} {a}. Expr s a
locationType forall a b. (a -> b) -> a -> b
$ forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
"Environment")
(forall s a. Chunks s a -> Expr s a
TextLit (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] (forall a. Pretty a => a -> Text
Core.pretty Text
env)))
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportSemantics {forall {s} {a}. Expr s a
importSemantics :: forall {s} {a}. Expr s a
importSemantics :: Expr Void Void
..})
computeSemisemanticHash :: Expr Void Void -> Dhall.Crypto.SHA256Digest
computeSemisemanticHash :: Expr Void Void -> SHA256Digest
computeSemisemanticHash Expr Void Void
resolvedExpr = Expr Void Void -> SHA256Digest
hashExpression Expr Void Void
resolvedExpr
fetchFromSemisemanticCache
:: (MonadState CacheWarning m, MonadCatch m, MonadIO m)
=> Dhall.Crypto.SHA256Digest
-> m (Maybe Data.ByteString.ByteString)
fetchFromSemisemanticCache :: forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> m (Maybe ByteString)
fetchFromSemisemanticCache SHA256Digest
semisemanticHash = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Maybe.runMaybeT forall a b. (a -> b) -> a -> b
$ do
String
cacheFile <- forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
MonadIO m) =>
String -> SHA256Digest -> m String
getCacheFile String
"dhall-haskell" SHA256Digest
semisemanticHash
Bool
True <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
Directory.doesFileExist String
cacheFile)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
Data.ByteString.readFile String
cacheFile)
writeToSemisemanticCache
:: (MonadState CacheWarning m, MonadCatch m, MonadIO m)
=> Dhall.Crypto.SHA256Digest
-> Data.ByteString.ByteString
-> m ()
writeToSemisemanticCache :: forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> ByteString -> m ()
writeToSemisemanticCache SHA256Digest
semisemanticHash ByteString
bytes = do
Maybe ()
_ <- forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Maybe.runMaybeT forall a b. (a -> b) -> a -> b
$ do
String
cacheFile <- forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
MonadIO m) =>
String -> SHA256Digest -> m String
getCacheFile String
"dhall-haskell" SHA256Digest
semisemanticHash
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> ByteString -> IO ()
AtomicWrite.Binary.atomicWriteFile String
cacheFile ByteString
bytes)
forall (m :: * -> *) a. Monad m => a -> m a
return ()
fetchFresh :: ImportType -> StateT Status IO Text
fetchFresh :: ImportType -> StateT Status IO Text
fetchFresh (Local FilePrefix
prefix File
file) = do
Status { NonEmpty Chained
_stack :: NonEmpty Chained
_stack :: Status -> NonEmpty Chained
_stack } <- forall s (m :: * -> *). MonadState s m => m s
State.get
String
path <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (io :: * -> *).
MonadIO io =>
FilePrefix -> File -> io String
localToPath FilePrefix
prefix File
file
Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
Directory.doesFileExist String
path
if Bool
exists
then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Text
Data.Text.IO.readFile String
path
else forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (String -> MissingFile
MissingFile String
path))
fetchFresh (Remote URL
url) = do
Status { URL -> StateT Status IO Text
_remote :: URL -> StateT Status IO Text
_remote :: Status -> URL -> StateT Status IO Text
_remote } <- forall s (m :: * -> *). MonadState s m => m s
State.get
URL -> StateT Status IO Text
_remote URL
url
fetchFresh (Env Text
env) = do
Status { NonEmpty Chained
_stack :: NonEmpty Chained
_stack :: Status -> NonEmpty Chained
_stack } <- forall s (m :: * -> *). MonadState s m => m s
State.get
Maybe String
x <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
System.Environment.lookupEnv (Text -> String
Text.unpack Text
env)
case Maybe String
x of
Just String
string ->
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
Text.pack String
string)
Maybe String
Nothing ->
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (Text -> MissingEnvironmentVariable
MissingEnvironmentVariable Text
env))
fetchFresh ImportType
Missing = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([SomeException] -> MissingImports
MissingImports [])
fetchBytes :: ImportType -> StateT Status IO ByteString
fetchBytes :: ImportType -> StateT Status IO ByteString
fetchBytes (Local FilePrefix
prefix File
file) = do
Status { NonEmpty Chained
_stack :: NonEmpty Chained
_stack :: Status -> NonEmpty Chained
_stack } <- forall s (m :: * -> *). MonadState s m => m s
State.get
String
path <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (io :: * -> *).
MonadIO io =>
FilePrefix -> File -> io String
localToPath FilePrefix
prefix File
file
Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
Directory.doesFileExist String
path
if Bool
exists
then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
Data.ByteString.readFile String
path
else forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (String -> MissingFile
MissingFile String
path))
fetchBytes (Remote URL
url) = do
Status { URL -> StateT Status IO ByteString
_remoteBytes :: URL -> StateT Status IO ByteString
_remoteBytes :: Status -> URL -> StateT Status IO ByteString
_remoteBytes } <- forall s (m :: * -> *). MonadState s m => m s
State.get
URL -> StateT Status IO ByteString
_remoteBytes URL
url
fetchBytes (Env Text
env) = do
Status { NonEmpty Chained
_stack :: NonEmpty Chained
_stack :: Status -> NonEmpty Chained
_stack } <- forall s (m :: * -> *). MonadState s m => m s
State.get
Maybe String
x <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
System.Environment.lookupEnv (Text -> String
Text.unpack Text
env)
case Maybe String
x of
Just String
string ->
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ByteString
Encoding.encodeUtf8 (String -> Text
Text.pack String
string))
Maybe String
Nothing ->
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (Text -> MissingEnvironmentVariable
MissingEnvironmentVariable Text
env))
fetchBytes ImportType
Missing = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([SomeException] -> MissingImports
MissingImports [])
fetchRemote :: URL -> StateT Status IO Data.Text.Text
#ifndef WITH_HTTP
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))
#else
fetchRemote :: URL -> StateT Status IO Text
fetchRemote URL
url = do
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom forall (f :: * -> *).
Functor f =>
LensLike' f Status (URL -> StateT Status IO Text)
remote (forall s (m :: * -> *). MonadState s m => s -> m ()
State.put URL -> StateT Status IO Text
fetchFromHTTP)
URL -> StateT Status IO Text
fetchFromHTTP URL
url
where
fetchFromHTTP :: URL -> StateT Status IO Data.Text.Text
fetchFromHTTP :: URL -> StateT Status IO Text
fetchFromHTTP (url' :: URL
url'@URL { headers :: URL -> Maybe (Expr Src Import)
headers = Maybe (Expr Src Import)
maybeHeadersExpression }) = do
let maybeHeaders :: Maybe [HTTPHeader]
maybeHeaders = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall s a. Expr s a -> [HTTPHeader]
toHeaders Maybe (Expr Src Import)
maybeHeadersExpression
URL -> Maybe [HTTPHeader] -> StateT Status IO Text
fetchFromHttpUrl URL
url' Maybe [HTTPHeader]
maybeHeaders
#endif
fetchRemoteBytes :: URL -> StateT Status IO Data.ByteString.ByteString
#ifndef WITH_HTTP
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))
#else
fetchRemoteBytes :: URL -> StateT Status IO ByteString
fetchRemoteBytes URL
url = do
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom forall (f :: * -> *).
Functor f =>
LensLike' f Status (URL -> StateT Status IO ByteString)
remoteBytes (forall s (m :: * -> *). MonadState s m => s -> m ()
State.put URL -> StateT Status IO ByteString
fetchFromHTTP)
URL -> StateT Status IO ByteString
fetchFromHTTP URL
url
where
fetchFromHTTP :: URL -> StateT Status IO Data.ByteString.ByteString
fetchFromHTTP :: URL -> StateT Status IO ByteString
fetchFromHTTP (url' :: URL
url'@URL { headers :: URL -> Maybe (Expr Src Import)
headers = Maybe (Expr Src Import)
maybeHeadersExpression }) = do
let maybeHeaders :: Maybe [HTTPHeader]
maybeHeaders = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall s a. Expr s a -> [HTTPHeader]
toHeaders Maybe (Expr Src Import)
maybeHeadersExpression
URL -> Maybe [HTTPHeader] -> StateT Status IO ByteString
fetchFromHttpUrlBytes URL
url' Maybe [HTTPHeader]
maybeHeaders
#endif
getCacheFile
:: (MonadCatch m, Alternative m, MonadState CacheWarning m, MonadIO m)
=> FilePath -> Dhall.Crypto.SHA256Digest -> m FilePath
getCacheFile :: forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
MonadIO m) =>
String -> SHA256Digest -> m String
getCacheFile String
cacheName SHA256Digest
hash = do
String
cacheDirectory <- forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
MonadIO m) =>
String -> m String
getOrCreateCacheDirectory String
cacheName
let cacheFile :: String
cacheFile = String
cacheDirectory String -> ShowS
</> (String
"1220" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SHA256Digest
hash)
forall (m :: * -> *) a. Monad m => a -> m a
return String
cacheFile
getOrCreateCacheDirectory
:: (MonadCatch m, Alternative m, MonadState CacheWarning m, MonadIO m)
=> FilePath -> m FilePath
getOrCreateCacheDirectory :: forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
MonadIO m) =>
String -> m String
getOrCreateCacheDirectory String
cacheName = do
let warn :: String -> m b
warn String
message = do
CacheWarning
cacheWarningStatus <- forall s (m :: * -> *). MonadState s m => m s
State.get
case CacheWarning
cacheWarningStatus of
CacheWarning
CacheWarned -> forall (m :: * -> *). MonadIO m => String -> m ()
printWarning String
message
CacheWarning
CacheNotWarned -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put CacheWarning
CacheWarned
forall (f :: * -> *) a. Alternative f => f a
empty
let handler :: String -> String -> IOException -> m b
handler String
action String
dir (IOException
ioex :: IOException) = do
let ioExMsg :: String
ioExMsg =
String
"When trying to " forall a. Semigroup a => a -> a -> a
<> String
action forall a. Semigroup a => a -> a -> a
<> String
":\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"↳ " forall a. Semigroup a => a -> a -> a
<> String
dir forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"... the following exception was thrown:\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"↳ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show IOException
ioex forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall {m :: * -> *} {b}.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> m b
warn String
ioExMsg
let setPermissions :: String -> m ()
setPermissions String
dir = do
let private :: Permissions
private = Permissions -> Permissions
transform Permissions
Directory.emptyPermissions
where
transform :: Permissions -> Permissions
transform =
Bool -> Permissions -> Permissions
Directory.setOwnerReadable Bool
True
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Permissions -> Permissions
Directory.setOwnerWritable Bool
True
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Permissions -> Permissions
Directory.setOwnerSearchable Bool
True
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
(forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> Permissions -> IO ()
Directory.setPermissions String
dir Permissions
private))
(forall {m :: * -> *} {b}.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> String -> IOException -> m b
handler String
"correct the permissions for" String
dir)
let assertPermissions :: String -> m ()
assertPermissions String
dir = do
let accessible :: Permissions -> Bool
accessible Permissions
path =
Permissions -> Bool
Directory.readable Permissions
path
Bool -> Bool -> Bool
&& Permissions -> Bool
Directory.writable Permissions
path
Bool -> Bool -> Bool
&& Permissions -> Bool
Directory.searchable Permissions
path
Permissions
permissions <-
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Permissions
Directory.getPermissions String
dir))
(forall {m :: * -> *} {b}.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> String -> IOException -> m b
handler String
"get permissions of" String
dir)
if Permissions -> Bool
accessible Permissions
permissions
then
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
let render :: (Permissions -> Bool) -> a
render Permissions -> Bool
f = if Permissions -> Bool
f Permissions
permissions then a
"✓" else a
"✗"
let message :: String
message =
String
"The directory:\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"↳ " forall a. Semigroup a => a -> a -> a
<> String
dir forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"... does not give you permission to read, write, or search files.\n\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"The directory's current permissions are:\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"• " forall a. Semigroup a => a -> a -> a
<> forall {a}. IsString a => (Permissions -> Bool) -> a
render Permissions -> Bool
Directory.readable forall a. Semigroup a => a -> a -> a
<> String
" readable\n"
forall a. Semigroup a => a -> a -> a
<> String
"• " forall a. Semigroup a => a -> a -> a
<> forall {a}. IsString a => (Permissions -> Bool) -> a
render Permissions -> Bool
Directory.writable forall a. Semigroup a => a -> a -> a
<> String
" writable\n"
forall a. Semigroup a => a -> a -> a
<> String
"• " forall a. Semigroup a => a -> a -> a
<> forall {a}. IsString a => (Permissions -> Bool) -> a
render Permissions -> Bool
Directory.searchable forall a. Semigroup a => a -> a -> a
<> String
" searchable\n"
forall {m :: * -> *} {b}.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> m b
warn String
message
let existsDirectory :: String -> m Bool
existsDirectory String
dir =
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
Directory.doesDirectoryExist String
dir))
(forall {m :: * -> *} {b}.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> String -> IOException -> m b
handler String
"check the existence of" String
dir)
let existsFile :: String -> m Bool
existsFile String
path =
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
Directory.doesFileExist String
path))
(forall {m :: * -> *} {b}.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> String -> IOException -> m b
handler String
"check the existence of" String
path)
let createDirectory :: String -> m ()
createDirectory String
dir =
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
Directory.createDirectory String
dir))
(forall {m :: * -> *} {b}.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> String -> IOException -> m b
handler String
"create" String
dir)
let assertDirectory :: String -> m ()
assertDirectory String
dir = do
Bool
existsDir <- forall {m :: * -> *}.
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
Alternative m) =>
String -> m Bool
existsDirectory String
dir
if Bool
existsDir
then
forall {m :: * -> *}.
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
Alternative m) =>
String -> m ()
assertPermissions String
dir
else do
Bool
existsFile' <- forall {m :: * -> *}.
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
Alternative m) =>
String -> m Bool
existsFile String
dir
if Bool
existsFile'
then do
let message :: String
message =
String
"The given path:\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"↳ " forall a. Semigroup a => a -> a -> a
<> String
dir forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"... already exists but is not a directory.\n"
forall {m :: * -> *} {b}.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> m b
warn String
message
else do
String -> m ()
assertDirectory (ShowS
FilePath.takeDirectory String
dir)
forall {m :: * -> *}.
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
Alternative m) =>
String -> m ()
createDirectory String
dir
forall {m :: * -> *}.
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
Alternative m) =>
String -> m ()
setPermissions String
dir
String
cacheBaseDirectory <- forall (m :: * -> *).
(MonadState CacheWarning m, Alternative m, MonadIO m) =>
m String
getCacheBaseDirectory
let directory :: String
directory = String
cacheBaseDirectory String -> ShowS
</> String
cacheName
let message :: String
message =
String
"Could not get or create the default cache directory:\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"↳ " forall a. Semigroup a => a -> a -> a
<> String
directory forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"You can enable caching by creating it if needed and setting read,\n"
forall a. Semigroup a => a -> a -> a
<> String
"write and search permissions on it or providing another cache base\n"
forall a. Semigroup a => a -> a -> a
<> String
"directory by setting the $XDG_CACHE_HOME environment variable.\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall {m :: * -> *}.
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
Alternative m) =>
String -> m ()
assertDirectory String
directory forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {m :: * -> *} {b}.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> m b
warn String
message
forall (m :: * -> *) a. Monad m => a -> m a
return String
directory
getCacheBaseDirectory
:: (MonadState CacheWarning m, Alternative m, MonadIO m) => m FilePath
getCacheBaseDirectory :: forall (m :: * -> *).
(MonadState CacheWarning m, Alternative m, MonadIO m) =>
m String
getCacheBaseDirectory = m String
alternative₀ forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m String
alternative₁ forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {b}. m b
alternative₂
where
alternative₀ :: m String
alternative₀ = do
Maybe String
maybeXDGCacheHome <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
System.Environment.lookupEnv String
"XDG_CACHE_HOME")
case Maybe String
maybeXDGCacheHome of
Just String
xdgCacheHome -> forall (m :: * -> *) a. Monad m => a -> m a
return String
xdgCacheHome
Maybe String
Nothing -> forall (f :: * -> *) a. Alternative f => f a
empty
alternative₁ :: m String
alternative₁
| Bool
isWindows = do
Maybe String
maybeLocalAppDirectory <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
System.Environment.lookupEnv String
"LOCALAPPDATA")
case Maybe String
maybeLocalAppDirectory of
Just String
localAppDirectory -> forall (m :: * -> *) a. Monad m => a -> m a
return String
localAppDirectory
Maybe String
Nothing -> forall (f :: * -> *) a. Alternative f => f a
empty
| Bool
otherwise = do
Maybe String
maybeHomeDirectory <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
System.Environment.lookupEnv String
"HOME")
case Maybe String
maybeHomeDirectory of
Just String
homeDirectory -> forall (m :: * -> *) a. Monad m => a -> m a
return (String
homeDirectory String -> ShowS
</> String
".cache")
Maybe String
Nothing -> forall (f :: * -> *) a. Alternative f => f a
empty
where isWindows :: Bool
isWindows = String
System.Info.os forall a. Eq a => a -> a -> Bool
== String
"mingw32"
alternative₂ :: m b
alternative₂ = do
CacheWarning
cacheWarningStatus <- forall s (m :: * -> *). MonadState s m => m s
State.get
let message :: String
message =
String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;33mWarning\ESC[0m: "
forall a. Semigroup a => a -> a -> a
<> String
"Could not locate a cache base directory from the environment.\n"
forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"You can provide a cache base directory by pointing the $XDG_CACHE_HOME\n"
forall a. Semigroup a => a -> a -> a
<> String
"environment variable to a directory with read and write permissions.\n"
case CacheWarning
cacheWarningStatus of
CacheWarning
CacheNotWarned ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
System.IO.hPutStrLn Handle
System.IO.stderr String
message)
CacheWarning
CacheWarned ->
forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put CacheWarning
CacheWarned
forall (f :: * -> *) a. Alternative f => f a
empty
normalizeHeadersIn :: URL -> StateT Status IO URL
url :: URL
url@URL { headers :: URL -> Maybe (Expr Src Import)
headers = Just Expr Src Import
headersExpression } = do
Status { NonEmpty Chained
_stack :: NonEmpty Chained
_stack :: Status -> NonEmpty Chained
_stack } <- forall s (m :: * -> *). MonadState s m => m s
State.get
Expr Src Void
loadedExpr <- Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
headersExpression
let handler :: SomeException -> m a
handler (SomeException
e :: SomeException) = forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack SomeException
e)
Expr Src Void
normalized <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle forall {m :: * -> *} {a}. MonadCatch m => SomeException -> m a
handler (Expr Src Void -> IO (Expr Src Void)
normalizeHeaders Expr Src Void
loadedExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return URL
url { headers :: Maybe (Expr Src Import)
headers = forall a. a -> Maybe a
Just (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Void -> a
absurd Expr Src Void
normalized) }
normalizeHeadersIn URL
url = forall (m :: * -> *) a. Monad m => a -> m a
return URL
url
emptyOriginHeaders :: Expr Src Import
= forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
ListLit (forall a. a -> Maybe a
Just (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Void -> a
absurd Expr Src Void
originHeadersTypeExpr)) forall a. Monoid a => a
mempty
headersSrc :: Src
= Src {
srcStart :: SourcePos
srcStart = SourcePos {
sourceName :: String
sourceName = String
fakeSrcName,
sourceLine :: Pos
sourceLine = Int -> Pos
mkPos Int
1,
sourceColumn :: Pos
sourceColumn = Int -> Pos
mkPos Int
1
},
srcEnd :: SourcePos
srcEnd = SourcePos {
sourceName :: String
sourceName = String
fakeSrcName,
sourceLine :: Pos
sourceLine = Int -> Pos
mkPos Int
1,
sourceColumn :: Pos
sourceColumn = Int -> Pos
mkPos (Text -> Int
Text.length Text
fakeSrcText)
},
srcText :: Text
srcText = Text
fakeSrcText
}
where
fakeSrcText :: Text
fakeSrcText = Text
"«Origin Header Configuration»"
fakeSrcName :: String
fakeSrcName = String
"[builtin]"
envOriginHeaders :: Expr Src Import
= forall s a. s -> Expr s a -> Expr s a
Note Src
headersSrc (forall s a. a -> Expr s a
Embed (ImportHashed -> ImportMode -> Import
Import (Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed forall a. Maybe a
Nothing (Text -> ImportType
Env Text
"DHALL_HEADERS")) ImportMode
Code))
defaultOriginHeaders :: IO (Expr Src Import)
#ifndef WITH_HTTP
defaultOriginHeaders = return emptyOriginHeaders
#else
= do
Expr Src Import
fromFile <- IO (Expr Src Import)
originHeadersFileExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. s -> Expr s a -> Expr s a
Note Src
headersSrc (forall s a. Expr s a -> Expr s a -> Expr s a
ImportAlt Expr Src Import
envOriginHeaders (forall s a. s -> Expr s a -> Expr s a
Note Src
headersSrc Expr Src Import
fromFile)))
#endif
originHeadersLoader :: IO (Expr Src Import) -> StateT Status IO OriginHeaders
IO (Expr Src Import)
headersExpr = do
Status
status <- forall s (m :: * -> *). MonadState s m => m s
State.get
let parentStack :: NonEmpty Chained
parentStack = forall a. a -> Maybe a -> a
fromMaybe forall {b}. b
abortEmptyStack (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (forall a. NonEmpty a -> [a]
NonEmpty.tail (Status -> NonEmpty Chained
_stack Status
status)))
let headerLoadStatus :: Status
headerLoadStatus = Status
status { _stack :: NonEmpty Chained
_stack = NonEmpty Chained
parentStack }
(OriginHeaders
headers, Status
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT StateT Status IO OriginHeaders
doLoad Status
headerLoadStatus)
()
_ <- forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\Status
state -> Status
state { _loadOriginHeaders :: StateT Status IO OriginHeaders
_loadOriginHeaders = forall (m :: * -> *) a. Monad m => a -> m a
return OriginHeaders
headers })
forall (m :: * -> *) a. Monad m => a -> m a
return OriginHeaders
headers
where
abortEmptyStack :: b
abortEmptyStack = Text -> forall {b}. b
Core.internalError Text
"Origin headers loaded with an empty stack"
doLoad :: StateT Status IO OriginHeaders
doLoad = do
Expr Src Import
partialExpr <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Expr Src Import)
headersExpr
Expr Src Void
loaded <- Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith (forall s a. s -> Expr s a -> Expr s a
Note Src
headersSrc (forall s a. Expr s a -> Expr s a -> Expr s a
ImportAlt Expr Src Import
partialExpr Expr Src Import
emptyOriginHeaders))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Expr Src Void -> IO OriginHeaders
toOriginHeaders Expr Src Void
loaded)
emptyStatus :: FilePath -> Status
emptyStatus :: String -> Status
emptyStatus = IO Manager -> IO (Expr Src Import) -> String -> Status
makeEmptyStatus IO Manager
defaultNewManager IO (Expr Src Import)
defaultOriginHeaders
emptyStatusWithManager
:: IO Manager
-> FilePath
-> Status
emptyStatusWithManager :: IO Manager -> String -> Status
emptyStatusWithManager IO Manager
newManager = IO Manager -> IO (Expr Src Import) -> String -> Status
makeEmptyStatus IO Manager
newManager IO (Expr Src Import)
defaultOriginHeaders
makeEmptyStatus
:: IO Manager
-> IO (Expr Src Import)
-> FilePath
-> Status
makeEmptyStatus :: IO Manager -> IO (Expr Src Import) -> String -> Status
makeEmptyStatus IO Manager
newManager IO (Expr Src Import)
headersExpr String
rootDirectory =
IO Manager
-> StateT Status IO OriginHeaders
-> (URL -> StateT Status IO Text)
-> (URL -> StateT Status IO ByteString)
-> Import
-> Status
emptyStatusWith IO Manager
newManager (IO (Expr Src Import) -> StateT Status IO OriginHeaders
originHeadersLoader IO (Expr Src Import)
headersExpr) URL -> StateT Status IO Text
fetchRemote URL -> StateT Status IO ByteString
fetchRemoteBytes Import
rootImport
where
prefix :: FilePrefix
prefix = if String -> Bool
FilePath.isRelative String
rootDirectory
then FilePrefix
Here
else FilePrefix
Absolute
pathComponents :: [Text]
pathComponents =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
Text.pack (forall a. [a] -> [a]
reverse (String -> [String]
FilePath.splitDirectories String
rootDirectory))
directoryAsFile :: File
directoryAsFile = Directory -> Text -> File
File ([Text] -> Directory
Directory [Text]
pathComponents) Text
"."
rootImport :: Import
rootImport = Import
{ importHashed :: ImportHashed
importHashed = ImportHashed
{ hash :: Maybe SHA256Digest
hash = forall a. Maybe a
Nothing
, importType :: ImportType
importType = FilePrefix -> File -> ImportType
Local FilePrefix
prefix File
directoryAsFile
}
, importMode :: ImportMode
importMode = ImportMode
Code
}
remoteStatus
:: URL
-> Status
remoteStatus :: URL -> Status
remoteStatus = IO Manager -> URL -> Status
remoteStatusWithManager IO Manager
defaultNewManager
remoteStatusWithManager :: IO Manager -> URL -> Status
remoteStatusWithManager :: IO Manager -> URL -> Status
remoteStatusWithManager IO Manager
newManager URL
url =
IO Manager
-> StateT Status IO OriginHeaders
-> (URL -> StateT Status IO Text)
-> (URL -> StateT Status IO ByteString)
-> Import
-> Status
emptyStatusWith IO Manager
newManager (IO (Expr Src Import) -> StateT Status IO OriginHeaders
originHeadersLoader (forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr Src Import
emptyOriginHeaders)) URL -> StateT Status IO Text
fetchRemote URL -> StateT Status IO ByteString
fetchRemoteBytes Import
rootImport
where
rootImport :: Import
rootImport = Import
{ importHashed :: ImportHashed
importHashed = ImportHashed
{ hash :: Maybe SHA256Digest
hash = forall a. Maybe a
Nothing
, importType :: ImportType
importType = URL -> ImportType
Remote URL
url
}
, importMode :: ImportMode
importMode = ImportMode
Code
}
loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
expr₀ = case Expr Src Import
expr₀ of
Embed Import
import₀ -> do
Status {[Depends]
Maybe Manager
Maybe (ReifiedNormalizer Void)
IO Manager
NonEmpty Chained
StateT Status IO OriginHeaders
Context (Expr Src Void)
Substitutions Src Void
Map Chained ImportSemantics
CacheWarning
SemanticCacheMode
URL -> StateT Status IO ByteString
URL -> StateT Status IO Text
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remoteBytes :: URL -> StateT Status IO ByteString
_remote :: URL -> StateT Status IO Text
_loadOriginHeaders :: StateT Status IO OriginHeaders
_manager :: Maybe Manager
_newManager :: IO Manager
_cache :: Map Chained ImportSemantics
_graph :: [Depends]
_stack :: NonEmpty Chained
_cacheWarning :: Status -> CacheWarning
_semanticCacheMode :: Status -> SemanticCacheMode
_startingContext :: Status -> Context (Expr Src Void)
_normalizer :: Status -> Maybe (ReifiedNormalizer Void)
_substitutions :: Status -> Substitutions Src Void
_remoteBytes :: Status -> URL -> StateT Status IO ByteString
_remote :: Status -> URL -> StateT Status IO Text
_loadOriginHeaders :: Status -> StateT Status IO OriginHeaders
_manager :: Status -> Maybe Manager
_newManager :: Status -> IO Manager
_cache :: Status -> Map Chained ImportSemantics
_graph :: Status -> [Depends]
_stack :: Status -> NonEmpty Chained
..} <- forall s (m :: * -> *). MonadState s m => m s
State.get
let parent :: Chained
parent = forall a. NonEmpty a -> a
NonEmpty.head NonEmpty Chained
_stack
Chained
child <- Chained -> Import -> StateT Status IO Chained
chainImport Chained
parent Import
import₀
let local :: Chained -> Bool
local (Chained (Import (ImportHashed Maybe SHA256Digest
_ (Remote {})) ImportMode
_)) = Bool
False
local (Chained (Import (ImportHashed Maybe SHA256Digest
_ (Local {})) ImportMode
_)) = Bool
True
local (Chained (Import (ImportHashed Maybe SHA256Digest
_ (Env {})) ImportMode
_)) = Bool
True
local (Chained (Import (ImportHashed Maybe SHA256Digest
_ (Missing {})) ImportMode
_)) = Bool
False
let referentiallySane :: Bool
referentiallySane = Bool -> Bool
not (Chained -> Bool
local Chained
child) Bool -> Bool -> Bool
|| Chained -> Bool
local Chained
parent
if Import -> ImportMode
importMode Import
import₀ forall a. Eq a => a -> a -> Bool
== ImportMode
Location Bool -> Bool -> Bool
|| Bool
referentiallySane
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (Import -> ReferentiallyOpaque
ReferentiallyOpaque Import
import₀))
let _stack' :: NonEmpty Chained
_stack' = forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.cons Chained
child NonEmpty Chained
_stack
if Chained
child forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` NonEmpty Chained
_stack
then forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (Import -> Cycle
Cycle Import
import₀))
else forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom forall (f :: * -> *). Functor f => LensLike' f Status [Depends]
graph forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify forall a b. (a -> b) -> a -> b
$
\[Depends]
edges -> Chained -> Chained -> Depends
Depends Chained
parent Chained
child forall a. a -> [a] -> [a]
: [Depends]
edges
let stackWithChild :: NonEmpty Chained
stackWithChild = forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.cons Chained
child NonEmpty Chained
_stack
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom forall (f :: * -> *).
Functor f =>
LensLike' f Status (NonEmpty Chained)
stack (forall s (m :: * -> *). MonadState s m => s -> m ()
State.put NonEmpty Chained
stackWithChild)
ImportSemantics {Expr Void Void
importSemantics :: Expr Void Void
importSemantics :: ImportSemantics -> Expr Void Void
..} <- Chained -> StateT Status IO ImportSemantics
loadImport Chained
child
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom forall (f :: * -> *).
Functor f =>
LensLike' f Status (NonEmpty Chained)
stack (forall s (m :: * -> *). MonadState s m => s -> m ()
State.put NonEmpty Chained
_stack)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a s. Expr Void a -> Expr s a
Core.renote Expr Void Void
importSemantics)
ImportAlt Expr Src Import
a Expr Src Import
b -> Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
a forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SourcedException MissingImports -> StateT Status IO (Expr Src Void)
handler₀
where
is :: forall e . Exception e => SomeException -> Bool
is :: forall e. Exception e => SomeException -> Bool
is SomeException
exception = forall a. Maybe a -> Bool
Maybe.isJust (forall e. Exception e => SomeException -> Maybe e
Exception.fromException @e SomeException
exception)
isNotResolutionError :: SomeException -> Bool
isNotResolutionError SomeException
exception =
forall e. Exception e => SomeException -> Bool
is @(Imported (TypeError Src Void)) SomeException
exception
Bool -> Bool -> Bool
|| forall e. Exception e => SomeException -> Bool
is @(Imported Cycle ) SomeException
exception
Bool -> Bool -> Bool
|| forall e. Exception e => SomeException -> Bool
is @(Imported HashMismatch ) SomeException
exception
Bool -> Bool -> Bool
|| forall e. Exception e => SomeException -> Bool
is @(Imported ParseError ) SomeException
exception
handler₀ :: SourcedException MissingImports -> StateT Status IO (Expr Src Void)
handler₀ exception₀ :: SourcedException MissingImports
exception₀@(SourcedException (Src SourcePos
begin SourcePos
_ Text
text₀) (MissingImports [SomeException]
es₀))
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SomeException -> Bool
isNotResolutionError [SomeException]
es₀ =
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SourcedException MissingImports
exception₀
| Bool
otherwise = do
Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
b forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall {m :: * -> *} {a}.
MonadThrow m =>
SourcedException MissingImports -> m a
handler₁
where
handler₁ :: SourcedException MissingImports -> m a
handler₁ exception₁ :: SourcedException MissingImports
exception₁@(SourcedException (Src SourcePos
_ SourcePos
end Text
text₁) (MissingImports [SomeException]
es₁))
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SomeException -> Bool
isNotResolutionError [SomeException]
es₁ =
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SourcedException MissingImports
exception₁
| Bool
otherwise =
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (forall e. Src -> e -> SourcedException e
SourcedException (SourcePos -> SourcePos -> Text -> Src
Src SourcePos
begin SourcePos
end Text
text₂) ([SomeException] -> MissingImports
MissingImports ([SomeException]
es₀ forall a. [a] -> [a] -> [a]
++ [SomeException]
es₁)))
where
text₂ :: Text
text₂ = Text
text₀ forall a. Semigroup a => a -> a -> a
<> Text
" ? " forall a. Semigroup a => a -> a -> a
<> Text
text₁
Note Src
a Expr Src Import
b -> do
let handler :: MissingImports -> m a
handler MissingImports
e = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (forall e. Src -> e -> SourcedException e
SourcedException Src
a (MissingImports
e :: MissingImports))
(forall s a. s -> Expr s a -> Expr s a
Note forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure Src
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
b) forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall {m :: * -> *} {a}. MonadThrow m => MissingImports -> m a
handler
Let Binding Src Import
a Expr Src Import
b -> forall s a. Binding s a -> Expr s a -> Expr s a
Let forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) s a b.
Applicative f =>
(Expr s a -> f (Expr s b)) -> Binding s a -> f (Binding s b)
bindingExprs Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Binding Src Import
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
b
Record Map Text (RecordField Src Import)
m -> forall s a. Map Text (RecordField s a) -> Expr s a
Record forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) s a b.
Applicative f =>
(Expr s a -> f (Expr s b))
-> RecordField s a -> f (RecordField s b)
recordFieldExprs Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith) Map Text (RecordField Src Import)
m
RecordLit Map Text (RecordField Src Import)
m -> forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) s a b.
Applicative f =>
(Expr s a -> f (Expr s b))
-> RecordField s a -> f (RecordField s b)
recordFieldExprs Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith) Map Text (RecordField Src Import)
m
Lam Maybe CharacterSet
cs FunctionBinding Src Import
a Expr Src Import
b -> forall s a.
Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
Lam Maybe CharacterSet
cs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) s a b.
Applicative f =>
(Expr s a -> f (Expr s b))
-> FunctionBinding s a -> f (FunctionBinding s b)
functionBindingExprs Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith FunctionBinding Src Import
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
b
Field Expr Src Import
a FieldSelection Src
b -> forall s a. Expr s a -> FieldSelection s -> Expr s a
Field forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldSelection Src
b
Expr Src Import
expression -> forall (f :: * -> *) s a t b.
Applicative f =>
(Expr s a -> f (Expr t b)) -> Expr s a -> f (Expr t b)
Syntax.unsafeSubExpressions Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
expression
load :: Expr Src Import -> IO (Expr Src Void)
load :: Expr Src Import -> IO (Expr Src Void)
load = IO Manager -> Expr Src Import -> IO (Expr Src Void)
loadWithManager IO Manager
defaultNewManager
loadWithManager :: IO Manager -> Expr Src Import -> IO (Expr Src Void)
loadWithManager :: IO Manager -> Expr Src Import -> IO (Expr Src Void)
loadWithManager IO Manager
newManager =
Status
-> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void)
loadWithStatus
(IO Manager -> IO (Expr Src Import) -> String -> Status
makeEmptyStatus IO Manager
newManager IO (Expr Src Import)
defaultOriginHeaders String
".")
SemanticCacheMode
UseSemanticCache
printWarning :: (MonadIO m) => String -> m ()
printWarning :: forall (m :: * -> *). MonadIO m => String -> m ()
printWarning String
message = do
let warning :: String
warning =
String
"\n"
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;33mWarning\ESC[0m: "
forall a. Semigroup a => a -> a -> a
<> String
message
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
System.IO.hPutStrLn Handle
System.IO.stderr String
warning
loadRelativeTo :: FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void)
loadRelativeTo :: String
-> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void)
loadRelativeTo String
parentDirectory = Status
-> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void)
loadWithStatus
(IO Manager -> IO (Expr Src Import) -> String -> Status
makeEmptyStatus IO Manager
defaultNewManager IO (Expr Src Import)
defaultOriginHeaders String
parentDirectory)
loadWithStatus
:: Status
-> SemanticCacheMode
-> Expr Src Import
-> IO (Expr Src Void)
loadWithStatus :: Status
-> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void)
loadWithStatus Status
status SemanticCacheMode
semanticCacheMode Expr Src Import
expression =
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT
(Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
expression)
Status
status { _semanticCacheMode :: SemanticCacheMode
_semanticCacheMode = SemanticCacheMode
semanticCacheMode }
encodeExpression :: Expr Void Void -> Data.ByteString.ByteString
encodeExpression :: Expr Void Void -> ByteString
encodeExpression Expr Void Void
expression = ByteString
bytesStrict
where
intermediateExpression :: Expr Void Import
intermediateExpression :: Expr Void Import
intermediateExpression = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Void -> a
absurd Expr Void Void
expression
encoding :: Encoding
encoding = forall a. Serialise a => a -> Encoding
Codec.Serialise.encode Expr Void Import
intermediateExpression
bytesStrict :: ByteString
bytesStrict = Encoding -> ByteString
Write.toStrictByteString Encoding
encoding
hashExpression :: Expr Void Void -> Dhall.Crypto.SHA256Digest
hashExpression :: Expr Void Void -> SHA256Digest
hashExpression = ByteString -> SHA256Digest
Dhall.Crypto.sha256Hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Void Void -> ByteString
encodeExpression
hashExpressionToCode :: Expr Void Void -> Text
hashExpressionToCode :: Expr Void Void -> Text
hashExpressionToCode Expr Void Void
expr =
Text
"sha256:" forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show (Expr Void Void -> SHA256Digest
hashExpression Expr Void Void
expr))
data ImportResolutionDisabled = ImportResolutionDisabled deriving (Show ImportResolutionDisabled
Typeable ImportResolutionDisabled
SomeException -> Maybe ImportResolutionDisabled
ImportResolutionDisabled -> String
ImportResolutionDisabled -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: ImportResolutionDisabled -> String
$cdisplayException :: ImportResolutionDisabled -> String
fromException :: SomeException -> Maybe ImportResolutionDisabled
$cfromException :: SomeException -> Maybe ImportResolutionDisabled
toException :: ImportResolutionDisabled -> SomeException
$ctoException :: ImportResolutionDisabled -> SomeException
Exception)
instance Show ImportResolutionDisabled where
show :: ImportResolutionDisabled -> String
show ImportResolutionDisabled
_ = String
"\nImport resolution is disabled"
assertNoImports :: MonadIO io => Expr Src Import -> io (Expr Src Void)
assertNoImports :: forall (io :: * -> *).
MonadIO io =>
Expr Src Import -> io (Expr Src Void)
assertNoImports Expr Src Import
expression =
forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Import
_ -> forall a b. a -> Either a b
Left ImportResolutionDisabled
ImportResolutionDisabled) Expr Src Import
expression)
{-# INLINABLE assertNoImports #-}
dependencyToFile :: Status -> Import -> IO (Maybe FilePath)
dependencyToFile :: Status -> Import -> IO (Maybe String)
dependencyToFile Status
status Import
import_ = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT Status
status forall a b. (a -> b) -> a -> b
$ do
Chained
parent :| [Chained]
_ <- forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom forall (f :: * -> *).
Functor f =>
LensLike' f Status (NonEmpty Chained)
stack forall s (m :: * -> *). MonadState s m => m s
State.get
Import
child <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Chained -> Import
chainedImport (forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
(b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Chained -> Import -> StateT Status IO Chained
chainImport Chained
parent Import
import_))
let ignore :: StateT Status IO (Maybe a)
ignore = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
case Import -> ImportMode
importMode Import
child of
ImportMode
RawText ->
forall {a}. StateT Status IO (Maybe a)
ignore
ImportMode
RawBytes ->
forall {a}. StateT Status IO (Maybe a)
ignore
ImportMode
Location ->
forall {a}. StateT Status IO (Maybe a)
ignore
ImportMode
Code ->
case ImportHashed -> ImportType
importType (Import -> ImportHashed
importHashed Import
child) of
Local FilePrefix
filePrefix File
file -> do
let descend :: StateT Status IO (Maybe String)
descend = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
String
path <- forall (io :: * -> *).
MonadIO io =>
FilePrefix -> File -> io String
localToPath FilePrefix
filePrefix File
file
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just String
path)
case ImportHashed -> ImportType
importType (Import -> ImportHashed
importHashed Import
import_) of
Local FilePrefix
Here File
_ -> StateT Status IO (Maybe String)
descend
Local FilePrefix
Parent File
_ -> StateT Status IO (Maybe String)
descend
ImportType
_ -> forall {a}. StateT Status IO (Maybe a)
ignore
Remote{} ->
forall {a}. StateT Status IO (Maybe a)
ignore
ImportType
Missing ->
forall {a}. StateT Status IO (Maybe a)
ignore
Env{} ->
forall {a}. StateT Status IO (Maybe a)
ignore